; with-heap-string.lisp
;
; Run body with a heap-allocated simple-base-string.

(in-package :ccl)

; During body, string will be bound to a simple-base-string with
; length characters, and buf will be bound to a macptr pointing
; at the contents of string.
; string will print as a bogus-object, but other string manipulation
; functions will work fine with it.
(defmacro with-heap-string ((string buf length) &body body)
  (let ((len (gensym)))
    `(let ((,len ,length)
           (,string nil)
           (,buf nil))
       (unwind-protect
         (progn
           (multiple-value-setq (,string ,buf)
             (%make-heap-string ,len))
           ,@body)
         (when ,string
           (%dispose-heap-ivector ,string))))))

#+ppc-target
(defun %make-heap-string (len)
  (%make-heap-ivector ppc::subtag-simple-base-string len len))

#-ppc-target
(progn

(eval-when (:compile-toplevel :execute)
  (require "LISPEQU")
  (require "LAPMACROS"))

(defun %make-heap-string (len)
  (let ((v (%make-heap-ivector $v_sstr len)))
    (values v
            (lap-inline ($v_data v)
              (getint arg_y)
              (add.l arg_y arg_z) 
              (move.l arg_z atemp0)
              (jsr_subprim $sp-consmacptr)))))

)

(defconstant $bm-packet-size 8192)

; buffer-substring-patch.lisp
;
; Patch buffer-substring to accept a new, optional, string arg.
; If the string arg is specified, of the right type, and long enough,
; fill it instead of consing up a new string.

(in-package :ccl)

(let ((*warn-if-redefine* nil)
      (*warn-if-redefine-kernel* nil))

(defun buffer-substring (mark end &optional start string)
  (multiple-value-setq (start end)(buffer-range mark end start))
  (locally (declare (fixnum start end)(optimize (speed 3)(safety 0)))
    (let* ((buf (mark.buffer mark))
           (gappos (bf.gappos buf))
           (type (bf-chartype buf))
           (shft (bf.logsiz buf))
           (chunkarr (bf.chunkarr buf))
           (gaplen (%i- (bf.gapend buf)(bf.gapstart buf)))
           (chunksz (bf.chunksz buf))
           (chars-left (- end start))
           (spos 0)           
           (nchars 0)
           (sidx 0)
           cross)
      (declare (fixnum  gappos chunksz mask spos chars-left gaplen sidx nchars))
      ;(print (list len start end (length string) (- start end)))
      (when (or (null string)
                (let ((string-type (array-element-type string)))
                  (not (or (eq string-type type)
                           (let ((types '(character extended-character)))
                             (and (memq string-type types)
                                  (memq type types))))))
                (< (length string) chars-left))
        (setq string (make-string chars-left :element-type type)))
      (cond
       ((>= start gappos)
        (setq start (+ start gaplen)))
       ((> end gappos)
        (setq chars-left (- gappos start))
        (setq cross t)))
      (setq sidx (%iasr shft start))
      (setq start (%ilogand (%i- chunksz 1) start))
      (loop
        (setq nchars (- chunksz start))
        (if (< chars-left nchars)(setq nchars chars-left))
        (move-string-bytes (svref chunkarr sidx) string start spos nchars)        
        (setq chars-left (- chars-left nchars))
        (cond ((= chars-left 0)
               (if cross
                 (let ((gapend (bf.gapend buf)))
                   (setq start (%ilogand (%i- chunksz 1) gapend))
                   (setq sidx (%iasr shft (%i+ gappos gaplen)))
                   (setq chars-left (- end gappos))
                   (setq cross nil))
                 (return)))
              (t 
               (setq start 0)
               (setq sidx (1+ sidx))))
        (setq spos (+ spos nchars)))
      string)))

)

;;;
;;; ml: I renaimed buffer by packet to avoid confusion with the real buffer
;;; BUGGY use block do dealocate mem
;;;
(defun find-bm-tables-in-buffer (bm-tables buffer &optional found-function)
  (unless found-function
    (let (res)
      (setq found-function
            #'(lambda (pos)
                (if pos
                  (push pos res)
                  (prog1 (nreverse res) (setq res nil)))))))                
  
  (let* ((len (bm-tables-len bm-tables))
         (len-1 (1- len))
         ; (packet-size (- $bm-packet-size len-1))
         (size 0)
         (bytes-read 0)
         
         (index 0)
         (buffer-size (buffer-size buffer))
         (buffer-pos 0)
         )
    (declare (fixnum len packet-size size bytes-read base))
    
    (when (> buffer-size $bm-packet-size)
      (setq size $bm-packet-size)
      (with-heap-string (s b size)
        
        (buffer-substring buffer buffer-pos  (+ buffer-pos size) s)
    
        ;; increment the buffer with size minis the length of the string
        ;; in case of overlapping between two buffers
        (setq buffer-pos (+ buffer-pos (- size len-1)))

        (loop

          (setq index 0)
          (loop
            
            (if (setq index (bm-search-array bm-tables b index size))
              (progn
                (unless (funcall found-function (+ index bytes-read))
                  (return-from find-bm-tables-in-buffer nil))
                (setq index (the fixnum (1+ (the fixnum index)))))
              (return nil)))


          ;; if the remaining is less than the buffer size
          ;; then quit the loop but undo the previous add

          (when (< buffer-size (+ buffer-pos size))
            (return))

          (buffer-substring buffer (+ buffer-pos size) buffer-pos s)

          (setq bytes-read buffer-pos)
          ;; increment the buffer with size minis the length of the string
          ;; in case of overlapping between two buffers
          (setq buffer-pos (+ buffer-pos (- size len-1)))
          
          )
        ))
    
    ;; read the remaining of the buffer (ie: a string < $bm-packet-size)
    ;;
    (setq size (- buffer-size buffer-pos))
    (setq bytes-read buffer-pos)
    (with-heap-string (s b size)
      (buffer-substring buffer buffer-pos t s)
      (setq index 0)
      (loop
        (if (setq index (bm-search-array bm-tables b index size))
          (progn
           (unless (funcall found-function (+ index bytes-read))
              (return-from find-bm-tables-in-buffer nil))
            (setq index (the fixnum (1+ (the fixnum index)))))
          (return nil)))
      )

    (funcall found-function nil)
    ))



(defun bm-find-string-in-buffer (string file &optional found-function)
  (find-bm-tables-in-buffer (compute-bm-tables string) file found-function)
  )

(defun find-firstbm-tables-in-buffer (bm-tables buffer)
  (let* ((len (bm-tables-len bm-tables))
         (len-1 (1- len))
         ; (packet-size (- $bm-packet-size len-1))
         (size 0)
         (bytes-read 0)
         
         (index 0)
         (buffer-size (buffer-size buffer))
         (buffer-pos 0)
         result
         )
    (declare (fixnum len packet-size size bytes-read base))
    
    (when (> buffer-size $bm-packet-size)
      (setq size $bm-packet-size)
      (with-heap-string (s b size)
        (block first-block
          (buffer-substring buffer buffer-pos  (+ buffer-pos size) s)
          
          ;; increment the buffer with size minis the length of the string
          ;; in case of overlapping between two buffers
          (setq buffer-pos (+ buffer-pos (- size len-1)))
          
          (loop
            
            (when (setq index (bm-search-array bm-tables b 0 size))
              (setf result (+ index bytes-read))
              (return-from first-block nil)
              )
            
            ;; if the remaining is less than the buffer size
            ;; then quit the loop but undo the previous add
            
            (when (< buffer-size (+ buffer-pos size))
              (return))
            
            (buffer-substring buffer (+ buffer-pos size) buffer-pos s)
            
            (setq bytes-read buffer-pos)
            ;; increment the buffer with size minis the length of the string
            ;; in case of overlapping between two buffers
            (setq buffer-pos (+ buffer-pos (- size len-1)))
            
            )
          )))
    
    (unless result
      ;; read the remaining of the buffer (ie: a string < $bm-packet-size)
      ;;
      (setq size (- buffer-size buffer-pos))
      (setq bytes-read buffer-pos)
      (with-heap-string (s b size)
        (block second-block
          (buffer-substring buffer buffer-pos t s)
          (if (setq index (bm-search-array bm-tables b 0 size))
            (setf result (+ index bytes-read))
            (return-from second-block nil )
            )
          )
        ))
    result
    ))

#|

(setf file (choose-file-dialog))
(setf buffer (make-buffer))

(buffer-insert-file buffer file)


(time
(bm-find-string-in-buffer "aller1" buffer)
)

(time
(bm-find-string-in-buffer "avoir" buffer)
)

(buffer-string-pos buffer "Czzzf" :start 1)
(buffer-string-pos buffer "azur" :start 1)


(time
(find-bm-tables-in-file (compute-bm-tables "aller1" nil) file)
)

(bm-find-string-in-file "\"Cf" file)


|#


 #|
(bm-tables-len (compute-bm-tables "5" t))

(time
 (find-firstbm-tables-in-buffer (compute-bm-tables "a" t) buffer)
 )

(time
(buffer-string-pos buffer "mathieulafourcade" :start 0)
)
|#

#|

(time
(with-heap-string (s b (* $bm-buffer-size 5))
  b
  (my-buffer-substring buffer s 0 (+ 0 (* $bm-buffer-size 5)))
  ;(subseq s 0 (length s))
  )
)

(time (progn (buffer-substring buffer 0 (+ 0 (* $bm-buffer-size 5))) nil))

|#