(in-package :atef)

; 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
;;;
(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
    ))

;;;---------------------------------------------------------------------------
;;; PATCHES
;;;---------------------------------------------------------------------------

;;;---------------------------------------------------------------------------
;;;
(let ((*warn-if-redefine* nil)
      (*warn-if-redefine-kernel* nil))
  
  (defun apply (function arg &rest args)
    "Applies FUNCTION to a list of arguments produced by evaluating ARGS in
  the manner of LIST*.  That is, a list is made of the values of all but the
  last argument, appended to the value of the last argument, which must be a
  list."
    (declare (dynamic-extent args))
    (cond ((null args)
           (apply function arg))
          ((null (cdr args))
           (apply function arg (car args)))
          (t (do* ((a1 args a2)
                   (a2 (cdr args) (cdr a2)))
                  ((atom (cdr a2))
                   (rplacd a1 (car a2))
                   (apply function arg args))))))
  )

;;;---------------------------------------------------------------------------
;;; STACK FUNCTIONS
;;;---------------------------------------------------------------------------
(in-package :atef)

;;;---------------------------------------------------------------------------
;;;
(defclass atef-stack-class ()
  ((contents :initarg :contents  
            :initform nil      
            :accessor stack-contents)
   ))

;;;---------------------------------------------------------------------------
;;; 
(defmethod stack-top ((self atef-stack-class))
  (first (stack-contents self)))

;;;---------------------------------------------------------------------------
;;; 
(defmethod stack-push! ((self atef-stack-class) object)
  ;; L'objet est pousse
  (setf (stack-contents self)
        (cons object (stack-contents self)))
  )

;;;---------------------------------------------------------------------------
;;; 
(defmethod stack-push-list! ((self atef-stack-class) object-list)
  (setf (stack-contents self)
        (revappend object-list (stack-contents self))
        ))

;;;---------------------------------------------------------------------------
;;; 
(defmethod stack-push-reversed-list! ((self atef-stack-class) object-list)
  (setf (stack-contents self)
        (append object-list (stack-contents self)))
  )

;;;---------------------------------------------------------------------------
;;; 
(defmethod stack-pop! ((self atef-stack-class))
  (if (stack-contents self)
    ;; La pile n'est pas vide
    ;; On sauve le sommet de pile
    (let ((x (first (stack-contents self))))
      (setf (stack-contents self) (rest (stack-contents self)))
      ;; On retourne le sommet de pile
      x)
    
    ;; La pile est vide, on retourne faux
    )
  )

;;;---------------------------------------------------------------------------
;;; 
(defmethod stack-purge! ((self atef-stack-class))
  (setf (stack-contents self) nil)
  )

;;;---------------------------------------------------------------------------
;;;
;;;---------------------------------------------------------------------------

;;;---------------------------------------------------------------------------
;;;
(defun get-keyword (list keyword)
  (let ((pos (position keyword list))
        )
    (when pos (nth (+ pos 1) list))))

;;;---------------------------------------------------------------------------
;;;
(defun delete-keyword (list keyword)
  (let ((pos (position keyword list))
        )
    (if pos (append (subseq list 0 pos) (subseq list (+ pos 2)))
        list)))

;; (delete-keyword '(1 2 3 4 :toto 5 6 7 8) :toto)


;;;---------------------------------------------------------------------------
;;; STRINGS functions
;;;---------------------------------------------------------------------------

(defun words (string)
  (do ((s (string-left-trim '(#\space) string))
       (n 0) ; counter
       (temp nil))
      ((equal s "") n) ; condition : s is finished
    (incf n)
    (setf temp (search " " s))
    (setf s (string-left-trim 
             '(#\space)
             (if temp (subseq s (+ temp 1)) "" ))
          )
        ))

;; (words "Now is the time")       -> 4
;; (words "")                      -> 0


;; End Of file