* Basic
** [[/Users/Can/Develop/Lisp/others/young/basic/string.cl][string]]
#+BEGIN_SRC lisp 
(load-code "/basic/concat.cl")

(defun println (string)
  (format t "~a~%" string))


(defun string-join (string-list &optional (seperator ""))
  "The list must consist of Strings"
  (let ((result (first string-list)))
    (dolist (string (rest string-list) result)
      (setf result (string+ result seperator string)))))

(defun join (&rest string-list)
  (string-join string-list " "))

(defun string-repeat (string n)
  "Create a string repeated n times"
  (string-join (fill (make-list n) string)))

(defun print-repeat (s n)
  (dotimes (i n)
    (println (string-repeat s (1+ i))))
  (dotimes (i (1- n))
    (println (string-repeat s (- n 1 i))))
  (values))

(defun surrounded-string (string &optional (surrounder "\""))
  (string+ surrounder string surrounder))

(defun string-start-with (string prefix &key (ignore-case t))
  (eql 0 (search prefix string
		 :end2 (min (length string) (length prefix))
		 :test (if ignore-case 'char-equal 'eql))))

(defun start-with (string prefix)
  (string= string prefix :end1 (length prefix)))

#+END_SRC

** [[/Users/Can/Develop/Lisp/others/young/basic/sequence.cl][sequence]]
#+BEGIN_SRC lisp 
(defun put (value alist)
  (unless (null alist)
	(progn
	  (push value (cdr (last alist)))
	  alist)))
(defun vector-to-list (array)
  (coerce array 'list))
  ;; (map 'list #'identity array))
  
(defun list-to-vector (list)
  (coerce list 'vector))
;;  (map 'array #'identity list))

#+END_SRC

** [[/Users/Can/Develop/Lisp/others/young/basic/open.cl][open]]
#+BEGIN_SRC lisp 
(defun shell (cmd)
    #+clisp
        (let ((str (ext:run-shell-command cmd :output :stream)))
            (loop for line = (read-line str nil)
             until (null line)
             do (print line)))
    #+ecl 
        (si:system cmd)
    #+sbcl 
        (sb-ext:run-program "/bin/sh" (list "-c" cmd) :input nil :output *standard-output*)
    #+clozure 
    (ccl:run-program "/bin/sh" (list "-c" cmd) :input nil :output *standard-output*))


(defun visit (url &optional (browser "Google Chrome") (protocal "https"))
  "Visit a website with URL"
  (unless (string-start-with url "http")
    (setf url (concat-string protocal "://" url)))
  (shell (string-join `("open" ,url "-a" ,(surrounded-string browser)) " ")))

(defun finder (file &rest args)
  "Open the file with Mac's Finder"
  (setq file (cl-ppcre:regex-replace "^~/?" file (namestring (user-homedir-pathname))))
  (sb-ext:run-program "/usr/bin/open" `(,file ,@args)))
 

#+END_SRC

** [[/Users/Can/Develop/Lisp/others/young/basic/concat.cl][concat]]
#+BEGIN_SRC lisp 
(defun concat-string (&rest strings)
  (apply #'concatenate (cons 'string strings)))
(alias string+ concat-string)

(defun concat-list (&rest lists)
  (apply #'concatenate (cons 'list lists)))

(defun concat-vector (&rest vectors)
  (apply #'concatenate (cons 'vector vectors)))

#+END_SRC

** [[/Users/Can/Develop/Lisp/mine/basic/tool.cl][tool]]
#+BEGIN_SRC lisp 
;;==================Macros================
(defmacro with-gensyms ((&rest names) &body body)
  "(&rest names) == names  Just make it more readable, it should be a list"
  `(let ,(loop for n in names collect `(,n (gensym)))
     ,@body))

(defmacro mac (expr)
  `(pprint (macroexpand-1 ',expr)))

(defmacro labeled-time (codes)
  `(progn
    (format *trace-output* "~2&~a" ',codes)
    (time ,codes)))



;;==================Functions================
;; recursive
(defun flatten (xs)
  (let (-result-)
    (dolist (x xs -result-)
      (cond ((null x))
            ((atom x) (setf -result- (nconc -result- (list x))))
            (t (setf -result- (append -result- (flatten x))))))))
(flatten '(1 (6 7 2) 3 4 (4 (5 6 ) nil (1 ( 3 (5 6)) 9))))
;; => (1 6 7 2 3 4 4 5 6 1 3 5 6 9) 

;;; Deep remove-if
(defun prune (test tree)
  (let (-list-)
    (dolist (x tree (nreverse -list-))
      (if (atom x)
          (unless (funcall test x) (push x -list-))
          (push (prune test x) -list-)))))
(prune #'evenp '(1 2 (3 (4 5) 6) 7 8 (((12))) (13) 22 (20) (9)))
;; => (1 (3 (5)) 7 ((nil)) (13) nil (9))

;;; Deep mapcar
(defun rmapcar (fn &rest args)
  (if (some #'atom args)
      (apply fn args)
      (apply #'mapcar
             #'(lambda (&rest lst) (apply #'rmapcar fn lst))
             args)))
(rmapcar #'* '(1 (2 (3) 4)) '(10 (20 (30) 40)))
;; => (10 (40 (90) 160))  

(defun memoize (fn)
  (let ((cache (make-hash-table :test #'equal)))
    #'(lambda (&rest args)
        (multiple-value-bind (val win) (gethash args cache)
          (if win
              val
              (setf (gethash args cache) 
                    (apply fn args)))))))

(defun compose (&rest fns)
  (if fns
      (let ((fn1 (car (last fns)))
            (fns (butlast fns)))
        #'(lambda (&rest args)
            (reduce #'funcall fns 
                    :from-end t
                    :initial-value (apply fn1 args))))
      #'identity))

#+END_SRC

** [[/Users/Can/Develop/Lisp/mine/basic/time.cl][time]]
#+BEGIN_SRC lisp 
(in-package :cl-user)
(defparameter +day-names+
  '("Monday"
    "Tuesday"
    "Wednesday"
    "Thursday"
    "Friday"
    "Saturday"
    "Sunday"))

(defun local-time (second minute hour date month year day-of-week dst-p tz)
  (declare (ignore dst-p))
  (format nil "~2,'0d:~2,'0d:~2,'0d of ~a, ~d/~2,'0d/~d (GMT~@d)"
          hour
          minute
	      second
	      (nth day-of-week +day-names+)
          month
	      date
	      year
	      (- tz)))

(defun now ()
  (apply 'local-time (multiple-value-list (get-decoded-time))))

;; (defun now (&optional destination)
;;   "Just print the time of now~"
;;   (multiple-value-bind
;;         (second minute hour date month year day-of-week dst-p tz)
;;       (get-decoded-time)
;;     (declare (ignore dst-p))
;;     (format destination "~2,'0d:~2,'0d:~2,'0d of ~a, ~d/~2,'0d/~d (GMT~@d)"
;;             hour
;;             minute
;; 	        second
;; 	        (nth day-of-week +day-names+)
;;             month
;; 	        date
;; 	        year
;; 	        (- tz))))

(defun file-write-time (file)
  (apply 'local-time
         (multiple-value-list (decode-universal-time (file-write-date file)))))

#+END_SRC

** [[/Users/Can/Develop/Lisp/mine/basic/string.cl][string]]
#+BEGIN_SRC lisp 
(defun println (s)
  (princ s)
  (princ "
"))

(defun string-join (string-list &optional (seperator ""))
  "The list must consist of Strings"
  (let ((result (first string-list)))
	(dolist (string (rest string-list) result)
	  (setf result (concat-string result seperator string)))))

(defun string-repeat (string n)
  "Create a string repeated n times"
  (string-join (fill (make-list n) string)))

(defun print-repeat (s n)
  (dotimes (i n)
    (println (string-repeat s (1+ i))))
  (dotimes (i (1- n))
    (println (string-repeat s (- n 1 i))))
  (values))

(defun string-of-code (code)
  "Return lowercase string from the code"
  (string-downcase (write-to-string code)))
;; write-to-string 		symbol => string
;; read-from-string  	string => symbol
;; (eval (read-from-string "(+ 1 2 3)"))  => 6
;; (equal '(+ 1 2 3) (read-from-string "(+ 1 2 3)"))  t

(defun wrapped-code (code &optional (seperator "=") (count 30))
  (format nil "~A~%~A~%~2:*~A"
          (string-repeat seperator count)
          (string-of-code code)))

;; (defun join (string-list &optional (seperator "-"))
;;   "Join the string list"           
;;   (format nil (format nil "~~{~~a~~^~a~~}" (cl-ppcre:regex-replace-all "~" seperator "~~")) string-list))

(defun join (string-list
             &key (seperator " ") output (fn #'identity)              
             &aux (seperator (cl-ppcre:regex-replace-all "~" seperator "~~")))
  "Join the string list"           
  (format output (format nil "~~{~~a~~^~a~~}" seperator) (mapcar fn string-list)))

#+END_SRC

** [[/Users/Can/Develop/Lisp/mine/basic/simple.cl][simple]]
#+BEGIN_SRC lisp 
;; (defun desc (symbol)
;;   (documentation symbol 'function))

(defmacro desc (symbol &optional (type 'function))
  (documentation symbol type))
;; (desc *print-readably* variable)  => for (defparameter x "documentation")

(defmacro alias (new-name source &rest init-args)
  `(defmacro ,new-name (&rest args)
     (append '(,source) ',init-args args)))

(defmacro alias-function (new origin)
  `(setf (symbol-function ',new) #',origin))


(defmacro ^ (&body codes)
  `#'(lambda ,@codes))
(alias $ ^) 

(defmacro re-name (source target)
  "Example: (rename format printf)"
  `(defmacro ,target (&rest params)
	 (cons ',source params)))



(alias fmt format nil)
(fmt "Hello ~a" "World") ;;=> (format nil "Hello ~a" "World")

;; (format t "~%Let's start using LISP!")

;; (defmacro rename-func (source target)
;;   `(defun ,target (&rest params)
;; 	 (apply ,source params)))

;; (setq *print-case* :downcase)
;; (print "Welcome to coding with Common Lisp, Can!")
;; (defun welcome (name)
;;   (format nil "Welcome home u, ~a" name))
;; (welcome "Soul-Clinic!")


;;(print-test "*" 10)
(defun update-case (&optional (case :downcase)) ;; :capitalize :upcase
  (setq *print-case* case))
(update-case)

(defun pro (&rest codes)
  (declare (ignore codes))
  (values (read-from-string (string-repeat "=" 40))))


#+END_SRC

** [[/Users/Can/Develop/Lisp/mine/basic/shell.cl][shell]]
#+BEGIN_SRC lisp 
(defun shell (cmd &key (output *standard-output*))
    #+clisp
        (let ((str (ext:run-shell-command cmd :output:stream)))
            (loop for line = (read-line str nil)
             until (null line)
             do (print line)))
    #+ecl 
        (si:system cmd)
    #+sbcl 
    ;; (sb-ext:run-program "/bin/sh" (list "-c" cmd) :input nil :output *standard-output*)
    (sb-ext:run-program "/bin/sh" (list "-c" cmd) :input nil :output output)
    #+clozure 
        (ccl:run-program "/bin/sh" (list "-c" cmd) :input nil :output *standard-output*))

(defun cmd (cmd &optional (output t))
  "Use uiop:run-program"           
  (uiop:run-program cmd :output output :ignore-error-status t))
;; Set output to '(:string :stripped t) as string


(defun weplant (sql)
    (run-program "/usr/local/mysql/bin/mysql" `("-uroot" "weplant2" "-e" ,sql) :input nil :output *standard-output*))


(defun psql (sql)
    (run-program "/Library/PostgreSQL/11/bin/psql" `("-c" ,sql) :input nil :output *standard-output*))

#+END_SRC

** [[/Users/Can/Develop/Lisp/mine/basic/meta.cl][meta]]
#+BEGIN_SRC lisp 
(require :sb-introspect)
(defun arglist (fn)
  "Return the signature of the function."
  #+allegro (excl:arglist fn)
  #+clisp (sys::arglist fn)
  #+(or cmu scl)
  (let ((f (coerce fn 'function)))
    (typecase f
      (STANDARD-GENERIC-FUNCTION (pcl:generic-function-lambda-list f))
      (EVAL:INTERPRETED-FUNCTION (eval:interpreted-function-arglist f))
      (FUNCTION (values (read-from-string (kernel:%function-arglist f))))))
  #+cormanlisp (ccl:function-lambda-list
                (typecase fn (symbol (fdefinition fn)) (t fn)))
  #+gcl (let ((fn (etypecase fn
                    (symbol fn)
                    (function (si:compiled-function-name fn)))))
          (get fn 'si:debug))
  #+lispworks (lw:function-lambda-list fn)
  #+lucid (lcl:arglist fn)
  #+sbcl (sb-introspect:function-lambda-list fn)
  #-(or allegro clisp cmu cormanlisp gcl lispworks lucid sbcl scl)
  (error 'not-implemented :proc (list 'arglist fn)))

(defun arity (fn)
  "Return the arg count"
  (let ((arglist (arglist fn)))
    (if (intersection arglist lambda-list-keywords)  ;; keywords: (&allow-other-keys &aux &body &environment &key sb-int:&more &optional &rest &whole)
        (error "~S lambda list ~S contains keywords" fn arglist)
        (length arglist))))

#+END_SRC

** [[/Users/Can/Develop/Lisp/mine/basic/macro.cl][macro]]
#+BEGIN_SRC lisp 
;;; -*- Mode: Lisp; Package: USER -*-
;;;
;;; PPMX - pretty prints a macro expansion
;;;
;;; From the book "Common Lisp:  A Gentle Introduction to
;;;      Symbolic Computation" by David S. Touretzky.  
;;; The Benjamin/Cummings Publishing Co., 1990.
;;;
;;; Example of use:  (ppmx (incf a))


(defmacro ppmx (form &optional (count 30))
  "Pretty prints the macro expansion of FORM."
  `(let* ((exp1 (macroexpand-1 ',form))
	  (exp (macroexpand exp1))
	  (*print-circle* nil))
     (cond ((equal exp exp1)
	    (format t "~&Macro expansion: ~%~A" (wrapped-code exp "*" ,count))
                                        ;(pprint exp))
            )
	   (t (format t "~&First step of expansion:")
	      (pprint exp1)
	      (format t "~%~%Final expansion:")
	      (pprint exp)))
     (format t "~%~%")
     (values)))


#+END_SRC

** [[/Users/Can/Develop/Lisp/mine/basic/hash.cl][hash]]
#+BEGIN_SRC lisp 
(defmacro sethash (key value hash)
  `(setf (gethash ,key ,hash) ,value))
;; equals to:
(defun set-hash (key value hash)
  (setf (gethash key hash) value))


(defun printhash (hash)
  (maphash #'(lambda (k v) (format t "~a: ~a ~%" k v)) hash))

(defun print-hash (hash)
  (maphash #'(lambda (k v) (print `(,k ,v))) hash))

#+END_SRC

** [[/Users/Can/Develop/Lisp/mine/basic/concat.cl][concat]]
#+BEGIN_SRC lisp 
(defmacro concats (&rest types)
  `(progn
     ,@(mapcar
        #'(lambda (type)
            `(defun ,(read-from-string (format nil "concat-~s" type)) (&rest values)
               (apply #'concatenate (cons ',type values))))
        types)))

(concats string list vector)

;; (defun concat-string (&rest strings)
;;   (apply #'concatenate (cons 'string strings)))

;; (defun concat-list (&rest lists)
;;   (apply #'concatenate (cons 'list lists)))

;; (defun concat-vector (&rest vectors)
;;   (apply #'concatenate (cons 'vector vectors)))


#+END_SRC

** [[/Users/Can/Develop/Lisp/others/young/basic/setup.lisp][setup]]
#+BEGIN_SRC lisp 
(defmacro rename (source target)
  "Example: (rename format printf)"
  `(defmacro ,target (&rest params)
     (cons ',source params)))

(defmacro alias (new-name source &rest init-args)
  `(defmacro ,new-name (&rest args)
     (append '(,source) ',init-args args)))

(alias fmt format nil)
(fmt "Hello ~a" "World") ;;=> (format nil "Hello ~a" "World")

(defun desc (func-name)
  (documentation func-name 'function))

(format t "~5%♞  Let's start using LISP!~2%")

(setf *default-pathname-defaults* #P"/Develop/common-lisp/")
(ql:quickload 'cl-ppcre)

(defparameter *loaded-files* (list *load-truename*))
(defun load-code (name)
  (let ((path (if (pathnamep name)
		  name
		  (merge-pathnames (cl-ppcre:regex-replace "^\\.?/?" name "")))))
    (if (position path *loaded-files* :test 'equalp)
	(format t "~& Already loaded ~a ~%" path)
	(progn
	  (load path)
	  (format t "~& 🎉  ~a ~%" (pathname-name path))
	  (nconc *loaded-files* (list path))))))

(load-code "basic/string.cl")

(defvar *source-list*
  (directory (make-pathname
	      :directory (namestring (truename "./basic"))
	      :name :wild
	      :type "cl")))

(dolist (source *source-list*)
  (unless (start-with (file-namestring source) ".")     ; don't load itself, or will go into infinite loop
    (load-code source)))


(defun update-case (&optional (case :downcase)) ;; :capitalize :upcase
  (setq *print-case* case))
(update-case)

(let ((line (string-repeat "*" 52)))
  (apply #'format `(t "~%~a~%~15tHello ~a, Happy Lisp~%~a~%" ,line "Can" ,line)))

#+END_SRC

** [[/Users/Can/Develop/Lisp/others/young/basic/base.lisp][base]]
#+BEGIN_SRC lisp 
(defun string-join (string-list &optional (seperator ""))
  "The list must consist of Strings"
  (let ((result (first string-list)))
    (dolist (string (rest string-list) result)
      (setf result (concat-string result seperator string)))))

(defun string-repeat (string n)
  "Create a string repeated n times"
  (string-join (fill (make-list n) string)))

(defun print-repeat (s n)
  (dotimes (i n)
    (println (string-repeat s (1+ i))))
  (dotimes (i (1- n))
    (println (string-repeat s (- n 1 i))))
  (values))

(defun surrounded-string (string &optional (surrounder "\""))
  (concat-string surrounder string surrounder))

#+END_SRC

* Chapter03
** [[/Users/Can/Develop/Lisp/document/pcl/code/Chapter03/simple-database.lisp][simple-database]]
#+BEGIN_SRC lisp 
(in-package :com.gigamonkeys.simple-db)

(defvar *db* nil)

(defun make-cd (title artist rating ripped)
  (list :title title :artist artist :rating rating :ripped ripped))

(defun add-record (cd) (push cd *db*))

(defun dump-db ()
  (dolist (cd *db*)
    (format t "~{~a:~10t~a~%~}~%" cd)))

(defun prompt-read (prompt)
  (format *query-io* "~a: " prompt)
  (force-output *query-io*)
  (read-line *query-io*))

(defun prompt-for-cd ()
  (make-cd
   (prompt-read "Title")
   (prompt-read "Artist")
   (or (parse-integer (prompt-read "Rating") :junk-allowed t) 0)
   (y-or-n-p "Ripped [y/n]: ")))

(defun add-cds ()
  (loop (add-record (prompt-for-cd))
     (if (not (y-or-n-p "Another? [y/n]: ")) (return))))

(defun save-db (filename)
  (with-open-file (out filename 
                   :direction :output
                   :if-exists :supersede)
    (with-standard-io-syntax
      (print *db* out))))

(defun load-db (filename)
  (with-open-file (in filename)
    (with-standard-io-syntax
      (setf *db* (read in)))))

(defun clear-db () (setq *db* nil))

(defun select (selector-fn)
  (remove-if-not selector-fn *db*))

(defmacro where (&rest clauses)
  `#'(lambda (cd) (and ,@(make-comparisons-list clauses))))

(defun make-comparisons-list (fields)
  (loop while fields
     collecting (make-comparison-expr (pop fields) (pop fields))))

(defun make-comparison-expr (field value)
  `(equal (getf cd ,field) ,value))


(defun update (selector-fn &key title artist rating (ripped nil ripped-p))
  (setf *db*
        (mapcar 
         #'(lambda (row)
             (when (funcall selector-fn row)
               (if title    (setf (getf row :title) title))
               (if artist   (setf (getf row :artist) artist))
               (if rating   (setf (getf row :rating) rating))
               (if ripped-p (setf (getf row :ripped) ripped)))
             row) *db*)))

(defun delete-rows (selector-fn)
  (setf *db* (remove-if selector-fn *db*)))




#+END_SRC

** [[/Users/Can/Develop/Lisp/document/pcl/code/Chapter03/packages.lisp][packages]]
#+BEGIN_SRC lisp 
(in-package :cl-user)

(defpackage :com.gigamonkeys.simple-db (:use :cl))

#+END_SRC

* Chapter08
** [[/Users/Can/Develop/Lisp/document/pcl/code/Chapter08/packages.lisp][packages]]
#+BEGIN_SRC lisp 
(in-package :cl-user)

(defpackage :com.gigamonkeys.macro-utilities
  (:use :common-lisp)
  (:export 
   :with-gensyms
   :with-gensymed-defuns
   :once-only
   :spliceable
   :ppme))
           

#+END_SRC

** [[/Users/Can/Develop/Lisp/document/pcl/code/Chapter08/macro-utilities.lisp][macro-utilities]]
#+BEGIN_SRC lisp 
(in-package :com.gigamonkeys.macro-utilities)

(defmacro with-gensyms ((&rest names) &body body)
  `(let ,(loop for n in names collect `(,n (make-symbol ,(string n))))
     ,@body))

(defmacro once-only ((&rest names) &body body)
  (let ((gensyms (loop for n in names collect (gensym (string n)))))
    `(let (,@(loop for g in gensyms collect `(,g (gensym))))
      `(let (,,@(loop for g in gensyms for n in names collect ``(,,g ,,n)))
        ,(let (,@(loop for n in names for g in gensyms collect `(,n ,g)))
           ,@body)))))

(defun spliceable (value)
  (if value (list value)))

(defmacro ppme (form &environment env)
  (progn
    (write (macroexpand-1 form env)
           :length nil
           :level nil
           :circle nil
           :pretty t
           :gensym nil
           :right-margin 83
           :case :downcase)
    nil))


#+END_SRC

* Chapter09
** [[/Users/Can/Develop/Lisp/document/pcl/code/Chapter09/test.lisp][test]]
#+BEGIN_SRC lisp 
(in-package :com.gigamonkeys.test)

(defvar *test-name* nil)

(defmacro deftest (name parameters &body body)
  "Define a test function. Within a test function we can call other
test functions or use `check' to run individual test cases."
  `(defun ,name ,parameters
    (let ((*test-name* (append *test-name* (list ',name))))
      ,@body)))

(defmacro check (&body forms)
  "Run each expression in `forms' as a test case."
  `(combine-results
    ,@(loop for f in forms collect `(report-result ,f ',f))))

(defmacro combine-results (&body forms)
  "Combine the results (as booleans) of evaluating `forms' in order."
  (with-gensyms (result)
    `(let ((,result t))
      ,@(loop for f in forms collect `(unless ,f (setf ,result nil)))
      ,result)))

(defun report-result (result form)
  "Report the results of a single test case. Called by `check'."
  (format t "~:[FAIL~;pass~] ... ~a: ~a~%" result *test-name* form)
  result)

#+END_SRC

** [[/Users/Can/Develop/Lisp/document/pcl/code/Chapter09/packages.lisp][packages]]
#+BEGIN_SRC lisp 
(in-package :cl-user)

(defpackage :com.gigamonkeys.test
  (:use :common-lisp :com.gigamonkeys.macro-utilities)
  (:export :deftest :check))

#+END_SRC

* Chapter15
** [[/Users/Can/Develop/Lisp/document/pcl/code/Chapter15/pathnames.lisp][pathnames]]
#+BEGIN_SRC lisp 
(in-package #:com.gigamonkeys.pathnames)

(defun list-directory (dirname)
  "Return a list of the contents of the directory named by dirname.
Names of subdirectories will be returned in `directory normal
form'. Unlike CL:DIRECTORY, LIST-DIRECTORY does not accept
wildcard pathnames; `dirname' should simply be a pathname that
names a directory. It can be in either file or directory form."
  (when (wild-pathname-p dirname)
    (error "Can only list concrete directory names."))

  (let ((wildcard (directory-wildcard dirname)))

    #+(or sbcl cmu lispworks)
    ;; SBCL, CMUCL, and Lispworks return subdirectories in directory
    ;; form just the way we want.
    (directory wildcard)
    
    #+openmcl
    ;; OpenMCl by default doesn't return subdirectories at all. But
    ;; when prodded to do so with the special argument :directories,
    ;; it returns them in directory form.
    (directory wildcard :directories t)
            
    #+allegro
    ;; Allegro normally return directories in file form but we can
    ;; change that with the :directories-are-files argument.
    (directory wildcard :directories-are-files nil)
            
    #+clisp
    ;; CLISP has a particularly idiosyncratic view of things. But we
    ;; can bludgeon even it into doing what we want.
    (nconc 
     ;; CLISP won't list files without an extension when :type is
     ;; wild so we make a special wildcard for it.
     (directory wildcard)
     ;; And CLISP doesn't consider subdirectories to match unless
     ;; there is a :wild in the directory component.
     (directory (clisp-subdirectories-wildcard wildcard)))

    #-(or sbcl cmu lispworks openmcl allegro clisp)
    (error "list-directory not implemented")))




(defun file-exists-p (pathname)
  "Similar to CL:PROBE-FILE except it always returns directory names
in `directory normal form'. Returns truename which will be in
`directory form' if file named is, in fact, a directory."

  #+(or sbcl lispworks openmcl)
  ;; These implementations do "The Right Thing" as far as we are
  ;; concerned. They return a truename of the file or directory if it
  ;; exists and the truename of a directory is in directory normal
  ;; form.
  (probe-file pathname)

  #+(or allegro cmu)
  ;; These implementations accept the name of a directory in either
  ;; form and return the name in the form given. However the name of a
  ;; file must be given in file form. So we try first with a directory
  ;; name which will return NIL if either the file doesn't exist at
  ;; all or exists and is not a directory. Then we try with a file
  ;; form name.
  (or (probe-file (pathname-as-directory pathname))
      (probe-file pathname))

  #+clisp
  ;; Once again CLISP takes a particularly unforgiving approach,
  ;; signalling ERRORs at the slightest provocation.

  ;; pathname in file form and actually a file      -- (probe-file file)      ==> truename
  ;; pathname in file form and doesn't exist        -- (probe-file file)      ==> NIL
  ;; pathname in dir form and actually a directory  -- (probe-directory file) ==> truename
  ;; pathname in dir form and doesn't exist         -- (probe-directory file) ==> NIL

  ;; pathname in file form and actually a directory -- (probe-file file)      ==> ERROR
  ;; pathname in dir form and actually a file       -- (probe-directory file) ==> ERROR
  (or (ignore-errors
        ;; PROBE-FILE will return the truename if file exists and is a
        ;; file or NIL if it doesn't exist at all. If it exists but is
        ;; a directory PROBE-FILE will signal an error which we
        ;; ignore.
        (probe-file (pathname-as-file pathname)))
      (ignore-errors
        ;; PROBE-DIRECTORY returns T if the file exists and is a
        ;; directory or NIL if it doesn't exist at all. If it exists
        ;; but is a file, PROBE-DIRECTORY will signal an error.
        (let ((directory-form (pathname-as-directory pathname)))
          (when (ext:probe-directory directory-form)
            directory-form))))


    #-(or sbcl cmu lispworks openmcl allegro clisp)
    (error "list-directory not implemented"))

(defun directory-wildcard (dirname)
  (make-pathname 
   :name :wild
   :type #-clisp :wild #+clisp nil
   :defaults (pathname-as-directory dirname)))

#+clisp
(defun clisp-subdirectories-wildcard (wildcard)
  (make-pathname
   :directory (append (pathname-directory wildcard) (list :wild))
   :name nil
   :type nil
   :defaults wildcard))


(defun directory-pathname-p (p)
  "Is the given pathname the name of a directory? This function can
usefully be used to test whether a name returned by LIST-DIRECTORIES
or passed to the function in WALK-DIRECTORY is the name of a directory
in the file system since they always return names in `directory normal
form'."
  (flet ((component-present-p (value)
           (and value (not (eql value :unspecific)))))
    (and 
     (not (component-present-p (pathname-name p)))
     (not (component-present-p (pathname-type p)))
     p)))


(defun file-pathname-p (p)
  (unless (directory-pathname-p p) p))

(defun pathname-as-directory (name)
  "Return a pathname reperesenting the given pathname in
`directory normal form', i.e. with all the name elements in the
directory component and NIL in the name and type components. Can
not be used on wild pathnames because there's not portable way to
convert wildcards in the name and type into a single directory
component. Returns its argument if name and type are both nil or
:unspecific."
  (let ((pathname (pathname name)))
    (when (wild-pathname-p pathname)
      (error "Can't reliably convert wild pathnames."))
    (if (not (directory-pathname-p name))
      (make-pathname 
       :directory (append (or (pathname-directory pathname) (list :relative))
                          (list (file-namestring pathname)))
       :name      nil
       :type      nil
       :defaults pathname)
      pathname)))

(defun pathname-as-file (name)
  "Return a pathname reperesenting the given pathname in `file form',
i.e. with the name elements in the name and type component. Can't
convert wild pathnames because of problems mapping wild directory
component into name and type components. Returns its argument if
it is already in file form."
  (let ((pathname (pathname name)))
    (when (wild-pathname-p pathname)
      (error "Can't reliably convert wild pathnames."))
    (if (directory-pathname-p name)
      (let* ((directory (pathname-directory pathname))
             (name-and-type (pathname (first (last directory)))))
        (make-pathname 
         :directory (butlast directory)
         :name (pathname-name name-and-type)
         :type (pathname-type name-and-type)
         :defaults pathname))
      pathname)))

(defun walk-directory (dirname fn &key directories (test (constantly t)))
  "Walk a directory invoking `fn' on each pathname found. If `test' is
supplied fn is invoked only on pathnames for which `test' returns
true. If `directories' is t invokes `test' and `fn' on directory
pathnames as well."
  (labels
      ((walk (name)
         (cond
           ((directory-pathname-p name)
            (when (and directories (funcall test name))
              (funcall fn name))
            (dolist (x (list-directory name)) (walk x)))
           ((funcall test name) (funcall fn name)))))
    (walk (pathname-as-directory dirname))))

(defun directory-p (name)
  "Is `name' the name of an existing directory."
  (let ((truename (file-exists-p name)))
    (and truename (directory-pathname-p name))))

(defun file-p (name)
  "Is `name' the name of an existing file, i.e. not a directory."
  (let ((truename (file-exists-p name)))
    (and truename (file-pathname-p name))))



#+END_SRC

** [[/Users/Can/Develop/Lisp/document/pcl/code/Chapter15/packages.lisp][packages]]
#+BEGIN_SRC lisp 
(in-package :cl-user)

(defpackage :com.gigamonkeys.pathnames
  (:use :common-lisp)
  (:export
   :list-directory
   :file-exists-p
   :directory-pathname-p
   :file-pathname-p
   :pathname-as-directory
   :pathname-as-file
   :walk-directory
   :directory-p
   :file-p))

#+END_SRC

* Chapter23
** [[/Users/Can/Develop/Lisp/document/pcl/code/Chapter23/spam.lisp][spam]]
#+BEGIN_SRC lisp 
(in-package :com.gigamonkeys.spam)

(defvar *feature-database* (make-hash-table :test #'equal))
(defvar *total-spams* 0)
(defvar *total-hams* 0)

(defparameter *max-ham-score* .4)
(defparameter *min-spam-score* .6)

(defparameter *max-chars* (* 10 1024))
(defparameter *corpus* (make-array 1000 :adjustable t :fill-pointer 0))

(defun classify (text)
  "Classify the text of a message as SPAM, HAM, or UNSURE."
  (classification (score (extract-features text))))


(defclass word-feature ()
  ((word       
    :initarg :word
    :accessor word
    :initform (error "Must supply :word")
    :documentation "The word this feature represents.")
   (spam-count
    :initarg :spam-count
    :accessor spam-count
    :initform 0
    :documentation "Number of spams we have seen this feature in.")
   (ham-count
    :initarg :ham-count
    :accessor ham-count
    :initform 0
    :documentation "Number of hams we have seen this feature in.")))

(defun intern-feature (word)
  (or (gethash word *feature-database*)
      (setf (gethash word *feature-database*)
            (make-instance 'word-feature :word word))))

(defun extract-words (text)
  (delete-duplicates
   (cl-ppcre:all-matches-as-strings "[a-zA-Z]{3,}" text)
   :test #'string=))

(defun extract-features (text)
  (mapcar #'intern-feature (extract-words text)))

(defmethod print-object ((object word-feature) stream)
  (print-unreadable-object (object stream :type t)
    (with-slots (word ham-count spam-count) object
      (format stream "~s :hams ~d :spams ~d" word ham-count spam-count))))

(defun train (text type)
  (dolist (feature (extract-features text))
    (increment-count feature type))
  (increment-total-count type))

(defun increment-count (feature type)
  (ecase type
    (ham (incf (ham-count feature)))
    (spam (incf (spam-count feature)))))

(defun increment-total-count (type)
  (ecase type
    (ham (incf *total-hams*))
    (spam (incf *total-spams*))))

(defun clear-database ()
  (setf
   *feature-database* (make-hash-table :test #'equal)
   *total-spams* 0
   *total-hams* 0))

(defun spam-probability (feature)
  "Basic probability that a feature with the given relative
frequencies will appear in a spam assuming spams and hams are
otherwise equally probable. One of the two frequencies must be
non-zero."
  (with-slots (spam-count ham-count) feature
    (let ((spam-frequency (/ spam-count (max 1 *total-spams*)))
          (ham-frequency (/ ham-count (max 1 *total-hams*))))
      (/ spam-frequency (+ spam-frequency ham-frequency)))))


(defun bayesian-spam-probability (feature &optional
                                  (assumed-probability 1/2)
                                  (weight 1))
  "Bayesian adjustment of a given probability given the number of
data points that went into it, an assumed probability, and a
weight we give that assumed probability."
  (let ((basic-probability (spam-probability feature))
        (data-points (+ (spam-count feature) (ham-count feature))))
    (/ (+ (* weight assumed-probability)
          (* data-points basic-probability))
       (+ weight data-points))))

(defun score (features)
  (let ((spam-probs ()) (ham-probs ()) (number-of-probs 0))
    (dolist (feature features)
      (unless (untrained-p feature)
        (let ((spam-prob (float (bayesian-spam-probability feature) 0.0d0)))
          (push spam-prob spam-probs)
          (push (- 1.0d0 spam-prob) ham-probs)
          (incf number-of-probs))))
    (let ((h (- 1 (fisher spam-probs number-of-probs)))
          (s (- 1 (fisher ham-probs number-of-probs))))
      (/ (+ (- 1 h) s) 2.0d0))))

(defun untrained-p (feature)
  (with-slots (spam-count ham-count) feature
    (and (zerop spam-count) (zerop ham-count))))

(defun fisher (probs number-of-probs)
  "The Fisher computation described by Robinson."
  (inverse-chi-square 
   (* -2 (reduce #'+ probs :key #'log))
   (* 2 number-of-probs)))

(defun inverse-chi-square (value degrees-of-freedom)
  "Probability that chi-square >= value with given degrees-of-freedom.
Based on Gary Robinson's Python implementation."
  (assert (evenp degrees-of-freedom))
  ;; Due to rounding errors in the multiplication and exponentiation
  ;; the sum computed in the loop may end up a shade above 1.0 which
  ;; we can't have since it's supposed to represent a probability.
  (min 
   (loop with m = (/ value 2)
      for i below (/ degrees-of-freedom 2)
      for prob = (exp (- m)) then (* prob (/ m i))
      summing prob)
   1.0))

(defun classification (score)
  (values
   (cond
     ((<= score *max-ham-score*) 'ham)
     ((>= score *min-spam-score*) 'spam)
     (t 'unsure))
   score))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Test rig

(defun add-file-to-corpus (filename type corpus)
  (vector-push-extend (list filename type) corpus))

(defun add-directory-to-corpus (dir type corpus)
  (dolist (filename (list-directory dir))
    (add-file-to-corpus filename type corpus)))

(defun test-classifier (corpus testing-fraction)
  (clear-database)
  (let* ((shuffled (shuffle-vector corpus))
         (size (length corpus))
         (train-on (floor (* size (- 1 testing-fraction)))))
    (train-from-corpus shuffled :start 0 :end train-on)
    (test-from-corpus shuffled :start train-on)))

(defun train-from-corpus (corpus &key (start 0) end)
  (loop for idx from start below (or end (length corpus)) do
        (destructuring-bind (file type) (aref corpus idx)
          (train (start-of-file file *max-chars*) type))))

(defun test-from-corpus (corpus &key (start 0) end)
  (loop for idx from start below (or end (length corpus)) collect
        (destructuring-bind (file type) (aref corpus idx)
          (multiple-value-bind (classification score)
              (classify (start-of-file file *max-chars*))
            (list 
             :file file
             :type type
             :classification classification
             :score score)))))

(defun nshuffle-vector (vector)
  "Shuffle a vector in place using Fisher-Yates algorithm." 
  (loop for idx downfrom (1- (length vector)) to 1
        for other = (random (1+ idx))
        do (unless (= idx other)
             (rotatef (aref vector idx) (aref vector other))))
  vector)

(defun shuffle-vector (vector)
  "Return a shuffled copy of vector."
  (nshuffle-vector (copy-seq vector)))

(defun start-of-file (file max-chars)
  (with-open-file (in file)
    (let* ((length (min (file-length in) max-chars))
           (text (make-string length))
           (read (read-sequence text in)))
      (if (< read length)
        (subseq text 0 read)
        text))))


(defun result-type (result)
  (destructuring-bind (&key type classification &allow-other-keys) result
    (ecase type
      (ham
       (ecase classification
         (ham 'correct)
         (spam 'false-positive)
         (unsure 'missed-ham)))
      (spam
       (ecase classification
         (ham 'false-negative)
         (spam 'correct)
         (unsure 'missed-spam))))))

(defun false-positive-p (result)
  (eql (result-type result) 'false-positive))

(defun false-negative-p (result)
  (eql (result-type result) 'false-negative))

(defun missed-ham-p (result)
  (eql (result-type result) 'missed-ham))

(defun missed-spam-p (result)
  (eql (result-type result) 'missed-spam))

(defun correct-p (result)
  (eql (result-type result) 'correct))

(defun analyze-results (results)
  (let* ((keys '(total correct false-positive 
                 false-negative missed-ham missed-spam))
         (counts (loop for x in keys collect (cons x 0))))
    (dolist (item results)
      (incf (cdr (assoc 'total counts)))
      (incf (cdr (assoc (result-type item) counts))))
    (loop with total = (cdr (assoc 'total counts))
          for (label . count) in counts
          do (format t "~&~@(~a~):~20t~5d~,5t: ~6,2f%~%"
                     label count (* 100 (/ count total))))))

(defun explain-classification (file)
  (let* ((text (start-of-file file *max-chars*))
         (features (extract-features text))
         (score (score features))
         (classification (classification score)))
    (show-summary file text classification score)
    (dolist (feature (sorted-interesting features))
      (show-feature feature))))

(defun show-summary (file text classification score)
  (format t "~&~a" file)
  (format t "~2%~a~2%" text)
  (format t "Classified as ~a with score of ~,5f~%" classification score))
  
(defun show-feature (feature)
  (with-slots (word ham-count spam-count) feature
    (format
     t "~&~2t~a~30thams: ~5d; spams: ~5d;~,10tprob: ~,f~%"
     word ham-count spam-count (bayesian-spam-probability feature))))

(defun sorted-interesting (features)
  (sort (remove-if #'untrained-p features) #'< :key #'bayesian-spam-probability))

#+END_SRC

** [[/Users/Can/Develop/Lisp/document/pcl/code/Chapter23/packages.lisp][packages]]
#+BEGIN_SRC lisp 
(in-package :cl-user)

(defpackage :com.gigamonkeys.spam
  (:use :common-lisp :com.gigamonkeys.pathnames))




#+END_SRC

* Chapter24
** [[/Users/Can/Develop/Lisp/document/pcl/code/Chapter24/packages.lisp][packages]]
#+BEGIN_SRC lisp 
(in-package :cl-user)

(defpackage :com.gigamonkeys.binary-data
  (:use :common-lisp :com.gigamonkeys.macro-utilities)
  (:export :define-binary-class
           :define-tagged-binary-class
           :define-binary-type
           :read-value
           :write-value
           :*in-progress-objects*
           :parent-of-type
           :current-binary-object
           :+null+))

#+END_SRC

** [[/Users/Can/Develop/Lisp/document/pcl/code/Chapter24/binary-data.lisp][binary-data]]
#+BEGIN_SRC lisp 
(in-package :com.gigamonkeys.binary-data)

(defvar *in-progress-objects* nil)

(defconstant +null+ (code-char 0))

(defgeneric read-value (type stream &key)
  (:documentation "Read a value of the given type from the stream."))

(defgeneric write-value (type stream value &key)
  (:documentation "Write a value as the given type to the stream."))

(defgeneric read-object (object stream)
  (:method-combination progn :most-specific-last)
  (:documentation "Fill in the slots of object from stream."))

(defgeneric write-object (object stream)
  (:method-combination progn :most-specific-last)
  (:documentation "Write out the slots of object to the stream."))

(defmethod read-value ((type symbol) stream &key)
  (let ((object (make-instance type)))
    (read-object object stream)
    object))

(defmethod write-value ((type symbol) stream value &key)
  (assert (typep value type))
  (write-object value stream))


;;; Binary types

(defmacro define-binary-type (name (&rest args) &body spec)
  (with-gensyms (type stream value)
  `(progn
    (defmethod read-value ((,type (eql ',name)) ,stream &key ,@args)
      (declare (ignorable ,@args))
      ,(type-reader-body spec stream))
    (defmethod write-value ((,type (eql ',name)) ,stream ,value &key ,@args)
      (declare (ignorable ,@args))
      ,(type-writer-body spec stream value)))))

(defun type-reader-body (spec stream)
  (ecase (length spec)
    (1 (destructuring-bind (type &rest args) (mklist (first spec))
         `(read-value ',type ,stream ,@args)))
    (2 (destructuring-bind ((in) &body body) (cdr (assoc :reader spec))
         `(let ((,in ,stream)) ,@body)))))

(defun type-writer-body (spec stream value)
  (ecase (length spec)
    (1 (destructuring-bind (type &rest args) (mklist (first spec))
         `(write-value ',type ,stream ,value ,@args)))
    (2 (destructuring-bind ((out v) &body body) (cdr (assoc :writer spec))
         `(let ((,out ,stream) (,v ,value)) ,@body)))))


;;; Binary classes

(defmacro define-generic-binary-class (name (&rest superclasses) slots read-method)
  (with-gensyms (objectvar streamvar)
    `(progn
       (eval-when (:compile-toplevel :load-toplevel :execute)
         (setf (get ',name 'slots) ',(mapcar #'first slots))
         (setf (get ',name 'superclasses) ',superclasses))
       
       (defclass ,name ,superclasses
         ,(mapcar #'slot->defclass-slot slots))
       
       ,read-method
       
       (defmethod write-object progn ((,objectvar ,name) ,streamvar)
         (declare (ignorable ,streamvar))
         (with-slots ,(new-class-all-slots slots superclasses) ,objectvar
           ,@(mapcar #'(lambda (x) (slot->write-value x streamvar)) slots))))))

(defmacro define-binary-class (name (&rest superclasses) slots)
  (with-gensyms (objectvar streamvar)
    `(define-generic-binary-class ,name ,superclasses ,slots
       (defmethod read-object progn ((,objectvar ,name) ,streamvar)
         (declare (ignorable ,streamvar))
         (with-slots ,(new-class-all-slots slots superclasses) ,objectvar
           ,@(mapcar #'(lambda (x) (slot->read-value x streamvar)) slots))))))

(defmacro define-tagged-binary-class (name (&rest superclasses) slots &rest options)
  (with-gensyms (typevar objectvar streamvar)
    `(define-generic-binary-class ,name ,superclasses ,slots
      (defmethod read-value ((,typevar (eql ',name)) ,streamvar &key)
        (let* ,(mapcar #'(lambda (x) (slot->binding x streamvar)) slots)
          (let ((,objectvar
                 (make-instance 
                  ,@(or (cdr (assoc :dispatch options))
                        (error "Must supply :disptach form."))
                  ,@(mapcan #'slot->keyword-arg slots))))
            (read-object ,objectvar ,streamvar)
            ,objectvar))))))

(defun as-keyword (sym) (intern (string sym) :keyword))

(defun normalize-slot-spec (spec)
  (list (first spec) (mklist (second spec))))

(defun mklist (x) (if (listp x) x (list x)))

(defun slot->defclass-slot (spec)
  (let ((name (first spec)))
    `(,name :initarg ,(as-keyword name) :accessor ,name)))

(defun slot->read-value (spec stream)
  (destructuring-bind (name (type &rest args)) (normalize-slot-spec spec)
    `(setf ,name (read-value ',type ,stream ,@args))))

(defun slot->write-value (spec stream)
  (destructuring-bind (name (type &rest args)) (normalize-slot-spec spec)
    `(write-value ',type ,stream ,name ,@args)))

(defun slot->binding (spec stream)
  (destructuring-bind (name (type &rest args)) (normalize-slot-spec spec)
    `(,name (read-value ',type ,stream ,@args))))

(defun slot->keyword-arg (spec)
  (let ((name (first spec)))
    `(,(as-keyword name) ,name)))

;;; Keeping track of inherited slots

(defun direct-slots (name)
  (copy-list (get name 'slots)))

(defun inherited-slots (name)
  (loop for super in (get name 'superclasses)
        nconc (direct-slots super)
        nconc (inherited-slots super)))

(defun all-slots (name)
  (nconc (direct-slots name) (inherited-slots name)))

(defun new-class-all-slots (slots superclasses)
  "Like all slots but works while compiling a new class before slots
and superclasses have been saved."
  (nconc (mapcan #'all-slots superclasses) (mapcar #'first slots)))

;;; In progress Object stack

(defun current-binary-object ()
  (first *in-progress-objects*))

(defun parent-of-type (type)
  (find-if #'(lambda (x) (typep x type)) *in-progress-objects*))

(defmethod read-object :around (object stream)
  (declare (ignore stream))
  (let ((*in-progress-objects* (cons object *in-progress-objects*)))
    (call-next-method)))

(defmethod write-object :around (object stream)
  (declare (ignore stream))
  (let ((*in-progress-objects* (cons object *in-progress-objects*)))
    (call-next-method)))


#+END_SRC

* Chapter25
** [[/Users/Can/Develop/Lisp/document/pcl/code/Chapter25/packages.lisp][packages]]
#+BEGIN_SRC lisp 
(in-package :cl-user)

(defpackage :com.gigamonkeys.id3v2
  (:use :common-lisp
        :com.gigamonkeys.binary-data
        :com.gigamonkeys.pathnames)
  (:export
   :read-id3
   :mp3-p
   :id3-p
   :album
   :composer
   :genre
   :encoding-program
   :artist
   :part-of-set
   :track
   :song
   :year
   :size
   :translated-genre))

#+END_SRC

** [[/Users/Can/Develop/Lisp/document/pcl/code/Chapter25/id3v2.lisp][id3v2]]
#+BEGIN_SRC lisp 
(in-package #:com.gigamonkeys.id3v2)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; A few basic types

(define-binary-type unsigned-integer (bytes bits-per-byte)
  (:reader (in)
    (loop with value = 0
       for low-bit downfrom (* bits-per-byte (1- bytes)) to 0 by bits-per-byte do
         (setf (ldb (byte bits-per-byte low-bit) value) (read-byte in))
       finally (return value)))
  (:writer (out value)
    (loop for low-bit downfrom (* bits-per-byte (1- bytes)) to 0 by bits-per-byte
       do (write-byte (ldb (byte bits-per-byte low-bit) value) out))))

(define-binary-type u1 () (unsigned-integer :bytes 1 :bits-per-byte 8))
(define-binary-type u2 () (unsigned-integer :bytes 2 :bits-per-byte 8))
(define-binary-type u3 () (unsigned-integer :bytes 3 :bits-per-byte 8))
(define-binary-type u4 () (unsigned-integer :bytes 4 :bits-per-byte 8))
(define-binary-type id3-tag-size () (unsigned-integer :bytes 4 :bits-per-byte 7))

;;; Strings

(define-binary-type generic-string (length character-type)
  (:reader (in)
    (let ((string (make-string length)))
      (dotimes (i length)
        (setf (char string i) (read-value character-type in)))
      string))
  (:writer (out string)
    (dotimes (i length)
      (write-value character-type out (char string i)))))

(define-binary-type generic-terminated-string (terminator character-type)
  (:reader (in)
    (with-output-to-string (s)
      (loop for char = (read-value character-type in)
            until (char= char terminator) do (write-char char s))))
  (:writer (out string)
    (loop for char across string
          do (write-value character-type out char)
          finally (write-value character-type out terminator))))

;;; ISO-8859-1 strings

(define-binary-type iso-8859-1-char ()
  (:reader (in)
    (let ((code (read-byte in)))
      (or (code-char code)
          (error "Character code ~d not supported" code))))
  (:writer (out char)
    (let ((code (char-code char)))
      (if (<= 0 code #xff)
          (write-byte code out)
          (error "Illegal character for iso-8859-1 encoding: character: ~c with code: ~d" char code)))))

(define-binary-type iso-8859-1-string (length)
  (generic-string :length length :character-type 'iso-8859-1-char))

(define-binary-type iso-8859-1-terminated-string (terminator)
  (generic-terminated-string :terminator terminator :character-type 'iso-8859-1-char))

;;; UCS-2 (Unicode) strings (i.e. UTF-16 without surrogate pairs, phew.)

;;; Define a binary type for reading a UCS-2 character relative to a
;;; particular byte ordering as indicated by the BOM value.
 ;; v2.3 specifies that the BOM should be present. v2.2 is silent
 ;; though it is arguably inherent in the definition of UCS-2) Length
 ;; is in bytes. On the write side, since we don't have any way of
 ;; knowing what BOM was used to read the string we just pick one.
 ;; This does mean roundtrip transparency could be broken.

(define-binary-type ucs-2-char (swap)
  (:reader (in)
    (let ((code (read-value 'u2 in)))
      (when swap (setf code (swap-bytes code)))
      (or (code-char code) (error "Character code ~d not supported" code))))
  (:writer (out char)
    (let ((code (char-code char)))
      (unless (<= 0 code #xffff)
        (error "Illegal character for ucs-2 encoding: ~c with char-code: ~d" char code))
      (when swap (setf code (swap-bytes code)))
      (write-value 'u2 out code))))

(defun swap-bytes (code)
  (assert (<= code #xffff))
  (rotatef (ldb (byte 8 0) code) (ldb (byte 8 8) code))
  code)


(define-binary-type ucs-2-char-big-endian () (ucs-2-char :swap nil))

(define-binary-type ucs-2-char-little-endian () (ucs-2-char :swap t))

(defun ucs-2-char-type (byte-order-mark)
  (ecase byte-order-mark
    (#xfeff 'ucs-2-char-big-endian)
    (#xfffe 'ucs-2-char-little-endian)))

(define-binary-type ucs-2-string (length)
  (:reader (in)
    (let ((byte-order-mark (read-value 'u2 in))
          (characters (1- (/ length 2))))
      (read-value
       'generic-string in
       :length characters
       :character-type (ucs-2-char-type byte-order-mark))))
  (:writer (out string)
    (write-value 'u2 out #xfeff)
    (write-value
     'generic-string out string
     :length (length string)
     :character-type (ucs-2-char-type #xfeff))))

(define-binary-type ucs-2-terminated-string (terminator)
  (:reader (in)
    (let ((byte-order-mark (read-value 'u2 in)))
      (read-value
       'generic-terminated-string in
       :terminator terminator
       :character-type (ucs-2-char-type byte-order-mark))))
  (:writer (out string)
    (write-value 'u2 out #xfeff)
    (write-value 
     'generic-terminated-string out string
     :terminator terminator
     :character-type (ucs-2-char-type #xfeff))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; ID3 tag class

;;; Handle ID3v2.2 and ID3v2.3 (but not ID3v2.4 since it mostly just
;;; requires a bunch more string encoding foo.) (Well, we can mostly
;;; read v2.4 tags as v2.3 tags.)

(define-tagged-binary-class id3-tag ()
  ((identifier     (iso-8859-1-string :length 3))
   (major-version  u1)
   (revision       u1)
   (flags          u1)
   (size           id3-tag-size))
  (:dispatch 
   (ecase major-version
     (2 'id3v2.2-tag)
     (3 'id3v2.3-tag))))

(define-binary-class id3v2.2-tag (id3-tag)
  ((frames (id3-frames :tag-size size :frame-type 'id3v2.2-frame))))

(define-binary-class id3v2.3-tag (id3-tag)
  ((extended-header-size (optional :type 'u4 :if (extended-p flags)))
   (extra-flags          (optional :type 'u2 :if (extended-p flags)))
   (padding-size         (optional :type 'u4 :if (extended-p flags)))
   (crc                  (optional :type 'u4 :if (crc-p flags extra-flags)))
   (frames               (id3-frames :tag-size size :frame-type 'id3v2.3-frame))))


(defun extended-p (flags) (logbitp 6 flags))

(defun crc-p (flags extra-flags)
  (and (extended-p flags) (logbitp 15 extra-flags)))

(define-binary-type optional (type if)
  (:reader (in)
    (when if (read-value type in)))
  (:writer (out value)
    (when if (write-value type out value))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; ID3 frames

(define-tagged-binary-class id3v2.2-frame ()
  ((id (frame-id :length 3))
   (size u3))
  (:dispatch (find-frame-class id)))

(define-tagged-binary-class id3v2.3-frame ()
  ((id                (frame-id :length 4))
   (size              u4)
   (flags             u2)
   (decompressed-size (optional :type 'u4 :if (frame-compressed-p flags)))
   (encryption-scheme (optional :type 'u1 :if (frame-encrypted-p flags)))
   (grouping-identity (optional :type 'u1 :if (frame-grouped-p flags))))
  (:dispatch (find-frame-class id)))

(defun frame-compressed-p (flags) (logbitp 7 flags))

(defun frame-encrypted-p (flags) (logbitp 6 flags))

(defun frame-grouped-p (flags) (logbitp 5 flags))

;;; find-frame

(defun find-frame-class (name)
  (cond
    ((and (char= (char name 0) #\T)
          (not (member name '("TXX" "TXXX") :test #'string=)))
     (ecase (length name)
       (3 'text-info-frame-v2.2)
       (4 'text-info-frame-v2.3)))
    ((string= name "COM")  'comment-frame-v2.2)
    ((string= name "COMM") 'comment-frame-v2.3)
    (t
     (ecase (length name)
       (3 'generic-frame-v2.2)
       (4 'generic-frame-v2.3)))))

;;; id3-frames

(define-binary-type id3-frames (tag-size frame-type)
  (:reader (in)
    (loop with to-read = tag-size
          while (plusp to-read)
          for frame = (read-frame frame-type in)
          while frame
          do (decf to-read (+ (frame-header-size frame) (size frame)))
          collect frame
          finally (loop repeat (1- to-read) do (read-byte in))))
  (:writer (out frames)
    (loop with to-write = tag-size
          for frame in frames
          do (write-value frame-type out frame)
          (decf to-write (+ (frame-header-size frame) (size frame)))
          finally (loop repeat to-write do (write-byte 0 out)))))

(defgeneric frame-header-size (frame))

(defmethod frame-header-size ((frame id3v2.2-frame)) 6)

(defmethod frame-header-size ((frame id3v2.3-frame)) 10)

(defun read-frame (frame-type in)
  (handler-case (read-value frame-type in)
    (in-padding ()  nil)))

(define-condition in-padding () ())

(define-binary-type frame-id (length)
  (:reader (in)
    (let ((first-byte (read-byte in)))
      (when (= first-byte 0) (signal 'in-padding))
      (let ((rest (read-value 'iso-8859-1-string in :length (1- length))))
        (concatenate
         'string (string (code-char first-byte)) rest))))
  (:writer (out id)
    (write-value 'iso-8859-1-string out id :length length)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Generic frames

(define-binary-class generic-frame ()
  ((data (raw-bytes :size (data-bytes (current-binary-object))))))

(defgeneric data-bytes (frame))

(defmethod data-bytes ((frame id3v2.2-frame))
  (size frame))

(defmethod data-bytes ((frame id3v2.3-frame))
  (let ((flags (flags frame)))
    (- (size frame)
       (if (frame-compressed-p flags) 4 0)
       (if (frame-encrypted-p flags) 1 0)
       (if (frame-grouped-p flags) 1 0))))


(define-binary-class generic-frame-v2.2 (id3v2.2-frame generic-frame) ())

(define-binary-class generic-frame-v2.3 (id3v2.3-frame generic-frame) ())

(define-binary-type raw-bytes (size)
  (:reader (in)
    (let ((buf (make-array size :element-type '(unsigned-byte 8))))
      (read-sequence buf in)
      buf))
  (:writer (out buf)
    (write-sequence buf out)))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Text info and comment frames

(define-binary-class text-info-frame ()
  ((encoding u1)
   (information (id3-encoded-string :encoding encoding :length (bytes-left 1)))))

(define-binary-class comment-frame ()
  ((encoding u1)
   (language (iso-8859-1-string :length 3))
   (description (id3-encoded-string :encoding encoding :terminator +null+))
   (text (id3-encoded-string
          :encoding encoding
          :length (bytes-left
                   (+ 1 ;; encoding 
                      3 ;; language
                      (encoded-string-length description encoding t)))))))

(defun bytes-left (bytes-read)
  (- (size (current-binary-object)) bytes-read))

(defun encoded-string-length (string encoding terminated)
  (let ((characters (+ (length string) (if terminated 1 0))))
    (* characters (ecase encoding (0 1) (1 2)))))

(defmethod (setf information) :after (value (frame text-info-frame))
  (declare (ignore value))
  (with-slots (encoding size information) frame
    (setf size (encoded-string-length information encoding nil))))

(define-binary-class text-info-frame-v2.2 (id3v2.2-frame text-info-frame) ())

(define-binary-class text-info-frame-v2.3 (id3v2.3-frame text-info-frame) ())

(define-binary-class comment-frame-v2.2 (id3v2.2-frame comment-frame) ())

(define-binary-class comment-frame-v2.3 (id3v2.3-frame comment-frame) ())

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; ID3 encoded string

(define-binary-type id3-encoded-string (encoding length terminator)
  (:reader (in) 
    (multiple-value-bind (type keyword arg)
        (string-args encoding length terminator)
      (read-value type in keyword arg)))
  (:writer (out string)
    (multiple-value-bind (type keyword arg)
        (string-args encoding length terminator)
      (write-value type out string keyword arg))))

(defun string-args (encoding length terminator)
  (cond 
    (length
     (values (non-terminated-type encoding) :length length))
    (terminator
     (values (terminated-type encoding) :terminator terminator))))
   
(defun non-terminated-type (encoding)
  (ecase encoding
    (0 'iso-8859-1-string)
    (1 'ucs-2-string)))

(defun terminated-type (encoding)
  (ecase encoding
    (0 'iso-8859-1-terminated-string)
    (1 'ucs-2-terminated-string)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Application code

(defun mp3-p (file)
  (and
   (not (directory-pathname-p file))
   (string-equal "mp3" (pathname-type file))))

(defun id3-p (file)
  (with-open-file (in file :element-type '(unsigned-byte 8))
    (string= "ID3" (read-value 'iso-8859-1-string in :length 3))))

(defun read-id3 (file)
  (with-open-file (in file :element-type '(unsigned-byte 8))
    (read-value 'id3-tag in)))

(defun show-tag-header (file)
  (with-slots (identifier major-version revision flags size) (read-id3 file)
    (format t "~a ~d.~d ~8,'0b ~d bytes -- ~a~%"
            identifier major-version revision flags size (enough-namestring file))))

(defun show-tag-headers (dir) 
  (walk-directory dir #'show-tag-header :test #'mp3-p))

(defun count-versions (dir)
  (let ((versions (mapcar #'(lambda (x) (cons x 0)) '(2 3 4))))
    (flet ((count-version (file)
             (incf (cdr (assoc (major-version (read-id3 file)) versions)))))
      (walk-directory dir #'count-version :test #'mp3-p))
    versions))

(defun frame-types (file)
  (delete-duplicates (mapcar #'id (frames (read-id3 file))) :test #'string=))

(defun frame-types-in-dir (dir)
  (let ((ids ()))
    (flet ((collect (file)
             (setf ids (nunion ids (frame-types file) :test #'string=))))
      (walk-directory dir #'collect :test #'mp3-p))
    ids))

(defun frame-name-member (id)
  (cond
    ((member id '("COM" "COMM") :test #'string=) "Comment")
    ((member id '("TAL" "TALB") :test #'string=) "Album")
    ((member id '("TCM" "TCOM") :test #'string=) "Composer")
    ((member id '("TCO" "TCON") :test #'string=) "Genre")
    ((member id '("TEN" "TENC") :test #'string=) "Encoding program")
    ((member id '("TP1" "TPE1") :test #'string=) "Artist")
    ((member id '("TPA" "TPOS") :test #'string=) "Part of set")
    ((member id '("TRK" "TRCK") :test #'string=) "Track")
    ((member id '("TT2" "TIT2") :test #'string=) "Song")
    ((member id '("TYE" "TYER") :test #'string=) "Year")
    (t id)))

;; As a hack in the ID3 format the string in a text info frame can
;; have an embedded null. Programs are not supposed to display any
;; information beyond the null. SUBSEQ and POSITION work together
;; nicely in this case since a NIL third argument to SUBSEQ is
;; equivalent to the length of the string.

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Extracting information from ID3 tag

(defun find-frame (id3 ids)
  (find-if #'(lambda (x) (find (id x) ids :test #'string=)) (frames id3)))

(defun get-text-info (id3 &rest ids)
  (let ((frame (find-frame id3 ids)))
    (when frame (upto-null (information frame)))))

(defun upto-null (string)
  (subseq string 0 (position +null+ string)))

(defmethod information ((frame generic-frame-v2.3))
  (with-output-to-string (s)
    (loop for byte across (data frame) do
          (format s "~2,'0x" byte))))

(defun album (id3) (get-text-info id3 "TAL" "TALB"))

(defun composer (id3) (get-text-info id3 "TCM" "TCOM"))

(defun genre (id3) (get-text-info id3 "TCO" "TCON"))

(defun encoding-program (id3) (get-text-info id3 "TEN" "TENC"))

(defun artist (id3) (get-text-info id3 "TP1" "TPE1"))

(defun part-of-set (id3) (get-text-info id3 "TPA" "TPOS"))

(defun track (id3) (get-text-info id3 "TRK" "TRCK"))

(defun song (id3) (get-text-info id3 "TT2" "TIT2"))

(defun year (id3) (get-text-info id3 "TYE" "TYER" "TDRC"))

;;; The first version of the ID3 format used a single byte to encode
;;; the genre. There were originally 80 official v1 genres. The makers
;;; of Winamp extended the list. 

(defun translated-genre (id3)
  (let ((genre (genre id3)))
    (if (and genre (char= #\( (char genre 0)))
      (translate-v1-genre genre)
      genre)))

(defparameter *id3-v1-genres*
  #(
    ;; These are the official ID3v1 genres.
    "Blues" "Classic Rock" "Country" "Dance" "Disco" "Funk" "Grunge"
    "Hip-Hop" "Jazz" "Metal" "New Age" "Oldies" "Other" "Pop" "R&B" "Rap"
    "Reggae" "Rock" "Techno" "Industrial" "Alternative" "Ska"
    "Death Metal" "Pranks" "Soundtrack" "Euro-Techno" "Ambient"
    "Trip-Hop" "Vocal" "Jazz+Funk" "Fusion" "Trance" "Classical"
    "Instrumental" "Acid" "House" "Game" "Sound Clip" "Gospel" "Noise"
    "AlternRock" "Bass" "Soul" "Punk" "Space" "Meditative"
    "Instrumental Pop" "Instrumental Rock" "Ethnic" "Gothic" "Darkwave"
    "Techno-Industrial" "Electronic" "Pop-Folk" "Eurodance" "Dream"
    "Southern Rock" "Comedy" "Cult" "Gangsta" "Top 40" "Christian Rap"
    "Pop/Funk" "Jungle" "Native American" "Cabaret" "New Wave"
    "Psychadelic" "Rave" "Showtunes" "Trailer" "Lo-Fi" "Tribal"
    "Acid Punk" "Acid Jazz" "Polka" "Retro" "Musical" "Rock & Roll"
    "Hard Rock"

    ;; These were made up by the authors of Winamp but backported into
    ;; the ID3 spec.
    "Folk" "Folk-Rock" "National Folk" "Swing" "Fast Fusion"
    "Bebob" "Latin" "Revival" "Celtic" "Bluegrass" "Avantgarde"
    "Gothic Rock" "Progressive Rock" "Psychedelic Rock" "Symphonic Rock"
    "Slow Rock" "Big Band" "Chorus" "Easy Listening" "Acoustic" "Humour"
    "Speech" "Chanson" "Opera" "Chamber Music" "Sonata" "Symphony"
    "Booty Bass" "Primus" "Porn Groove" "Satire" "Slow Jam" "Club"
    "Tango" "Samba" "Folklore" "Ballad" "Power Ballad" "Rhythmic Soul"
    "Freestyle" "Duet" "Punk Rock" "Drum Solo" "A capella" "Euro-House"
    "Dance Hall"

    ;; These were also invented by the Winamp folks but ignored by the
    ;; ID3 authors.
    "Goa" "Drum & Bass" "Club-House" "Hardcore" "Terror" "Indie"
    "BritPop" "Negerpunk" "Polsk Punk" "Beat" "Christian Gangsta Rap"
    "Heavy Metal" "Black Metal" "Crossover" "Contemporary Christian"
    "Christian Rock" "Merengue" "Salsa" "Thrash Metal" "Anime" "Jpop"
    "Synthpop"))


(defun translate-v1-genre (genre)
  (aref *id3-v1-genres* (parse-integer genre :start 1 :junk-allowed t)))



#+END_SRC

* Chapter26
** [[/Users/Can/Develop/Lisp/document/pcl/code/Chapter26/packages.lisp][packages]]
#+BEGIN_SRC lisp 
(in-package :cl-user)

(defpackage :com.gigamonkeys.url-function
  (:use :common-lisp 
        :net.aserve 
        :com.gigamonkeys.html
        :com.gigamonkeys.macro-utilities)
  (:export :define-url-function
           :string->type))


#+END_SRC

** [[/Users/Can/Develop/Lisp/document/pcl/code/Chapter26/html-infrastructure.lisp][html-infrastructure]]
#+BEGIN_SRC lisp 
(in-package :com.gigamonkeys.url-function)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; API

(defmacro define-url-function (name (request &rest params) &body body)
  (with-gensyms (entity)
    (let ((params (mapcar #'normalize-param params)))
      `(progn
         (defun ,name (,request ,entity)
           (with-http-response (,request ,entity :content-type "text/html")
             (let* (,@(param-bindings name request params))
               ,@(set-cookies-code name request params)
               (with-http-body (,request ,entity)
                 (with-html-output ((request-reply-stream ,request))
                   (html ,@body))))))
         (publish :path ,(format nil "/~(~a~)" name) :function ',name)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Compiler code

(defun normalize-param (param)
  (etypecase param
    (list param)
    (symbol `(,param string nil nil))))

(defun param-bindings (function-name request params)
  (loop for param in params
     collect (param-binding function-name request param)))

(defun param-binding (function-name request param)
  (destructuring-bind (name type &optional default sticky) param
    (let ((query-name (symbol->query-name name))
          (cookie-name (symbol->cookie-name function-name name sticky)))
      `(,name (or 
               (string->type ',type (request-query-value ,query-name ,request))
               ,@(if cookie-name
                     (list `(string->type ',type (get-cookie-value ,request ,cookie-name))))
               ,default)))))

(defun symbol->query-name (sym)
  (string-downcase sym))

(defun symbol->cookie-name (function-name sym sticky)
  (let ((package-name (package-name (symbol-package function-name))))
    (when sticky
      (ecase sticky
        (:global
         (string-downcase sym))
        (:package
         (format nil "~(~a:~a~)" package-name sym))
        (:local 
         (format nil "~(~a:~a:~a~)" package-name function-name sym))))))

(defun set-cookies-code (function-name request params)
  (loop for param in params
       when (set-cookie-code function-name request param) collect it))

(defun set-cookie-code (function-name request param)
  (destructuring-bind (name type &optional default sticky) param
    (declare (ignore type default))
    (if sticky
      `(when ,name 
         (set-cookie-header 
          ,request
          :name ,(symbol->cookie-name function-name name sticky)
          :value (princ-to-string ,name))))))
  
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Runtime

(defgeneric string->type (type value))

(defmethod string->type ((type (eql 'string)) value)
  (and (plusp (length value)) value))

(defun get-cookie-value (request name)
  (cdr (assoc name (get-cookie-values request) :test #'string=)))




#+END_SRC

** [[/Users/Can/Develop/Lisp/document/pcl/code/Chapter26/allegroserve.lisp][allegroserve]]
#+BEGIN_SRC lisp 
;;; This file contains the demonstration code used in Chapter 26. This
;;; file is not loaded as part of the url-function system.

(require :aserve)

(defpackage :com.gigamonkeys.web
  (:use :cl :net.aserve :com.gigamonkeys.html :com.gigamonkeys.url-function))

(in-package :com.gigamonkeys.web)

(start :port 2001)

(publish :path "/random-number" :function 'random-number)

(defun random-number (request entity)
  (with-http-response (request entity :content-type "text/html")
    (with-http-body (request entity)
      (format 
       (request-reply-stream request)
       "<html>~@
            <head><title>Random</title></head>~@
            <body>~@
            <p>Random number: ~d</p>~@
            </body>~@
            </html>~@
           "
       (random 1000)))))

(defun random-number (request entity)
  (with-http-response (request entity :content-type "text/html")
    (with-http-body (request entity)
      (with-html-output ((request-reply-stream request))
        (html
          (:html
            (:head (:title "Random"))
            (:body
              (:p "Random number: " (:print (random 1000))))))))))

(publish :path "/show-query-params" :function 'show-query-params)

(defun show-query-params (request entity)
  (with-http-response (request entity :content-type "text/html")
    (with-http-body (request entity)
      (with-html-output ((request-reply-stream request))
        (html
          (:standard-page
           (:title "Query Parameters")
           (if (request-query request)
             (html 
               (:table :border 1
                       (loop for (k . v) in (request-query request)
                          do (html (:tr (:td k) (:td v))))))
             (html (:p "No query parameters.")))))))))

(publish :path "/simple-form" :function 'simple-form)

(defun simple-form (request entity)
  (with-http-response (request entity :content-type "text/html")
    (with-http-body (request entity)
      (with-html-output ((request-reply-stream request))
        (html
          (:html
            (:head (:title "Simple Form"))
            (:body
              (:form :method "POST" :action "/show-query-params"
                     (:table
                       (:tr (:td "Foo")
                            (:td (:input :name "foo" :size 20)))
                       (:tr (:td "Password")
                            (:td (:input :name "password" :type "password" :size 20))))
                     (:p (:input :name "submit" :type "submit" :value "Okay")
                         (:input ::type "reset" :value "Reset"))))))))))

(defun random-number (request entity)
  (with-http-response (request entity :content-type "text/html")
    (with-http-body (request entity)
      (with-html-output ((request-reply-stream request))
        (let* ((limit-string (or (request-query-value "limit" request) ""))
               (limit (or (parse-integer limit-string :junk-allowed t) 1000)))
          (html
            (:html
              (:head (:title "Random"))
              (:body
                (:p "Random number: " (:print (random limit)))))))))))

(defun show-cookies (request entity)
  (with-http-response (request entity :content-type "text/html")
    (with-http-body (request entity)
      (with-html-output ((request-reply-stream request))
        (html
          (:standard-page
           (:title "Cookies")
           (if (null (get-cookie-values request))
             (html (:p "No cookies."))
             (html 
               (:table
                 (loop for (key . value) in (get-cookie-values request)
                    do (html (:tr (:td key) (:td value)))))))))))))

(publish :path "/show-cookies" :function 'show-cookies)



(defun set-cookie (request entity)
  (with-http-response (request entity :content-type "text/html")
    (set-cookie-header request :name "MyCookie" :value "A cookie value")
    (with-http-body (request entity)
      (with-html-output ((request-reply-stream request))
        (html 
          (:standard-page
           (:title "Set Cookie")
           (:p "Cookie set.")
           (:p (:a :href "/show-cookies" "Look at cookie jar."))))))))

(publish :path "/set-cookie" :function 'set-cookie)

(defmethod string->type ((type (eql 'integer)) value)
  (parse-integer (or value "") :junk-allowed t))

(define-url-function random-number (request (limit integer 1000))
  (:html
    (:head (:title "Random"))
    (:body
      (:p "Random number: " (:print (random limit))))))

#+END_SRC

* Chapter27
** [[/Users/Can/Develop/Lisp/document/pcl/code/Chapter27/packages.lisp][packages]]
#+BEGIN_SRC lisp 
(in-package :cl-user)

(defpackage :com.gigamonkeys.mp3-database
  (:use :common-lisp 
        :com.gigamonkeys.pathnames
        :com.gigamonkeys.macro-utilities
        :com.gigamonkeys.id3v2)
  (:export  :*default-table-size*
            :*mp3-schema*
            :*mp3s*
            :column
            :column-value
            :delete-all-rows
            :delete-rows
            :do-rows
            :extract-schema
            :in
            :insert-row
            :load-database
            :make-column
            :make-schema
            :map-rows
            :matching
            :not-nullable
            :nth-row
            :random-selection
            :schema
            :select
            :shuffle-table
            :sort-rows
            :table
            :table-size
            :with-column-values))

#+END_SRC

** [[/Users/Can/Develop/Lisp/document/pcl/code/Chapter27/mp3-database.lisp][mp3-database]]
#+BEGIN_SRC lisp 
(in-package :com.gigamonkeys.mp3-database)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Load database

(defparameter *mp3-schema* 
  (make-schema 
   '((:file     string)
     (:genre    interned-string "Unknown")
     (:artist   interned-string "Unknown")
     (:album    interned-string "Unknown")
     (:song     string)
     (:track    number 0)
     (:year     number 0)
     (:id3-size number))))

(defparameter *mp3s* (make-instance 'table :schema *mp3-schema*))

(defun load-database (dir db)
  (let ((count 0))
    (walk-directory 
     dir 
     #'(lambda (file)
         (princ #\.)
         (incf count)
         (insert-row (file->row file) db))
     :test #'mp3-p)
    (format t "~&Loaded ~d files into database." count)))

(defun file->row (file)
  (let ((id3 (read-id3 file)))
    (list
     :file   (namestring (truename file))
     :genre  (translated-genre id3)
     :artist (artist id3)
     :album  (album id3)
     :song   (song id3)
     :track  (parse-track (track id3))
     :year   (parse-year (year id3))
     :id3-size (size id3))))

(defun parse-track (track)
  (when track (parse-integer track :end (position #\/ track))))

(defun parse-year (year)
  (when year (parse-integer year)))

#+END_SRC

** [[/Users/Can/Develop/Lisp/document/pcl/code/Chapter27/database.lisp][database]]
#+BEGIN_SRC lisp 
(in-package :com.gigamonkeys.mp3-database)

(defparameter *default-table-size* 100)

(defclass table ()
  ((rows   :accessor rows   :initarg :rows :initform (make-rows))
   (schema :accessor schema :initarg :schema)))

(defun make-rows (&optional (size *default-table-size*))
  (make-array size :adjustable t :fill-pointer 0))

(defclass column ()
  ((name               
    :reader name
    :initarg :name)
   (equality-predicate
    :reader equality-predicate
    :initarg :equality-predicate)
   (comparator
    :reader comparator
    :initarg :comparator)
   (default-value
    :reader default-value
    :initarg :default-value
    :initform nil)
   (value-normalizer
    :reader value-normalizer
    :initarg :value-normalizer
    :initform #'(lambda (v column) (declare (ignore column)) v))))

(defclass interned-values-column (column)
  ((interned-values
    :reader interned-values
    :initform (make-hash-table :test #'equal))
   (equality-predicate :initform #'eql)
   (value-normalizer   :initform #'intern-for-column)))

(defun intern-for-column (value column)
  (let ((hash (interned-values column)))
    (or (gethash (not-nullable value column) hash)
        (setf (gethash value hash) value))))

;;; Schemas

(defgeneric make-column (name type &optional default-value))
  
(defun make-schema (spec)
  (mapcar #'(lambda (column-spec) (apply #'make-column column-spec)) spec))

(defun find-column (column-name schema)
  (or (find column-name schema :key #'name)
      (error "No column: ~a in schema: ~a" column-name schema)))

;;; Column constructors

(defmethod make-column (name (type (eql 'string)) &optional default-value)
  (make-instance
   'column 
   :name name
   :comparator #'string< 
   :equality-predicate #'string=
   :default-value default-value
   :value-normalizer #'not-nullable))

(defmethod make-column (name (type (eql 'number)) &optional default-value)
  (make-instance 
   'column
   :name name
   :comparator #'< 
   :equality-predicate #'=
   :default-value default-value))

(defmethod make-column (name (type (eql 'interned-string)) &optional default-value)
  (make-instance 
   'interned-values-column
   :name name
   :comparator #'string< 
   :default-value default-value))

(defun not-nullable (value column)
  (or value (error "Column ~a can't be null" (name column))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; INSERT-ROW

(defun insert-row (names-and-values table)
  (vector-push-extend (normalize-row names-and-values (schema table)) (rows table)))

(defun normalize-row (names-and-values schema)
  (loop
     for column in schema
     for name = (name column)
     for value = (or (getf names-and-values name) (default-value column))
     collect name
     collect (normalize-for-column value column)))

(defun normalize-for-column (value column)
  (funcall (value-normalizer column) value column))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; SELECT

(defun select (&key (columns t) from where distinct order-by)
  (let ((rows (rows from))
        (schema (schema from)))

    (when where
      (setf rows (restrict-rows rows where)))

    (unless (eql columns 't)
      (setf schema (extract-schema (mklist columns) schema))
      (setf rows (project-columns rows schema)))

    (when distinct
      (setf rows (distinct-rows rows schema)))

    (when order-by
      (setf rows (sorted-rows rows schema (mklist order-by))))
    
    (make-instance 'table :rows rows :schema schema)))

(defun restrict-rows (rows where)
  (remove-if-not where rows))

(defun project-columns (rows schema)
  (map 'vector (extractor schema) rows))

(defun distinct-rows (rows schema)
  (remove-duplicates rows :test (row-equality-tester schema)))

(defun sorted-rows (rows schema order-by)
  (sort (copy-seq rows) (row-comparator order-by schema)))

;;; where-clause builders

(defun matching (table &rest names-and-values)
  "Build a where function that matches rows with the given column values."
  (let ((matchers (column-matchers (schema table) names-and-values)))
    #'(lambda (row)
        (every #'(lambda (matcher) (funcall matcher row)) matchers))))

(defun column-matchers (schema names-and-values)
  (loop for (name value) on names-and-values by #'cddr
     when value collect
       (column-matcher (find-column name schema) value)))

(defun column-matcher (column value)
  (let ((name (name column))
        (predicate (equality-predicate column))
        (normalized (normalize-for-column value column)))
    #'(lambda (row) (funcall predicate (getf row name) normalized))))

(defun in (column-name table)
  "Build a where function that matches rows in which the value of
  the named column is in the given table"
  (let ((test (equality-predicate (find-column column-name (schema table))))
        (values (map 'list #'(lambda (r) (getf r column-name)) (rows table))))
    #'(lambda (row)
        (member (getf row column-name) values :test test))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Table info and utilities

(defun column-value (row column-name)
  (getf row column-name))

(defmacro do-rows ((row table) &body body)
  `(loop for ,row across (rows ,table) do ,@body))

(defun map-rows (fn table)
  (loop for row across (rows table) collect (funcall fn row)))

(defun table-size (table)
  (length (rows table)))

(defun nth-row (n table)
  (aref (rows table) n))

(defmacro with-column-values ((&rest vars) row &body body)
  (once-only (row)
    `(let ,(column-bindings vars row) ,@body)))

(defun column-bindings (vars row)
  (loop for v in vars collect `(,v (column-value ,row ,(as-keyword v)))))

(defun as-keyword (symbol)
  (intern (symbol-name symbol) :keyword))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; DELETE-ROWS, DELETE-ALL-ROWS

(defun delete-rows (&key from where)
  (loop
     with rows = (rows from)
     with store-idx = 0
     for read-idx from 0
     for row across rows
     do (setf (aref rows read-idx) nil)
     unless (funcall where row) do
       (setf (aref rows store-idx) row)
       (incf store-idx)
     finally (setf (fill-pointer rows) store-idx)))

(defun delete-all-rows (table)
  (setf (rows table) (make-rows *default-table-size*)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; SORT-ROWS

(defun sort-rows (table &rest column-names)
  (setf (rows table) (sort (rows table) (row-comparator column-names (schema table))))
  table)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; RANDOM-SELECTION and SHUFFLE-TABLE


(defun shuffle-table (table)
  (nshuffle-vector (rows table))
  table)

(defun nshuffle-vector (vector)
  "Shuffle a vector in place." 
  (loop for idx downfrom (1- (length vector)) to 1
        for other = (random (1+ idx))
        do (unless (= idx other)
             (rotatef (aref vector idx) (aref vector other))))
  vector)

(defun random-selection (table n)
  (make-instance
   'table
   :schema (schema table)
   :rows (nshuffle-vector (random-sample (rows table) n))))

(defun random-sample (vector n)
  "Based on Algorithm S from Knuth. TAOCP, vol. 2. p. 142"
  (loop with selected = (make-array n :fill-pointer 0)
     for idx from 0
     do
       (loop
          with to-select = (- n (length selected))
          for remaining = (- (length vector) idx)
          while (>= (* remaining (random 1.0)) to-select)
          do (incf idx))
       (vector-push (aref vector idx) selected)
     when (= (length selected) n) return selected))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Helpers

(defun mklist (thing)
  (if (listp thing) thing (list thing)))

(defun extract-schema (column-names schema)
  (loop for c in column-names collect (find-column c schema)))

(defun extractor (schema)
  (let ((names (mapcar #'name schema)))
    #'(lambda (row)
        (loop for c in names collect c collect (getf row c)))))

(defun row-equality-tester (schema)
  (let ((names (mapcar #'name schema))
        (tests (mapcar #'equality-predicate schema)))
    #'(lambda (a b)
        (loop for name in names and test in tests
           always (funcall test (getf a name) (getf b name))))))

(defun row-comparator (column-names schema)
  (let ((comparators (mapcar #'comparator (extract-schema column-names schema))))
    #'(lambda (a b)
        (loop
           for name in column-names
           for comparator in comparators
           for a-value = (getf a name)
           for b-value = (getf b name)
           when (funcall comparator a-value b-value) return t
           when (funcall comparator b-value a-value) return nil
           finally (return nil)))))



#+END_SRC

* Chapter28
** [[/Users/Can/Develop/Lisp/document/pcl/code/Chapter28/song-source.lisp][song-source]]
#+BEGIN_SRC lisp 
(in-package :com.gigamonkeys.shoutcast)

(defclass song ()
  ((file     :reader file     :initarg :file)
   (title    :reader title    :initarg :title)
   (id3-size :reader id3-size :initarg :id3-size)))

(defgeneric find-song-source (type request)
  (:documentation "Find the song-source of the given type for the given request."))

(defgeneric current-song (source)
  (:documentation "Return the currently playing song or NIL."))

(defgeneric still-current-p (song source)
  (:documentation
   "Return true if the song given is the same as the current-song."))

(defgeneric maybe-move-to-next-song (song source)
  (:documentation
   "If the given song is still the current one update the value
returned by current-song."))

;;; Singleton implementation

(defclass simple-song-queue ()
  ((songs :accessor songs :initform (make-array 10 :adjustable t :fill-pointer 0))
   (index :accessor index :initform 0)))

(defparameter *songs* (make-instance 'simple-song-queue))

(defmethod find-song-source ((type (eql 'singleton)) request)
  (declare (ignore request))
  *songs*)

(defmethod current-song ((source simple-song-queue))
  (when (array-in-bounds-p (songs source) (index source))
    (aref (songs source) (index source))))

(defmethod still-current-p (song (source simple-song-queue))
  (eql song (current-song source)))

(defmethod maybe-move-to-next-song (song (source simple-song-queue))
  (when (still-current-p song source)
    (incf (index source))))

(defun add-file-to-songs (file)
  (vector-push-extend (file->song file) (songs *songs*)))

(defun file->song (file)
  (let ((id3 (read-id3 file)))
    (make-instance 
     'song
     :file (namestring (truename file))
     :title (format nil "~a by ~a from ~a" (song id3) (artist id3) (album id3))
     :id3-size (size id3))))

#+END_SRC

** [[/Users/Can/Develop/Lisp/document/pcl/code/Chapter28/shoutcast.lisp][shoutcast]]
#+BEGIN_SRC lisp 
(in-package :com.gigamonkeys.shoutcast)

(defparameter *metadata-interval* (expt 2 12))
(defparameter *timeout-seconds* (* 60 60 24 7 52 10))
(defparameter *song-source-type* 'singleton)

(publish :path "/stream.mp3" :function 'shoutcast)

(defun shoutcast (request entity)
  (with-http-response
      (request entity :content-type "audio/MP3" :timeout *timeout-seconds*)
    (prepare-icy-response request *metadata-interval*)
    (let ((wants-metadata-p (header-slot-value request :icy-metadata)))
      (with-http-body (request entity)
        (play-songs 
         (request-socket request)
         (find-song-source *song-source-type* request)
         (if wants-metadata-p *metadata-interval*))))))

(defun prepare-icy-response (request metadata-interval)
  (setf (request-reply-protocol-string request) "ICY")
  (loop for (k v) in (reverse
       `((:|icy-metaint| ,(princ-to-string metadata-interval))
         (:|icy-notice1| "<BR>This stream blah blah blah<BR>")
         (:|icy-notice2| "More blah")
         (:|icy-name|    "MyLispShoutcastServer")
         (:|icy-genre|   "Unknown")
         (:|icy-url|     ,(request-uri request))
         (:|icy-pub|     "1")))
     do (setf (reply-header-slot-value request k) v))
  ;; iTunes, despite claiming to speak HTTP/1.1, doesn't understand
  ;; chunked Transfer-encoding. Grrr. So we just turn it off.
  (turn-off-chunked-transfer-encoding request))

(defun turn-off-chunked-transfer-encoding (request)
  ;; We have to use a bit of knowledge about AllegroServe's internals
  ;; to do this.
  (setf (request-reply-strategy request)
        (remove :chunked (request-reply-strategy request))))

(defun play-songs (stream song-source metadata-interval)
  (handler-case 
      (loop
         for next-metadata = metadata-interval
         then (play-current 
               stream 
               song-source
               next-metadata
               metadata-interval)
         while next-metadata)
    (error (e) (format *trace-output* "Caught error in play-songs: ~a" e))))


;;; Simple version of play current
(defun play-current (out song-source next-metadata metadata-interval)
  (let ((song (current-song song-source)))
    (when song
      (let ((metadata (make-icy-metadata (title song))))
        (with-open-file (mp3 (file song))
          (unless (file-position mp3 (id3-size song))
            (error "Can't skip to position ~d in ~a" (id3-size song) (file song)))
          (loop for byte = (read-byte mp3 nil nil)
             while (and byte (still-current-p song song-source)) do
               (write-byte byte out)
               (decf next-metadata)
             when (and (zerop next-metadata) metadata-interval) do
               (write-sequence metadata out)
               (setf next-metadata metadata-interval))
          
          (maybe-move-to-next-song song song-source)))
      next-metadata)))

;;; i/o efficient version of play-current
#+(or)
(defun play-current (out song-source next-metadata metadata-interval)
  (let ((song (current-song song-source)))
    (when song
      (let ((metadata (make-icy-metadata (title song)))
            (buffer (make-array size :element-type '(unsigned-byte 8))))
        (with-open-file (mp3 (file song))
          (labels ((write-buffer (start end)
                     (if metadata-interval
                       (write-buffer-with-metadata start end)
                       (write-sequence buffer out :start start :end end)))
                   
                   (write-buffer-with-metadata (start end)
                     (cond
                       ((> next-metadata (- end start))
                        (write-sequence buffer out :start start :end end)
                        (decf next-metadata (- end start)))
                       (t 
                        (let ((middle (+ start next-metadata)))
                          (write-sequence buffer out :start start :end middle)
                          (write-sequence metadata out)
                          (setf next-metadata metadata-interval)
                          (write-buffer-with-metadata middle end))))))
            
            (multiple-value-bind (skip-blocks skip-bytes)
                (floor (id3-size song) (length buffer))
              
              (unless (file-position mp3 (* skip-blocks (length buffer)))
                (error "Couldn't skip over ~d ~d byte blocks."
                       skip-blocks (length buffer)))

              (loop for end = (read-sequence buffer mp3) 
                 for start = skip-bytes then 0
                 do (write-buffer start end)
                 while (and (= end (length buffer))
                            (still-current-p song song-source)))
              
              (maybe-move-to-next-song song song-source)))))
      next-metadata)))

(defun make-icy-metadata (title)
  (let* ((text (format nil "StreamTitle='~a';" (substitute #\Space #\' title)))
         (blocks (ceiling (length text) 16))
         (buffer (make-array (1+ (* blocks 16))
                             :element-type '(unsigned-byte 8)
                             :initial-element 0)))
    (setf (aref buffer 0) blocks)
    (loop 
       for char across text
       for i from 1 
       do (setf (aref buffer i) (char-code char)))
    buffer))





#+END_SRC

** [[/Users/Can/Develop/Lisp/document/pcl/code/Chapter28/packages.lisp][packages]]
#+BEGIN_SRC lisp 
(in-package :cl-user)

(defpackage :com.gigamonkeys.shoutcast
  (:use :common-lisp 
        :net.aserve 
        :com.gigamonkeys.id3v2)
  (:export :song
           :file
           :title
           :id3-size
           :find-song-source
           :current-song
           :still-current-p
           :maybe-move-to-next-song
           :*song-source-type*))


#+END_SRC

* Chapter29
** [[/Users/Can/Develop/Lisp/document/pcl/code/Chapter29/playlist.lisp][playlist]]
#+BEGIN_SRC lisp 
(in-package :com.gigamonkeys.mp3-browser)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Two versions of silence

;; Set this variable to the filename of an MP3 of silence.
(defparameter *silence-mp3* nil)

(defun make-silent-song (title &optional (file *silence-mp3*))
  (make-instance
   'song 
   :file file
   :title title
   :id3-size (if (id3-p file) (size (read-id3 file)) 0)))

(defparameter *empty-playlist-song* (make-silent-song "Playlist empty."))

(defparameter *end-of-playlist-song* (make-silent-song "At end of playlist."))

(defclass playlist ()
  ((id           :accessor id           :initarg :id)
   (songs-table  :accessor songs-table  :initform (make-playlist-table))
   (current-song :accessor current-song :initform *empty-playlist-song*)
   (current-idx  :accessor current-idx  :initform 0)
   (ordering     :accessor ordering     :initform :album)
   (shuffle      :accessor shuffle      :initform :none)
   (repeat       :accessor repeat       :initform :none)
   (user-agent   :accessor user-agent   :initform "Unknown")
   (lock         :reader   lock         :initform (make-process-lock))))

(defun make-playlist-table ()
  (make-instance 'table :schema *mp3-schema*))

(defmacro with-playlist-locked ((playlist) &body body)
  `(with-process-lock ((lock ,playlist))
     ,@body))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; find-song-source

(defvar *playlists* (make-hash-table :test #'equal))
(defparameter *playlists-lock* (make-process-lock :name "playlists-lock"))

(defmethod find-song-source ((type (eql 'playlist)) request)
  (let ((playlist (lookup-playlist (playlist-id request))))
    (with-playlist-locked (playlist)
      (let ((user-agent (header-slot-value request :user-agent)))
        (when user-agent (setf (user-agent playlist) user-agent))))
    playlist))

(defun lookup-playlist (id)
  (with-process-lock (*playlists-lock*)
    (or (gethash id *playlists*)
        (setf (gethash id *playlists*) (make-instance 'playlist :id id)))))

(defun playlist-id (request)
  (ipaddr-to-dotted (remote-host (request-socket request))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; song-source implementation

(defmethod current-song :around ((playlist playlist))
  (with-playlist-locked (playlist) (call-next-method)))

(defmethod still-current-p (song (playlist playlist))
  (with-playlist-locked (playlist)
    (eql song (current-song playlist))))

(defmethod maybe-move-to-next-song (song (playlist playlist))
  (with-playlist-locked (playlist)
    (when (still-current-p song playlist)
      (unless (at-end-p playlist)
        (ecase (repeat playlist)
          (:song) ; nothing changes
          (:none (incf (current-idx playlist)))
          (:all  (setf (current-idx playlist)
                       (mod (1+ (current-idx playlist))
                            (table-size (songs-table playlist)))))))
      (update-current-if-necessary playlist))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Internals

;;; update-current-if-necessary

(defun update-current-if-necessary (playlist)
  (unless (equal (file (current-song playlist))
                 (file-for-current-idx playlist))
    (reset-current-song playlist)))

(defun file-for-current-idx (playlist)
  (if (at-end-p playlist)
    nil
    (column-value (nth-row (current-idx playlist) (songs-table playlist)) :file)))

(defun at-end-p (playlist)
  (>= (current-idx playlist) (table-size (songs-table playlist))))

(defun reset-current-song (playlist)
  (setf
   (current-song playlist) 
   (cond
     ((empty-p playlist) *empty-playlist-song*)
     ((at-end-p playlist) *end-of-playlist-song*)
     (t (row->song (nth-row (current-idx playlist) (songs-table playlist)))))))

(defun row->song (song-db-entry)
  (with-column-values (file song artist album id3-size) song-db-entry
    (make-instance
     'song
     :file file
     :title (format nil "~a by ~a from ~a" song artist album)
     :id3-size id3-size)))

(defun empty-p (playlist)
  (zerop (table-size (songs-table playlist))))


;;; Playlist manipulation functions called from mp3-browser.lisp

(defun add-songs (playlist column-name values)
  (let ((table (make-instance
                'table 
                :schema (extract-schema (list column-name) (schema *mp3s*)))))
    (dolist (v values) (insert-row (list column-name v) table))
    (do-rows (row (select :from *mp3s* :where (in column-name table)))
      (insert-row row (songs-table playlist))))
  (update-current-if-necessary playlist))

(defun delete-songs (playlist &rest names-and-values)
  (delete-rows
   :from (songs-table playlist)
   :where (apply #'matching (songs-table playlist) names-and-values))
  (setf (current-idx playlist) (or (position-of-current playlist) 0))
  (update-current-if-necessary playlist))
  
(defun clear-playlist (playlist)
  (delete-all-rows (songs-table playlist))
  (setf (current-idx playlist) 0)
  (update-current-if-necessary playlist))

(defun sort-playlist (playlist ordering)
  (setf (ordering playlist) ordering)
  (setf (shuffle playlist) :none)
  (order-playlist playlist)
  (setf (current-idx playlist) (position-of-current playlist)))

(defun shuffle-playlist (playlist shuffle)
  (setf (shuffle playlist) shuffle)
  (case shuffle
    (:none (order-playlist playlist))
    (:song (shuffle-by-song playlist))
    (:album (shuffle-by-album playlist)))
  (setf (current-idx playlist) (position-of-current playlist)))

(defmethod (setf repeat) :after (value (playlist playlist))
  (if (and (at-end-p playlist) (not (empty-p playlist)))
    (ecase value
      (:song (setf (current-idx playlist) (1- (table-size (songs-table playlist)))))
      (:none)
      (:all  (setf (current-idx playlist) 0)))
    (update-current-if-necessary playlist)))

;;; Shuffling helpers

(defun position-of-current (playlist)
  (let* ((table (songs-table playlist))
         (matcher (matching table :file (file (current-song playlist))))
         (pos 0))
    (do-rows (row table)
      (when (funcall matcher row)
        (return-from position-of-current pos))
      (incf pos))))

(defun order-playlist (playlist)
  (apply #'sort-rows (songs-table playlist)
         (case (ordering playlist)
           (:genre  '(:genre :album :track))
           (:artist '(:artist :album :track))
           (:album  '(:album :track))
           (:song   '(:song)))))

(defun shuffle-by-song (playlist)
  (shuffle-table (songs-table playlist)))

(defun shuffle-by-album (playlist)
  (let ((new-table (make-playlist-table)))
    (do-rows (album-row (shuffled-album-names playlist))
      (do-rows (song (songs-for-album playlist (column-value album-row :album)))
        (insert-row song new-table)))
    (setf (songs-table playlist) new-table)))

(defun shuffled-album-names (playlist)
  (shuffle-table 
   (select
    :columns :album
    :from (songs-table playlist)
    :distinct t)))

(defun songs-for-album (playlist album)
  (select
   :from (songs-table playlist) 
   :where (matching (songs-table playlist) :album album)
   :order-by :track))






#+END_SRC

** [[/Users/Can/Develop/Lisp/document/pcl/code/Chapter29/packages.lisp][packages]]
#+BEGIN_SRC lisp 
(in-package :cl-user)

(defpackage :com.gigamonkeys.mp3-browser
  (:use :common-lisp 
        :net.aserve 
        :com.gigamonkeys.html
        :com.gigamonkeys.shoutcast
        :com.gigamonkeys.url-function
        :com.gigamonkeys.mp3-database
        :com.gigamonkeys.id3v2)
  (:import-from :acl-socket
                :ipaddr-to-dotted 
                :remote-host)
  (:import-from #+allegro :multiprocessing 
                #-allegro :acl-compat.mp
                :make-process-lock
                :with-process-lock)
  (:export :start-mp3-browser))
                


#+END_SRC

** [[/Users/Can/Develop/Lisp/document/pcl/code/Chapter29/mp3-browser.lisp][mp3-browser]]
#+BEGIN_SRC lisp 
(in-package :com.gigamonkeys.mp3-browser)

(defvar *major-version* 1)
(defvar *minor-version* 0)

(defparameter *mp3-dir* nil)

(defparameter *mp3-css* 
  (when *load-pathname* (make-pathname :name "mp3-browser" :type "css" :defaults *load-pathname*)))

(defun configure-mp3-browser (&optional force)
  (unless (or *mp3-dir* force)
    (format t "Enter root directory of MP3 collection: ")
    (force-output *standard-output*)
    (setf *mp3-dir* (read)))
  (unless (or *mp3-css* force)
    (format t "Enter full filename of mp3-browser.css: ")
    (force-output *standard-output*)
    (setf *mp3-css* (read))))

(defun start-mp3-browser ()
  (unless (and *mp3-dir* *mp3-css*)
    (configure-mp3-browser))
  (load-database *mp3-dir* *mp3s*)
  (publish-file :path "/mp3-browser.css"  :file *mp3-css* :content-type "text/css")
  (setf *song-source-type* 'playlist)
  (net.aserve::debug-on :notrap)
  (net.aserve:start :port 2001))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Parameter types for url functions

(defmethod string->type ((type (eql 'integer)) value)
  (parse-integer (or value "") :junk-allowed t))

(defmethod string->type ((type (eql 'keyword)) value)
  (and (plusp (length value)) (intern (string-upcase value) :keyword)))

(defun safe-read-from-string (string)
  (let ((*read-eval* nil)) (ignore-errors (read-from-string string))))

(defmethod string->type ((type (eql 'base-64-list)) value)
  (let ((obj (base64->obj value)))
    (if (listp obj) obj nil)))

(defmacro with-safe-io-syntax (&body body)
  `(with-standard-io-syntax
     (let ((*read-eval* nil))
       ,@body)))

(defun obj->base64 (obj)
  (base64-encode (with-safe-io-syntax (write-to-string obj))))

(defun base64->obj (string)
  (ignore-errors
    (with-safe-io-syntax (read-from-string (base64-decode string)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Standard page layout

(define-html-macro :mp3-browser-page ((&key title (header title)) &body body)
  `(:html
     (:head
      (:title ,title)
      (:link :rel "stylesheet" :type "text/css" :href "mp3-browser.css"))
     (:body
      (standard-header)
      (when ,header (html (:h1 :class "title" ,header)))
      ,@body
      (standard-footer))))

(defun link (target &rest attributes)
  (html 
    (:attribute
     (:format "~a~@[?~{~(~a~)=~a~^&~}~]" target (mapcar #'urlencode attributes)))))

(defun urlencode (string)
  (net.aserve::encode-form-urlencoded string))

(defparameter *random-amount* 25)

(defun standard-header ()
  (html 
    ((:p :class "toolbar")
     "[" (:a :href (link "/browse" :what "genre") "All genres") "] "
     "[" (:a :href (link "/browse" :what "genre" :random *random-amount*) "Random genres") "] "
     "[" (:a :href (link "/browse" :what "artist") "All artists") "] "
     "[" (:a :href (link "/browse":what "artist" :random *random-amount*) "Random artists") "] "
     "[" (:a :href (link "/browse":what "album") "All albums") "] "
     "[" (:a :href (link "/browse":what "album" :random *random-amount*) "Random albums") "] "
     "[" (:a :href (link "/browse" :what "song" :random *random-amount*) "Random songs") "] "
     "[" (:a :href (link "/playlist") "Playlist") "] "
     "[" (:a :href (link "/all-playlists") "All playlists") "]")))

(defun standard-footer ()
  (html (:hr) ((:p :class "footer") "MP3 Browser v" *major-version* "." *minor-version*)))

(define-html-macro :table-row (&attributes attrs &rest values)
  `(:tr ,@attrs ,@(loop for v in values collect `(:td ,v))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; MP3 Browser

(define-url-function browse
    (request (what keyword :genre) genre artist album (random integer))

  (let* ((values (values-for-page what genre artist album random))
         (title (browse-page-title what random genre artist album))
         (single-column (if (eql what :song) :file what))
         (values-string (values->base-64 single-column values)))
    (html
     (:mp3-browser-page
      (:title title)
      ((:form :method "POST" :action "playlist")
       (:input :name "values" :type "hidden" :value values-string)
       (:input :name "what" :type "hidden" :value single-column)
       (:input :name "action" :type "hidden" :value :add-songs)
       (:input :name "submit" :type "submit" :value "Add all"))
      (:ul (do-rows (row values) (list-item-for-page what row)))))))

(define-url-function playlist 
    (request
     (playlist-id string (playlist-id request) :package)
     (action keyword)      ; Playlist manipulation action
     (what keyword :file)  ; for :add-songs action
     (values base-64-list) ;             "
     file                  ; for :add-songs and :delete-songs actions
     genre                 ; for :delete-songs action
     artist                ;             "
     album                 ;             "
     (order-by keyword)    ; for :sort action
     (shuffle keyword)     ; for :shuffle action
     (repeat keyword))     ; for :set-repeat action

  (let ((playlist (lookup-playlist playlist-id)))
    (with-playlist-locked (playlist)

      (case action
        (:add-songs      (add-songs playlist what (or values (list file))))
        (:delete-songs   (delete-songs 
                          playlist 
                          :file file :genre genre
                          :artist artist :album album))
        (:clear          (clear-playlist playlist))
        (:sort           (sort-playlist playlist order-by))
        (:shuffle        (shuffle-playlist playlist shuffle))
        (:set-repeat     (setf (repeat playlist) repeat)))

      (html
        (:mp3-browser-page
         (:title (:format "Playlist - ~a" (id playlist)) :header nil)
         (playlist-toolbar playlist)
         (if (empty-p playlist)
           (html (:p (:i "Empty.")))
           (html 
             ((:table :class "playlist")
              (:table-row "#" "Song" "Album" "Artist" "Genre")
              (let ((idx 0)
                    (current-idx (current-idx playlist)))
                (do-rows (row (songs-table playlist))
                  (with-column-values (track file song album artist genre) row
                    (let ((row-style (if (= idx current-idx) "now-playing" "normal")))
                      (html
                        ((:table-row :class row-style)
                         track
                         (:progn song   (delete-songs-link :file file))
                         (:progn album  (delete-songs-link :album album))
                         (:progn artist (delete-songs-link :artist artist))
                         (:progn genre  (delete-songs-link :genre genre)))))
                    (incf idx))))))))))))

(define-url-function all-playlists (request)
  (:mp3-browser-page
   (:title "All Playlists")
   ((:table :class "all-playlists")
    (:table-row "Playlist" "# Songs" "Most recent user agent")
    (with-process-lock (*playlists-lock*)
      (loop for playlist being the hash-values of *playlists* do
           (html
             (:table-row
              (:a :href (link "playlist" :playlist-id (id playlist)) (:print (id playlist)))
              (:print (table-size (songs-table playlist)))
              (:print (user-agent playlist)))))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Helper functions

(defun values-for-page (what genre artist album random)
  (let ((values
         (select 
          :from *mp3s*
          :columns (if (eql what :song) t what)
          :where (matching *mp3s* :genre genre :artist artist :album album)
          :distinct (not (eql what :song))
          :order-by (if (eql what :song) '(:album :track) what))))
    (if random (random-selection values random) values)))

(defun browse-page-title (what random genre artist album)
  (with-output-to-string (s)
    (when random (format s "~:(~r~) Random " random))
    (format s "~:(~a~p~)" what random)
    (when (or genre artist album)
      (when (not (eql what :song)) (princ " with songs" s))
      (when genre  (format s " in genre ~a" genre))
      (when artist (format s " by artist ~a" artist))
      (when album  (format s " on album ~a" album)))))

(defun list-item-for-page (what row)
  (if (eql what :song)
    (with-column-values (song file album artist genre) row
      (html
        (:li
         (:a :href (link "playlist" :file file :action "add-songs") (:b song)) " from "
         (:a :href (link "browse"  :what :song :album  album) album) " by "
         (:a :href (link "browse" :what :song :artist artist) artist) " in genre "
         (:a :href (link "browse"  :what :song :genre  genre) genre))))
    (let ((value (column-value row what)))
      (html
       (:li value " - "
            (browse-link :genre  what value)
            (browse-link :artist what value)
            (browse-link :album  what value)
            (browse-link :song   what value))))))

(defun browse-link (new-what what value)
  (unless (eql new-what what)
    (html
     "[" 
     (:a :href (link "browse" :what new-what what value) (:format "~(~as~)" new-what))
     "] ")))

(defun playlist-toolbar (playlist)
  (let ((current-repeat (repeat playlist))
        (current-sort (ordering playlist))
        (current-shuffle (shuffle playlist)))
    (html
     (:p :class "playlist-toolbar"
         (:i "Sort by:")
         " [ "
         (sort-playlist-button "genre" current-sort) " | " 
         (sort-playlist-button "artist" current-sort) " | " 
         (sort-playlist-button "album" current-sort) " | " 
         (sort-playlist-button "song" current-sort) " ] "
         (:i "Shuffle by:")
         " [ "
         (playlist-shuffle-button "none" current-shuffle) " | "
         (playlist-shuffle-button "song" current-shuffle) " | "
         (playlist-shuffle-button "album" current-shuffle) " ] "
         (:i "Repeat:")
         " [ "
         (playlist-repeat-button "none" current-repeat) " | "
         (playlist-repeat-button "song" current-repeat) " | "
         (playlist-repeat-button "all" current-repeat) " ] "
         "[ " (:a :href (link "playlist" :action "clear") "Clear") " ] "))))

(defun playlist-button (action argument new-value current-value)
  (let ((label (string-capitalize new-value)))
    (if (string-equal new-value current-value)
      (html (:b label))
      (html (:a :href (link "playlist" :action action argument new-value) label)))))
  
(defun sort-playlist-button (order-by current-sort)
  (playlist-button :sort :order-by order-by current-sort))

(defun playlist-shuffle-button (shuffle current-shuffle)
  (playlist-button :shuffle :shuffle shuffle current-shuffle))

(defun playlist-repeat-button (repeat current-repeat)
  (playlist-button :set-repeat :repeat repeat current-repeat))

(defun delete-songs-link (what value)
  (html " [" (:a :href (link "playlist" :action :delete-songs what value) "x") "]"))

(defun values->base-64 (column values-table)
  (flet ((value (r) (column-value r column)))
    (obj->base64 (map-rows #'value values-table))))



#+END_SRC

* Chapter31
** [[/Users/Can/Develop/Lisp/document/pcl/code/Chapter31/packages.lisp][packages]]
#+BEGIN_SRC lisp 
(in-package :cl-user)

(defpackage :com.gigamonkeys.html
  (:use :common-lisp :com.gigamonkeys.macro-utilities)
  (:export :with-html-output
           :with-html-to-file
           :in-html-style
           :define-html-macro
           :define-css-macro
           :css
           :html
           :emit-css
           :emit-html
           :&attributes))

#+END_SRC

** [[/Users/Can/Develop/Lisp/document/pcl/code/Chapter31/html.lisp][html]]
#+BEGIN_SRC lisp 
(in-package #:com.gigamonkeys.html)

(defvar *pretty* t)
(defvar *html-output* *standard-output*)
(defvar *html-pretty-printer* nil)

(defparameter *xhtml* nil)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Public API

(defmacro with-html-output ((stream &key (pretty *pretty*)) &body body)
  `(let* ((*html-output* ,stream)
          (*pretty* ,pretty))
    ,@body))

(defmacro with-html-to-file ((file &key (pretty *pretty*)) &body body)
  (with-gensyms (stream)
    `(with-open-file (,stream ,file :direction :output :if-exists :supersede)
      (with-html-output (,stream :pretty ,pretty)
        ,@body))))

(defmacro in-html-style (syntax)
  (eval-when (:compile-toplevel :load-toplevel :execute)
    (case syntax
      (:html (setf *xhtml* nil))
      (:xhtml (setf *xhtml* t)))))

(defun emit-html (sexp) (process (get-pretty-printer) sexp))

(defmacro html (&whole whole &body body)
  (declare (ignore body))
  `(if *pretty*
     (macrolet ((html (&body body) (codegen-html (sexp->ops body) t)))
       (let ((*html-pretty-printer* (get-pretty-printer))) ,whole))
     (macrolet ((html (&body body) (codegen-html (sexp->ops body) nil)))
       ,whole)))

;;; Helpers for public API

(defun get-pretty-printer ()
  (or *html-pretty-printer*
      (make-instance 
       'html-pretty-printer
       :printer (make-instance 'indenting-printer :out *html-output*))))

(defun codegen-html (ops pretty)
  (let ((*pretty* pretty))
    `(progn ,@(generate-code (optimize-static-output ops)) nil)))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; String escaping

(defparameter *element-escapes* "<>&")
(defparameter *attribute-escapes* "<>&\"'")
(defvar *escapes* *element-escapes*)

(defun escape-char (char)
  (case char
    (#\& "&amp;")
    (#\< "&lt;")
    (#\> "&gt;")
    (#\' "&apos;")
    (#\" "&quot;")
    (t (format nil "&#~d;" (char-code char)))))

(defun escape (in to-escape)
  (flet ((needs-escape-p (char) (find char to-escape)))
    (with-output-to-string (out)
      (loop for start = 0 then (1+ pos)
            for pos = (position-if #'needs-escape-p in :start start)
            do (write-sequence in out :start start :end pos)
            when pos do (write-sequence (escape-char (char in pos)) out)
            while pos))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; indenting-printer

(defclass indenting-printer ()
  ((out                 :accessor out                 :initarg :out)
   (beginning-of-line-p :accessor beginning-of-line-p :initform t)
   (indentation         :accessor indentation         :initform 0)
   (indenting-p         :accessor indenting-p         :initform t)))

(defun emit (ip string)
  (loop for start = 0 then (1+ pos)
     for pos = (position #\Newline string :start start)
     do (emit/no-newlines ip string :start start :end pos)
     when pos do (emit-newline ip)
     while pos))

(defun emit/no-newlines (ip string &key (start 0) end)
  (indent-if-necessary ip)
  (write-sequence string (out ip) :start start :end end)
  (unless (zerop (- (or end (length string)) start))
    (setf (beginning-of-line-p ip) nil)))

(defun emit-newline (ip)
  (write-char #\Newline (out ip))
  (setf (beginning-of-line-p ip) t))

(defun emit-freshline (ip)
  (unless (beginning-of-line-p ip) (emit-newline ip)))

(defun indent-if-necessary (ip)
  (when (and (beginning-of-line-p ip) (indenting-p ip))
    (loop repeat (indentation ip) do (write-char #\Space (out ip)))
    (setf (beginning-of-line-p ip) nil)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; html processor interface

(defgeneric raw-string (processor string &optional check-for-newlines))

(defgeneric newline (processor))
  
(defgeneric freshline (processor))

(defgeneric indent (processor))

(defgeneric unindent (processor))

(defgeneric toggle-indenting (processor))

(defgeneric embed-value (processor value))

(defgeneric embed-code (processor code))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; html-pretty-printer

(defclass html-pretty-printer ()
  ((printer   :accessor printer   :initarg :printer)
   (tab-width :accessor tab-width :initarg :tab-width :initform 2)))

(defmethod raw-string ((pp html-pretty-printer) string &optional newlines-p)
  (if newlines-p
    (emit (printer pp) string)
    (emit/no-newlines (printer pp) string)))

(defmethod newline ((pp html-pretty-printer))
  (emit-newline (printer pp)))

(defmethod freshline ((pp html-pretty-printer))
  (when *pretty* (emit-freshline (printer pp))))

(defmethod indent ((pp html-pretty-printer))
  (when *pretty* 
    (incf (indentation (printer pp)) (tab-width pp))))

(defmethod unindent ((pp html-pretty-printer))
  (when *pretty* 
    (decf (indentation (printer pp)) (tab-width pp))))

(defmethod toggle-indenting ((pp html-pretty-printer))
  (when *pretty* 
    (with-slots (indenting-p) (printer pp)
      (setf indenting-p (not indenting-p)))))

(defmethod embed-value ((pp html-pretty-printer) value)
  (error "Can't embed values when interpreting. Value: ~s" value))

(defmethod embed-code ((pp html-pretty-printer) code)
  (error "Can't embed code when interpreting. Code: ~s" code))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Ops buffer

(defun make-op-buffer () (make-array 10 :adjustable t :fill-pointer 0))

(defun push-op (op ops-buffer) (vector-push-extend op ops-buffer))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Compiler

(defclass html-compiler ()
  ((ops :accessor ops :initform (make-op-buffer))))

(defmethod raw-string ((compiler html-compiler) string &optional newlines-p)
  (push-op `(:raw-string ,string ,newlines-p) (ops compiler)))

(defmethod newline ((compiler html-compiler))
  (push-op '(:newline) (ops compiler)))
  
(defmethod freshline ((compiler html-compiler))
  (push-op '(:freshline) (ops compiler)))

(defmethod indent ((compiler html-compiler))
  (push-op `(:indent) (ops compiler)))

(defmethod unindent ((compiler html-compiler))
  (push-op `(:unindent) (ops compiler)))

(defmethod toggle-indenting ((compiler html-compiler))
  (push-op `(:toggle-indenting) (ops compiler)))

(defmethod embed-value ((compiler html-compiler) value)
  (push-op `(:embed-value ,value ,*escapes*) (ops compiler)))

(defmethod embed-code ((compiler html-compiler) code)
  (push-op `(:embed-code ,code) (ops compiler)))

(defun sexp->ops (body)
  (loop with compiler = (make-instance 'html-compiler)
     for form in body do (process compiler form)
     finally (return (ops compiler))))

(defun optimize-static-output (ops)
  (let ((new-ops (make-op-buffer)))
    (with-output-to-string (buf)
      (flet ((add-op (op) 
               (compile-buffer buf new-ops)
               (push-op op new-ops)))
        (loop for op across ops do
             (ecase (first op)
               (:raw-string (write-sequence (second op) buf))
               ((:newline :embed-value :embed-code) (add-op op))
               ((:indent :unindent :freshline :toggle-indenting)
                (when *pretty* (add-op op)))))
        (compile-buffer buf new-ops)))
    new-ops))

(defun compile-buffer (buf ops)
  "Compile a string possibly containing newlines into a sequence of
:raw-string and :newline ops."
  (loop with str = (get-output-stream-string buf)
     for start = 0 then (1+ pos)
     for pos = (position #\Newline str :start start)
     when (< start (length str))
     do (push-op `(:raw-string ,(subseq str start pos) nil) ops)
     when pos do (push-op '(:newline) ops)
     while pos))

(defun generate-code (ops)
  (loop for op across ops collect (apply #'op->code op)))

(defgeneric op->code (op &rest operands))

(defmethod op->code ((op (eql :raw-string)) &rest operands)
  (destructuring-bind (string check-for-newlines) operands
    (if *pretty*
      `(raw-string *html-pretty-printer* ,string ,check-for-newlines)
      `(write-sequence ,string *html-output*))))

(defmethod op->code ((op (eql :newline)) &rest operands)
  (if *pretty*
    `(newline *html-pretty-printer*)
    `(write-char #\Newline *html-output*)))    

(defmethod op->code ((op (eql :freshline)) &rest operands)
  (if *pretty*
    `(freshline *html-pretty-printer*)
    (error "Bad op when not pretty-printing: ~a" op)))

(defmethod op->code ((op (eql :indent)) &rest operands)
  (if *pretty*
    `(indent *html-pretty-printer*)
    (error "Bad op when not pretty-printing: ~a" op)))

(defmethod op->code ((op (eql :unindent)) &rest operands)
  (if *pretty*
    `(unindent *html-pretty-printer*)
    (error "Bad op when not pretty-printing: ~a" op)))

(defmethod op->code ((op (eql :toggle-indenting)) &rest operands)
  (if *pretty*
    `(toggle-indenting *html-pretty-printer*)
    (error "Bad op when not pretty-printing: ~a" op)))

(defmethod op->code ((op (eql :embed-value)) &rest operands)
  (destructuring-bind (value escapes) operands
    (if *pretty*
      (if escapes
        `(raw-string *html-pretty-printer* (escape (princ-to-string ,value) ,escapes) t)
        `(raw-string *html-pretty-printer* (princ-to-string ,value) t))
      (if escapes
        `(write-sequence (escape (princ-to-string ,value) ,escapes) *html-output*)
        `(princ ,value *html-output*)))))

(defmethod op->code ((op (eql :embed-code)) &rest operands)
  (first operands))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; HTML processor.

(defun process (processor form)
  (cond
    ((special-form-p form) (process-special-form processor form))
    ((macro-form-p form)   (process processor (expand-macro-form form)))
    ((sexp-html-p form)    (process-sexp-html processor form))
    ((consp form)          (embed-code processor form))
    (t                     (embed-value processor form))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Language syntax

(defun sexp-html-p (form)
  (or (self-evaluating-p form) (cons-form-p form)))

(defun self-evaluating-p (form)
  (and (atom form) (if (symbolp form) (keywordp form) t)))

(defun cons-form-p (form &optional (test #'keywordp))
  (and (consp form)
       (or (funcall test (car form))
           (and (consp (car form)) (funcall test (caar form))))))

(defun macro-form-p (form)
  (cons-form-p form #'(lambda (x) (and (symbolp x) (get x 'html-macro)))))

(defun special-form-p (form)
  (and (consp form) (symbolp (car form)) (get (car form) 'html-special-operator)))

(defun parse-cons-form (sexp)
  (if (consp (first sexp))
    (parse-explicit-attributes-sexp sexp)
    (parse-implicit-attributes-sexp sexp)))

(defun parse-explicit-attributes-sexp (sexp)
  (destructuring-bind ((tag &rest attributes) &body body) sexp
    (values tag attributes body)))

(defun parse-implicit-attributes-sexp (sexp)
  (loop with tag = (first sexp)
     for rest on (rest sexp) by #'cddr
     while (and (keywordp (first rest)) (second rest))
     when (second rest)
     collect (first rest) into attributes and
     collect (second rest) into attributes
     end
     finally (return (values tag attributes rest))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; SEXP-HTML

(defparameter *block-elements*
  '(:body :colgroup :dl :fieldset :form :head :html :map :noscript :object
    :ol :optgroup :pre :script :select :style :table :tbody :tfoot :thead
    :tr :ul))

(defparameter *paragraph-elements*
  '(:area :base :blockquote :br :button :caption :col :dd :div :dt :h1
    :h2 :h3 :h4 :h5 :h6 :hr :input :li :link :meta :option :p :param
    :td :textarea :th :title))

(defparameter *inline-elements*
  '(:a :abbr :acronym :address :b :bdo :big :cite :code :del :dfn :em
    :i :img :ins :kbd :label :legend :q :samp :small :span :strong :sub
    :sup :tt :var))

(defparameter *empty-elements*
  '(:area :base :br :col :hr :img :input :link :meta :param))

(defparameter *preserve-whitespace-elements* '(:pre :script :style))

(defun process-sexp-html (processor form)
  (if (self-evaluating-p form)
    (raw-string processor (escape (princ-to-string form) *escapes*) t)
    (process-cons-sexp-html processor form)))

(defun process-cons-sexp-html (processor form)
  (when (string= *escapes* *attribute-escapes*)
    (error "Can't use cons forms in attributes: ~a" form))
  (multiple-value-bind (tag attributes body) (parse-cons-form form)
    (emit-open-tag     processor tag body attributes)
    (emit-element-body processor tag body)
    (emit-close-tag    processor tag body)))

(defun emit-open-tag (processor tag body-p attributes)
  (when (or (paragraph-element-p tag) (block-element-p tag))
    (freshline processor))
  (raw-string processor (format nil "<~(~a~)" tag))
  (emit-attributes processor attributes)
  (raw-string processor (if (and *xhtml* (not body-p)) "/>" ">")))

(defun emit-attributes (processor attributes)
  (loop for (k v) on attributes by #'cddr do
       (raw-string processor (format nil " ~(~a~)='" k))
       (let ((*escapes* *attribute-escapes*))
         (process processor (if (eql v t) (string-downcase k) v)))
       (raw-string processor "'")))

(defun emit-element-body (processor tag body)
  (when (block-element-p tag)
    (freshline processor)
    (indent processor))
  (when (preserve-whitespace-p tag) (toggle-indenting processor))
  (dolist (item body)  (process processor item))
  (when (preserve-whitespace-p tag) (toggle-indenting processor))
  (when (block-element-p tag)
    (unindent processor)
    (freshline processor)))

(defun emit-close-tag (processor tag body-p)
  (unless (and (or *xhtml* (empty-element-p tag)) (not body-p))
    (raw-string processor (format nil "</~(~a~)>" tag)))
  (when (or (paragraph-element-p tag) (block-element-p tag))
    (freshline processor)))

(defun block-element-p (tag) (find tag *block-elements*))

(defun paragraph-element-p (tag) (find tag *paragraph-elements*))

(defun empty-element-p (tag) (find tag *empty-elements*))

(defun preserve-whitespace-p (tag) (find tag *preserve-whitespace-elements*))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Special operators

(defmacro define-html-special-operator (name (processor &rest other-parameters) &body body)
  `(eval-when (:compile-toplevel :load-toplevel :execute)
     (setf (get ',name 'html-special-operator)
           (lambda (,processor ,@other-parameters) ,@body))))

(defun process-special-form (processor form)
  (apply (get (car form) 'html-special-operator) processor (rest form)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Macros

(defmacro define-html-macro (name (&rest args) &body body)
  (multiple-value-bind (attribute-var args)
      (parse-html-macro-lambda-list args)
    (if attribute-var
      (generate-macro-with-attributes name attribute-var args body)
      (generate-macro-no-attributes name args body))))

(defun generate-macro-with-attributes (name attribute-args args body)
  (with-gensyms (attributes form-body)
    (if (symbolp attribute-args) (setf attribute-args `(&rest ,attribute-args)))
    `(eval-when (:compile-toplevel :load-toplevel :execute)
       (setf (get ',name 'html-macro-wants-attributes) t)
       (setf (get ',name 'html-macro) 
             (lambda (,attributes ,form-body)
               (destructuring-bind (,@attribute-args) ,attributes
                 (destructuring-bind (,@args) ,form-body
                   ,@body)))))))

(defun generate-macro-no-attributes (name args body)
  (with-gensyms (form-body)
    `(eval-when (:compile-toplevel :load-toplevel :execute)
       (setf (get ',name 'html-macro-wants-attributes) nil)
       (setf (get ',name 'html-macro)
             (lambda (,form-body)
               (destructuring-bind (,@args) ,form-body ,@body))))))

(defun parse-html-macro-lambda-list (args)
  "Parse a lambda list that can include the &attributes lambda-list-keyword."
  (let ((attr-cons (member '&attributes args)))
    (values 
     (cadr attr-cons)
     (nconc (ldiff args attr-cons) (cddr attr-cons)))))

(defun expand-macro-form (form)
  (if (or (consp (first form))
          (get (first form) 'html-macro-wants-attributes))
    (multiple-value-bind (tag attributes body) (parse-cons-form form)
      (funcall (get tag 'html-macro) attributes body))
    (destructuring-bind (tag &body body) form
      (funcall (get tag 'html-macro) body))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Special Forms

(define-html-special-operator :print (processor form)
  (cond
    ((self-evaluating-p form)
     (warn "Redundant :print of self-evaluating form ~s" form)
     (process-sexp-html processor form))
    (t
     (embed-value processor form))))

(define-html-special-operator :format (processor &rest args)
  (if (every #'self-evaluating-p args)
    (process-sexp-html processor (apply #'format nil args))
    (embed-value processor `(format nil ,@args))))

(define-html-special-operator :progn (processor &rest body)
  (loop for exp in body do (process processor exp)))

(define-html-special-operator :noescape (processor &rest body)
  (let ((*escapes* nil))
    (loop for exp in body do (process processor exp))))

(define-html-special-operator :attribute (processor &rest body)
  (let ((*escapes* *attribute-escapes*))
    (loop for exp in body do (process processor exp))))

(define-html-special-operator :newline (processor)
  (newline processor))

#+END_SRC

** [[/Users/Can/Develop/Lisp/document/pcl/code/Chapter31/embed-foo-with-conditions-and-restarts.lisp][embed-foo-with-conditions-and-restarts]]
#+BEGIN_SRC lisp 
(in-package #:com.gigamonkeys.html)

;; Conditions

(define-condition embedded-lisp-in-interpreter (error)
  ((form :initarg :form :reader form)))

(define-condition value-in-interpreter (embedded-lisp-in-interpreter) ()
  (:report
   (lambda (c s) 
     (format s "Can't embed values when interpreting. Value: ~s" (form c)))))

(define-condition code-in-interpreter (embedded-lisp-in-interpreter) ()
  (:report
   (lambda (c s) 
     (format s "Can't embed code when interpreting. Code: ~s" (form c)))))

;; Implementation with restarts provided

(defmethod embed-value ((pp html-pretty-printer) value)
  (restart-case (error 'value-in-interpreter :form value)
    (evaluate ()
      :report (lambda (s) (format s "EVAL ~s in null lexical environment." value))
      (raw-string pp (escape (princ-to-string (eval value)) *escapes*) t))))

(defmethod embed-code ((pp html-pretty-printer) code)
  (restart-case (error 'code-in-interpreter :form code)
    (evaluate ()
      :report (lambda (s) (format s "EVAL ~s in null lexical environment." code))
      (eval code))))

;; Restart functions

(defun evaluate (&optional condition)
  (declare (ignore condition))
  (invoke-restart 'evaluate))

(defun eval-dynamic-variables (&optional condition)
  (when (and (symbolp (form condition)) (boundp (form condition)))
    (evaluate)))

(defun eval-code (&optional condition)
  (when (consp (form condition))
    (evaluate)))

;; Macro to automate binding of handlers to invoke evaluate restart.

(defmacro with-dynamic-evaluation ((&key values code) &body body)
  `(handler-bind (
       ,@(if values `((value-in-interpreter #'evaluate)))
       ,@(if code `((code-in-interpreter #'evaluate))))
     ,@body))
  


#+END_SRC

** [[/Users/Can/Develop/Lisp/document/pcl/code/Chapter31/css.lisp][css]]
#+BEGIN_SRC lisp 
(in-package #:com.gigamonkeys.html)

;;; CSS support

;; For stylesheets
(define-html-special-operator css-style (processor &rest body)
  (dolist (sexp body)
    (if (eql (first sexp) :import)
      (emit-css-import processor sexp)
      (process-css processor sexp))))

(defun emit-css-import (processor sexp)
  (let ((url (second sexp)))
    (freshline processor)
    (raw-string processor "@import ")
    (cond
      ((consp url)
       (raw-string processor "url(")
       (raw-string processor (second url))
       (raw-string processor ")"))
      (t (raw-string processor (format nil "\"~a\"" url))))
    (raw-string processor ";")))

(defun process-css (processor sexp)
  (destructuring-bind (selector &rest attributes) sexp
    (freshline processor)
    (emit-css-selector processor selector)
    (freshline processor)
    (raw-string processor "{")
    (indent processor)
    (freshline processor)
    (loop for (k v) on attributes by #'cddr do
         (process-css-key-or-value processor k)
         (raw-string processor ": ")
         (process-css-key-or-value processor v)
         (raw-string processor ";")
         (freshline processor))
    (unindent processor)
    (freshline processor)
    (raw-string processor "}")
    (freshline processor)))

(defun emit-css-selector (processor selector)
  (cond
    ((atom selector)
     (raw-string processor (string selector)))
    ((and (consp selector) (member (first selector) '(or and adjacent)))
     (loop with separator = (case (first selector) (or ", ") (and " ") (adjacent " + "))
        for (x . rest) on (rest selector)
        do (emit-css-selector processor x)
        when rest do (raw-string processor separator)))
    (t
     (multiple-value-bind (tag class pseudo-class id) (parse-selector selector)
       (when tag
         (embed-value processor (string tag)))
       (when class
         (embed-value processor (format nil ".~a" class)))
       (when pseudo-class
         (embed-value processor (format nil ":~a" pseudo-class)))
       (when id
         (embed-value processor (format nil "#~a" id)))))))

(defun parse-selector (selector)
  (if (member (first selector) '(:class :pseudo-class :id))
    (destructuring-bind (&key class pseudo-class id) selector
      (values nil class pseudo-class id))
    (destructuring-bind (tag &key class pseudo-class id) selector
      (values tag class pseudo-class id))))

(defun process-css-key-or-value (processor form)
  (if (keywordp form)
    (embed-value processor (string-downcase form))
    (process processor form)))


#+END_SRC

* Chapter32
** [[/Users/Can/Develop/Lisp/document/pcl/code/Chapter32/profiler.lisp][profiler]]
#+BEGIN_SRC lisp 
(in-package :cl-user)

(defparameter *timing-data* ())

(defmacro with-timing (label &body body)
  (with-gensyms (start)
    `(let ((,start (get-internal-run-time)))
      (unwind-protect (progn ,@body)
        (push (list ',label ,start (get-internal-run-time)) *timing-data*)))))

(defun clear-timing-data ()
  (setf *timing-data* ()))

(defun show-timing-data ()
  (loop for (label time count time-per %-of-total) in (compile-timing-data) do
       (format t "~3d% ~a: ~d ticks over ~d calls for ~d per.~%" 
               %-of-total label time count time-per)))

(defun compile-timing-data () 
  (loop with timing-table = (make-hash-table)
     with count-table = (make-hash-table)
     for (label start end) in *timing-data*
     for time = (- end start)
     summing time into total
     do
       (incf (gethash label timing-table 0) time)
       (incf (gethash label count-table 0))
     finally 
       (return
         (sort
          (loop for label being the hash-keys in timing-table collect
               (let  ((time (gethash label timing-table))
                      (count (gethash label count-table)))
                 (list label time count (round (/ time count)) (round (* 100 (/ time total))))))
          #'> :key #'fifth))))

         

#+END_SRC

* Cl-Postgres
** [[/Users/Can/Develop/Lisp/document/postmodern/cl-postgres/trivial-utf-8.lisp][trivial-utf-8]]
#+BEGIN_SRC lisp 
;;; Minimal utf-8 decoding and encoding library.
;;;
;;; See http://common-lisp.net/project/trivial-utf-8/

(defpackage :cl-postgres-trivial-utf-8
  (:use :common-lisp)
  (:export #:utf-8-byte-length
           #:string-to-utf-8-bytes
           #:write-utf-8-bytes
           #:utf-8-group-size
           #:utf-8-bytes-to-string
           #:read-utf-8-string
           #:utf-8-decoding-error))

(in-package :cl-postgres-trivial-utf-8)

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defparameter *optimize*
    '(optimize
      (speed 3)
      #-ecl(safety 0) #+ecl(safety 1)
      (space 0)
      (debug 1)
      (compilation-speed 0))))

(defun utf-8-byte-length (string)
  "Calculate the amount of bytes needed to encode a string."
  (declare (type string string)
           #'*optimize*)
  (let ((length (length string))
        (string (coerce string 'simple-string)))
    (loop :for char :across string
          :do (let ((code (char-code char)))
                (when (> code 127)
                  (incf length
                        (cond ((< code 2048) 1)
                              ((< code 65536) 2)
                              (t 3))))))
    length))

(defmacro as-utf-8-bytes (char writer)
  "Given a character, calls the writer function for every byte in the
encoded form of that character."
  (let ((char-code (gensym)))
    `(let ((,char-code (char-code ,char)))
       (declare (type fixnum ,char-code))
       (cond ((< ,char-code 128)
              (,writer ,char-code))
             ((< ,char-code 2048)
              (,writer (logior #b11000000 (ldb (byte 5 6) ,char-code)))
              (,writer (logior #b10000000 (ldb (byte 6 0) ,char-code))))
             ((< ,char-code 65536)
              (,writer (logior #b11100000 (ldb (byte 4 12) ,char-code)))
              (,writer (logior #b10000000 (ldb (byte 6 6) ,char-code)))
              (,writer (logior #b10000000 (ldb (byte 6 0) ,char-code))))
             (t
              (,writer (logior #b11110000 (ldb (byte 3 18) ,char-code)))
              (,writer (logior #b10000000 (ldb (byte 6 12) ,char-code)))
              (,writer (logior #b10000000 (ldb (byte 6 6) ,char-code)))
              (,writer (logior #b10000000 (ldb (byte 6 0) ,char-code))))))))

(defun string-to-utf-8-bytes (string &key null-terminate)
  "Convert a string into an array of unsigned bytes containing its
utf-8 representation."
  (declare (type string string)
           #.*optimize*)
  (let ((buffer (make-array (+ (the fixnum (utf-8-byte-length string))
                               (if null-terminate 1 0))
                            :element-type '(unsigned-byte 8)))
        (position 0)
        (string (coerce string 'simple-string)))
    (declare (type (array (unsigned-byte 8)) buffer)
             (type fixnum position))
    (macrolet ((add-byte (byte)
                 `(progn (setf (aref buffer position) ,byte)
                         (incf position))))
      (loop :for char :across string
            :do (as-utf-8-bytes char add-byte)))
    (when null-terminate
      (setf (elt buffer (1- (length buffer))) 0))
    buffer))

(defun write-utf-8-bytes (string output &key null-terminate)
  "Write a string to a byte-stream, encoding it as utf-8."
  (declare (type string string)
           (type stream output)
           #.*optimize*)
  (macrolet ((byte-out (byte)
               `(write-byte ,byte output)))
    (let ((string (coerce string 'simple-string)))
      (loop :for char :across string
            :do (as-utf-8-bytes char byte-out))))
  (when null-terminate
    (write-byte 0 output)))

(define-condition utf-8-decoding-error (simple-error)
  ((message :initarg :message)
   (byte :initarg :byte :initform nil))
  (:report (lambda (err stream)
             (format stream (slot-value err 'message)
                     (slot-value err 'byte)))))

(declaim (inline utf-8-group-size))
(defun utf-8-group-size (byte)
  "Determine the amount of bytes that are part of the character
starting with a given byte."
  (declare (type fixnum byte)
           #.*optimize*)
  (cond ((zerop (logand byte #b10000000)) 1)
        ((= (logand byte #b11100000) #b11000000) 2)
        ((= (logand byte #b11110000) #b11100000) 3)
        ((= (logand byte #b11111000) #b11110000) 4)
        (t (error 'utf-8-decoding-error :byte byte
                  :message "Invalid byte at start of character: 0x~X"))))

(defun utf-8-string-length (bytes &key (start 0) (end (length bytes)))
  "Calculate the length of the string encoded by the given bytes."
  (declare (type (simple-array (unsigned-byte 8) (*)) bytes)
           (type fixnum start end)
           #.*optimize*)
  (loop :with i :of-type fixnum = start
        :with string-length = 0
        :while (< i end)
        :do (progn
              (incf (the fixnum string-length) 1)
              (incf i (utf-8-group-size (elt bytes i))))
        :finally (return string-length)))

(defun get-utf-8-character (bytes group-size &optional (start 0))
  "Given an array of bytes and the amount of bytes to use,
extract the character starting at the given start position."
  (declare (type (simple-array (unsigned-byte 8) (*)) bytes)
           (type fixnum group-size start)
           #.*optimize*)
  (labels ((next-byte ()
             (prog1 (elt bytes start)
               (incf start)))
           (six-bits (byte)
             (unless (= (logand byte #b11000000) #b10000000)
               (error 'utf-8-decoding-error :byte byte
                      :message "Invalid byte 0x~X inside a character."))
             (ldb (byte 6 0) byte)))
    (case group-size
      (1 (next-byte))
      (2 (logior (ash (ldb (byte 5 0) (next-byte)) 6)
                 (six-bits (next-byte))))
      (3 (logior (ash (ldb (byte 4 0) (next-byte)) 12)
                 (ash (six-bits (next-byte)) 6)
                 (six-bits (next-byte))))
      (4 (logior (ash (ldb (byte 3 0) (next-byte)) 18)
                 (ash (six-bits (next-byte)) 12)
                 (ash (six-bits (next-byte)) 6)
                 (six-bits (next-byte)))))))

(defun utf-8-bytes-to-string (bytes-in &key (start 0) (end (length bytes-in)))
  "Convert a byte array containing utf-8 encoded characters into
the string it encodes." 
  (declare (type vector bytes-in)
           (type fixnum start end)
           #.*optimize*)
  (loop :with bytes = (coerce bytes-in '(simple-array (unsigned-byte 8) (*)))
        :with buffer = (make-string (utf-8-string-length bytes :start start :end end) :element-type 'character)
        :with array-position :of-type fixnum = start
        :with string-position :of-type fixnum = 0
        :while (< array-position end)
        :do (let* ((char (elt bytes array-position))
                   (current-group (utf-8-group-size char)))
              (when (> (+ current-group array-position) end)
                (error 'utf-8-decoding-error
                       :message "Unfinished character at end of byte array."))
              (setf (char buffer string-position)
                 (code-char (get-utf-8-character bytes current-group
                                                 array-position)))
              (incf string-position 1)
              (incf array-position current-group))
        :finally (return buffer)))

(defun read-utf-8-string (input &key null-terminated stop-at-eof
                          (char-length -1) (byte-length -1))
  "Read utf-8 encoded data from a byte stream and construct a
string with the characters found. When null-terminated is given
it will stop reading at a null character, stop-at-eof tells it to
stop at the end of file without raising an error, and the
char-length and byte-length parameters can be used to specify the
max amount of characters or bytes to read."
  (declare (type stream input)
           (type fixnum byte-length char-length)
           #.*optimize*)
  (let ((buffer (make-array 4 :element-type '(unsigned-byte 8)))
        (bytes-read 0)
        (string (make-array 64 :element-type 'character
                            :adjustable t :fill-pointer 0)))
    (declare (type fixnum bytes-read))
    (loop
       (when (or (and (/= -1 byte-length) (>= bytes-read byte-length))
		 (and (/= -1 char-length) (= char-length (length string))))
	 (return))
       (let ((next-char (read-byte input (not stop-at-eof) :eof)))
	 (when (or (eq next-char :eof)
		   (and null-terminated (eq next-char 0)))
	   (return))
	 (let ((current-group (utf-8-group-size next-char)))
	   (incf bytes-read current-group)
	   (cond ((= current-group 1)
		  (vector-push-extend (code-char next-char) string))
		 (t
		  (setf (elt buffer 0) next-char)
		  (loop :for i :from 1 :below current-group
		     :for next-char = (read-byte input nil :eof)
		     :do (when (eq next-char :eof)
			   (error 'utf-8-decoding-error
				  :message "Unfinished character at end of input."))
		     :do (setf (elt buffer i) next-char))
		  (vector-push-extend (code-char (get-utf-8-character
						  buffer current-group))
				      string))))))
    string))

#+END_SRC

** [[/Users/Can/Develop/Lisp/document/postmodern/cl-postgres/strings-utf-8.lisp][strings-utf-8]]
#+BEGIN_SRC lisp 
(in-package :cl-postgres)

(defparameter *client-encoding* "UNICODE")

(declaim (inline enc-byte-length))
(defun enc-byte-length (sequence)
  (cl-postgres-trivial-utf-8:utf-8-byte-length sequence))

(declaim (inline enc-write-string))
(defun enc-write-string (string output &key null-terminate)
  (cl-postgres-trivial-utf-8:write-utf-8-bytes string output
                                               :null-terminate null-terminate))

(declaim (inline enc-read-string))
(declaim (ftype (function (t &key (:null-terminated t)
                                  (:byte-length fixnum))
                          string)
                enc-read-string))
(defun enc-read-string (input &key null-terminated (byte-length -1))
  (cl-postgres-trivial-utf-8:read-utf-8-string
   input :null-terminated null-terminated :byte-length byte-length))

(declaim (inline enc-string-bytes))
(defun enc-string-bytes (string &key null-terminate)
  (cl-postgres-trivial-utf-8:string-to-utf-8-bytes
   string :null-terminate null-terminate))

#+END_SRC

** [[/Users/Can/Develop/Lisp/document/postmodern/cl-postgres/strings-ascii.lisp][strings-ascii]]
#+BEGIN_SRC lisp 
(in-package :cl-postgres)

(defparameter *client-encoding* "SQL_ASCII")

(declaim (inline enc-byte-length))
(defun enc-byte-length (sequence)
  (length sequence))

(declaim (ftype (function (t &key (:null-terminated t)
                                  (:byte-length unsigned-byte))
                          string)
                enc-read-string))
(defun enc-read-string (stream &key null-terminated byte-length)
  "Read an ascii-string from a byte stream, until either a null byte
is reached or the given amount of bytes have been read."
  (declare (type stream stream)
           (type (or null fixnum) byte-length)
           #.*optimize*)
  (let ((bytes-read 0)
        (string (make-array 64 :element-type 'character
                               :adjustable t :fill-pointer 0)))
    (loop
       (when (and byte-length (>= bytes-read byte-length))
         (return))
       (let ((next-char (read-byte stream)))
         (incf bytes-read)
         (when (and null-terminated (eq next-char 0))
           (return))
         (vector-push-extend (code-char next-char) string)))
    string))

(declaim (ftype (function (string) (simple-array (unsigned-byte 8) (*)))
                enc-string-bytes))
(defun enc-string-bytes (string)
  "Convert an ascii string to an array of octets."
  (map '(simple-array (unsigned-byte 8) (*)) 'char-code string))

(defun enc-write-string (string stream)
  "Write an ascii string to a stream."
  (declare (type stream stream)
           (type string string)
           #.*optimize*)
  (loop :for char :of-type character :across string
     :do (write-byte (char-code char) stream)))

#+END_SRC

** [[/Users/Can/Develop/Lisp/document/postmodern/cl-postgres/sql-string.lisp][sql-string]]
#+BEGIN_SRC lisp 
(in-package :cl-postgres)

(defun escape-bytes (bytes)
  "Escape an array of octets in PostgreSQL's horribly inefficient
textual format for binary data."
  (let ((*print-pretty* nil))
    (with-output-to-string (out)
      (loop :for byte :of-type fixnum :across bytes
            :do (if (or (< byte 32) (> byte 126) (= byte 39) (= byte 92))
                    (progn
                      (princ #\\ out)
                      (princ (digit-char (ldb (byte 3 6) byte) 8) out)
                      (princ (digit-char (ldb (byte 3 3) byte) 8) out)
                      (princ (digit-char (ldb (byte 3 0) byte) 8) out))
                    (princ (code-char byte) out))))))

(defparameter *silently-truncate-ratios* t)

(defun write-ratio-as-floating-point (number stream digit-length-limit)
  "Given a ratio, a stream and a digital-length-limit, if *silently-truncate-ratios* is true,
will return a potentially truncated ratio. If false and the digital-length-limit is reached,
it will throw an error noting the loss of precision and offering to continue or reset
*silently-truncate-ratios* to true. Code contributed by Attila Lendvai."
  (declare #.*optimize* (type fixnum digit-length-limit))
  (check-type number ratio)
  (let ((silently-truncate? *silently-truncate-ratios*))
    (flet ((fail ()
                 (unless silently-truncate?
                   (restart-case
                    (error 'database-error :message
                           (format nil "Can not write the ratio ~A as a floating point number with only ~A available digits. You may want to (setf ~S t) if you don't mind the loss of precision."
                                   number digit-length-limit '*silently-truncate-ratios*))
                    (continue ()
                              :report (lambda (stream)
                                        (write-string "Ignore this precision loss and continue" stream))
                              (setf silently-truncate? t))
                    (disable-assertion ()
                                       :report (lambda (stream)
                                                 (write-string "Set ~S to true (the precision loss of ratios will be silently ignored in this Lisp VM)." stream))
                                       (setf silently-truncate? t)
                                       (setf *silently-truncate-ratios* t))))))
      (multiple-value-bind (quotient remainder)
          (truncate (if (< number 0)
                        (progn
                          (write-char #\- stream)
                          (- number))
                      number))
        (let* ((quotient-part (princ-to-string quotient))
               (remaining-digit-length (- digit-length-limit (length quotient-part))))
          (write-string quotient-part stream)
          (when (<= remaining-digit-length 0)
            (fail))
          (unless (zerop remainder)
            (write-char #\. stream))
          (loop
           :for decimal-digits :upfrom 1
           :until (zerop remainder)
           :do (progn
                 (when (> decimal-digits remaining-digit-length)
                   (fail)
                   (return))
                 (multiple-value-bind (quotient rem) (floor (* remainder 10))
                   (princ quotient stream)
                   (setf remainder rem)))))))))

(defparameter *silently-truncate-rationals* t)

(defun write-rational-as-floating-point (number stream digit-length-limit)
  "DEPRECATED. The same as write-ratio-as-floating point. Note the difference between rational and ratio.
Kept for backwards compatibility.
Given a ratio, a stream and a digital-length-limit, if *silently-truncate-rationals* is true,
will return a potentially truncated ratio. If false and the digital-length-limit is reached,
it will throw an error noting the loss of precision and offering to continue or reset
*silently-truncate-rationals* to true. Code contributed by Attila Lendvai."
  (declare #.*optimize* (type fixnum digit-length-limit))
  (check-type number ratio)
  (let ((silently-truncate? *silently-truncate-rationals*))
    (flet ((fail ()
                 (unless silently-truncate?
                   (restart-case
                    (error 'database-error :message
                           (format nil "Can not write the rational ~A as a floating point number with only ~A available digits. You may want to (setf ~S t) if you don't mind the loss of precision."
                                   number digit-length-limit '*silently-truncate-rationals*))
                    (continue ()
                              :report (lambda (stream)
                                        (write-string "Ignore this precision loss and continue" stream))
                              (setf silently-truncate? t))
                    (disable-assertion ()
                                       :report (lambda (stream)
                                                 (write-string "Set ~S to true (the precision loss of ratios will be silently ignored in this Lisp VM)." stream))
                                       (setf silently-truncate? t)
                                       (setf *silently-truncate-rationals* t))))))
      (multiple-value-bind (quotient remainder)
          (truncate (if (< number 0)
                        (progn
                          (write-char #\- stream)
                          (- number))
                      number))
        (let* ((quotient-part (princ-to-string quotient))
               (remaining-digit-length (- digit-length-limit (length quotient-part))))
          (write-string quotient-part stream)
          (when (<= remaining-digit-length 0)
            (fail))
          (unless (zerop remainder)
            (write-char #\. stream))
          (loop
           :for decimal-digits :upfrom 1
           :until (zerop remainder)
           :do (progn
                 (when (> decimal-digits remaining-digit-length)
                   (fail)
                   (return))
                 (multiple-value-bind (quotient rem) (floor (* remainder 10))
                   (princ quotient stream)
                   (setf remainder rem)))))))))

(defun write-quoted (string out)
  (write-char #\" out)
  (loop :for ch :across string :do
     (when (member ch '(#\" #\\))
       (write-char #\\ out))
     (write-char ch out))
  (write-char #\" out))

(defgeneric to-sql-string (arg)
  (:documentation "Turn a lisp value into a string containing its SQL
representation. Returns an optional second value that indicates
whether the string should be escaped before being put into a query.
Generally any string is going to be designated to be escaped")
  (:method ((arg string))
    (values arg t))
  (:method ((arg vector))
    (if (typep arg '(vector (unsigned-byte 8)))
        (values (escape-bytes arg) t)
        (values
         (with-output-to-string (out)
           (write-char #\{  out)
           (loop :for sep := "" :then #\, :for x :across arg :do
              (princ sep out)
              (multiple-value-bind (string escape) (to-sql-string x)
              (if escape (write-quoted string out) (write-string string out))))
           (write-char #\} out))
         t)))
  (:method ((arg array))
    (values
     (with-output-to-string (out)
       (labels ((recur (dims off)
                  (write-char #\{ out)
                  (if (cdr dims)
                      (let ((factor (reduce #'* (cdr dims))))
                        (loop :for i :below (car dims) :for sep := "" :then #\, :do
                           (princ sep out)
                           (recur (cdr dims) (+ off (* factor i)))))
                      (loop :for sep := "" :then #\, :for i :from off :below (+ off (car dims)) :do
                         (princ sep out)
                         (multiple-value-bind (string escape) (to-sql-string (row-major-aref arg i))
                           (if escape (write-quoted string out) (write-string string out)))))
                  (write-char #\} out)))
         (recur (array-dimensions arg) 0)))
     t))
  (:method ((arg integer))
    (princ-to-string arg))
  (:method ((arg float))
    (format nil "~f" arg))
  #-clisp (:method ((arg double-float)) ;; CLISP doesn't allow methods on double-float
            (format nil "~,,,,,,'EE" arg))
  (:method ((arg ratio))
    ;; Possible optimization: we could probably build up the same binary structure postgres
    ;; sends us instead of sending it as a string. See the "numeric" interpreter for more details...
    (with-output-to-string (result)
      ;; PostgreSQL happily handles 200+ decimal digits, but the SQL standard only requires
      ;; 38 digits from the NUMERIC type, and Oracle also doesn't handle more. For practical
      ;; reasons we also draw the line there. If someone needs full rational numbers then
      ;; 200 wouldn't help them much more than 38...
      (write-rational-as-floating-point arg result 38)))
  (:method ((arg (eql t)))
    "true")
  (:method ((arg (eql nil)))
    "false")
  (:method ((arg (eql :null)))
    "NULL")
  (:method ((arg t))
    (error "Value ~S can not be converted to an SQL literal." arg)))

(defgeneric serialize-for-postgres (arg)
  (:documentation "Conversion function used to turn a lisp value into a value that PostgreSQL understands when sent through its socket connection. May return a string or a (vector (unsigned-byte 8)).")
  (:method (arg)
    (to-sql-string arg)))

#+END_SRC

** [[/Users/Can/Develop/Lisp/document/postmodern/cl-postgres/public.lisp][public]]
#+BEGIN_SRC lisp 
(in-package :cl-postgres)

(defclass database-connection ()
  ((host :initarg :host :reader connection-host)
   (port :initarg :port :reader connection-port)
   (database :initarg :db :reader connection-db)
   (user :initarg :user :reader connection-user)
   (password :initarg :password :reader connection-password)
   (use-ssl :initarg :ssl :reader connection-use-ssl)
   (service :initarg :service :accessor connection-service)
   (socket :initarg :socket :accessor connection-socket)
   (meta :initform nil)
   (available :initform t :accessor connection-available)
   (parameters :accessor connection-parameters)
   (timestamp-format :accessor connection-timestamp-format))
  (:documentation "Representation of a database connection. Contains
login information in order to be able to automatically re-establish a
connection when it is somehow closed."))

(defun connection-meta (connection)
  "Retrieves the meta field of a connection, the primary purpose of
which is to store information about the prepared statements that
exists for it."
  (or (slot-value connection 'meta)
      (let ((meta-data (make-hash-table :test 'equal)))
        (setf (slot-value connection 'meta) meta-data)
        meta-data)))

(defun connection-pid (connection)
  "Retrieves a list consisting of the pid and the secret-key from the connection, not from the database itself.
These are needed for cancelling connections and error processing with respect to prepared statements."
  (list (gethash "pid" (slot-value connection 'parameters))
        (gethash "secret-key" (slot-value connection 'parameters))))

(defun database-open-p (connection)
  "Returns a boolean indicating whether the given connection is
currently connected."
  (and (connection-socket connection)
       (open-stream-p (connection-socket connection))))

(defun open-database (database user password host &optional (port 5432) (use-ssl :no) (service "postgres"))
  "Create and connect a database object. use-ssl may be :no, :try, :yes, or
:full (NOTE: :yes only verifies that the server cert is issued by a trusted CA,
but does not verify the server hostname; use :full to also verify the hostname)."
  (check-type database string)
  (check-type user string)
  (check-type password (or null string))
  (check-type host (or string (eql :unix)) "a string or :unix")
  (check-type port (integer 1 65535) "an integer from 1 to 65535")
  (check-type use-ssl (member :no :try :yes :full) ":no, :try, :yes or :full")
  (let ((conn (make-instance 'database-connection :host host :port port :user user
                             :password password :socket nil :db database :ssl use-ssl
                             :service service)))
    (initiate-connection conn)
    conn))

#+(and (or cl-postgres.features:sbcl-available ccl allegro) unix)
(progn
  (defparameter *unix-socket-dir*
    #-(or freebsd darwin) "/var/run/postgresql/"
    #+(or darwin freebsd) "/tmp/"
    "Directory where the Unix domain socket for PostgreSQL be found.")

  (defun unix-socket-path (base-dir port)
    (unless (char= #\/ (aref base-dir (1- (length base-dir))))
      (setf base-dir (concatenate 'string base-dir "/")))
    (format nil "~a.s.PGSQL.~a" base-dir port))

  #+cl-postgres.features:sbcl-available
  (defun unix-socket-connect (path)
    (let ((sock (make-instance 'sb-bsd-sockets:local-socket :type :stream)))
      (sb-bsd-sockets:socket-connect sock path)
      (sb-bsd-sockets:socket-make-stream
       sock :input t :output t :element-type '(unsigned-byte 8))))

  #+ccl
  (defun unix-socket-connect (path)
    (ccl:make-socket :type :stream
                     :address-family :file
                     :format :binary
                     :remote-filename path))

  #+allegro
  (defun unix-socket-connect (path)
    (socket:make-socket :type :stream
                        :address-family :file
                        :format :binary
                        :remote-filename path)))

#+cl-postgres.features:sbcl-available
(defun get-host-address (host)
  "Returns valid IPv4 or IPv6 address for the host."
  ;; get all IPv4 and IPv6 addresses as a list
  (let* ((host-ents (multiple-value-list (sb-bsd-sockets:get-host-by-name host)))
         ;; remove protocols for which we don't have an address
         (addresses (remove-if-not #'sb-bsd-sockets:host-ent-address host-ents)))
    ;; Return the first one or nil,
    ;; but actually, it shouln't return nil, because
    ;; get-host-by-name should signal NAME-SERVICE-ERROR condition
    ;; if there isn't any address for the host.
    (first addresses)))


#+cl-postgres.features:sbcl-available
(defun inet-socket-connect (host port)
  (let* ((host-ent (get-host-address host))
         (sock (make-instance
                #+cl-postgres.features:sbcl-ipv6-available
                (ecase (sb-bsd-sockets:host-ent-address-type host-ent)
                  (2  'sb-bsd-sockets:inet-socket)
                  (10 'sb-bsd-sockets:inet6-socket))

                #-cl-postgres.features:sbcl-ipv6-available
                'sb-bsd-sockets:inet-socket

                :type :stream :protocol :tcp))
         (address (sb-bsd-sockets:host-ent-address host-ent)))
    (sb-bsd-sockets:socket-connect sock address port)
    (sb-bsd-sockets:socket-make-stream
     sock :input t :output t :buffering :full :element-type '(unsigned-byte 8))))

#+ccl
(defun inet-socket-connect (host port)
  (ccl:make-socket :format :binary
                   :remote-host host
                   :remote-port port))

#+allegro
(defun inet-socket-connect (host port)
  (socket:make-socket :remote-host host
                      :remote-port port
                      :format :binary
                      :type :stream))

(defun initiate-connection (conn)
  "Check whether a connection object is connected, try to connect it
if it isn't."
  (flet ((add-restart (err)
           (restart-case (error (wrap-socket-error err))
             (:reconnect () :report "Try again." (initiate-connection conn))))
         (assert-unix ()
           #+unix t
           #-unix (error "Unix sockets only available on Unix (really)")))
    (handler-case
        (let ((socket #-(or allegro cl-postgres.features:sbcl-available ccl)
                      (usocket:socket-stream
                       (usocket:socket-connect (connection-host conn)
                                               (connection-port conn)
                                               :element-type '(unsigned-byte 8)))
                      #+(or allegro cl-postgres.features:sbcl-available ccl)
                      (cond
                        ((equal (connection-host conn) :unix)
                         (assert-unix)
                         (unix-socket-connect (unix-socket-path *unix-socket-dir* (connection-port conn))))
                        ((and (stringp (connection-host conn))
                              (char= #\/ (aref (connection-host conn) 0)))
                         (assert-unix)
                         (unix-socket-connect (unix-socket-path (connection-host conn) (connection-port conn))))
                        ((and (pathnamep (connection-host conn))
                              (eql :absolute (pathname-directory (connection-host conn))))
                         (assert-unix)
                         (unix-socket-connect (unix-socket-path (namestring (connection-host conn))
                                                                (connection-port conn))))
                        (t
                         (inet-socket-connect (connection-host conn)
                                              (connection-port conn)))))
              (finished nil)
              (*connection-params* (make-hash-table :test 'equal)))
          (setf (connection-parameters conn) *connection-params*)
          (unwind-protect
               (setf socket (authenticate socket conn)
                     (connection-timestamp-format conn)
                     (if (string= (gethash "integer_datetimes" (connection-parameters conn)) "on")
                         :integer :float)
                     (connection-socket conn) socket
                     finished t)
            (unless finished
              (ensure-socket-is-closed socket)))
          (maphash (lambda (id query)
                     (prepare-query conn id query))
                   (connection-meta conn)))
      #-(or allegro cl-postgres.features:sbcl-available ccl)(usocket:socket-error (e) (add-restart e))
      #+ccl (ccl:socket-error (e) (add-restart e))
      #+allegro(excl:socket-error (e) (add-restart e))
      #+cl-postgres.features:sbcl-available(sb-bsd-sockets:socket-error (e) (add-restart e))
      #+cl-postgres.features:sbcl-available(sb-bsd-sockets:name-service-error (e) (add-restart e))
      (stream-error (e) (add-restart e))))
    (values))

(defvar *retry-connect-times* 5
  "How many times to we try to connect again. Borrowed from pgloader")

(defvar *retry-connect-delay* 0.5
  "How many seconds to wait before trying to connect again. Borrowed from pgloader")

(defun reopen-database (conn)
  "Reconnect a disconnected database connection."
  (loop :while (not (database-open-p conn))
     :repeat *retry-connect-times*
     :do
       (initiate-connection conn)))

(defun ensure-connection (conn)
  "Used to make sure a connection object is connected before doing
anything with it."
  (unless conn
    (error "No database connection selected."))
  (unless (database-open-p conn)
    (restart-case (error 'database-connection-lost :message "Connection to database server lost.")
      (:reconnect () :report "Try to reconnect."
                  (loop :while (not (database-open-p conn))
                     :repeat *retry-connect-times*
                     :do
                       (initiate-connection conn))))))

(defun close-database (connection)
  "Gracefully disconnect a database connection."
  (when (database-open-p connection)
    (terminate-connection (connection-socket connection)))
  (values))

(defmacro using-connection (connection &body body)
  "This is used to prevent a row-reader from recursively calling some
query function. Because the connection is still returning results from
the previous query when a row-reading is being executed, starting
another query will not work as expected \(or at all, in general). This
might also raise an error when you are using a single database
connection from multiple threads, but you should not do that at all.
Also binds *timestamp-format* and *connection-params*, which might be
needed by the code interpreting the query results."
  (let ((connection-name (gensym)))
    `(let* ((,connection-name ,connection)
            (*timestamp-format* (connection-timestamp-format ,connection-name))
            (*connection-params* (connection-parameters ,connection-name)))
      (when (not (connection-available ,connection-name))
        (error 'database-error :message "This connection is still processing another query."))
      (setf (connection-available ,connection-name) nil)
      (unwind-protect (progn ,@body)
        (setf (connection-available ,connection-name) t)))))

(defmacro with-reconnect-restart (connection &body body)
  "When, inside the body, an error occurs that breaks the connection
socket, a condition of type database-connection-error is raised,
offering a :reconnect restart."
  (let ((connection-name (gensym))
        (body-name (gensym))
        (retry-name (gensym)))
  `(let ((,connection-name ,connection))
    (ensure-connection ,connection-name)
    (labels ((,body-name ()
               (handler-case (progn ,@body)
                 (stream-error (e)
                   (cond ((eq (connection-socket ,connection-name) (stream-error-stream e))
                          (ensure-socket-is-closed (connection-socket ,connection-name) :abort t)
                          (,retry-name (wrap-socket-error e)))
                         (t (error e))))
                 (cl-postgres-error:server-shutdown (e)
                   (ensure-socket-is-closed (connection-socket ,connection-name) :abort t)
                   (,retry-name e))))
             (,retry-name (err)
               (restart-case (error err)
                 (:reconnect () :report "Try to reconnect"
                             (reopen-database ,connection-name)
                             (,body-name)))))
      (,body-name)))))

(defun wait-for-notification (connection)
  "Perform a blocking wait for asynchronous notification. Return the
channel string, the payload and notifying pid as multiple values."
  (block nil
    (with-reconnect-restart connection
      (handler-bind ((postgresql-notification
                      (lambda (c)
                        (return (values (postgresql-notification-channel c)
                                        (postgresql-notification-payload c)
                                        (postgresql-notification-pid c))))))
        (message-case (connection-socket connection))))))

(defun exec-query (connection query &optional (row-reader 'ignore-row-reader))
  "Execute a query string and apply the given row-reader to the
result."
  (check-type query string)
  (with-reconnect-restart connection
    (using-connection connection
      (send-query (connection-socket connection) query row-reader))))

(defun prepare-query (connection name query)
  "Prepare a query string and store it under the given name."
  (check-type query string)
  (check-type name string)
  (with-reconnect-restart connection
    (using-connection connection
      (send-parse (connection-socket connection) name query)
      (values))))

(defun unprepare-query (connection name)
  "Close the prepared query given by name by closing the session connection.
Does not remove the query from the meta slot in connection"
  (check-type name string)
  (with-reconnect-restart connection
    (using-connection connection
      (send-close (connection-socket connection) name)
      (values))))

(defun exec-prepared (connection name parameters &optional (row-reader 'ignore-row-reader))
  "Execute a previously prepared query with the given parameters, apply a
row-reader to the result."
  (check-type name string)
  (check-type parameters list)
  (with-reconnect-restart connection
    (using-connection connection
      (send-execute (connection-socket connection)
                    name parameters row-reader))))

;; A row-reader that returns a list of (field-name . field-value)
;; alist for the returned rows.
(def-row-reader alist-row-reader (fields)
  (loop :while (next-row)
        :collect (loop :for field :across fields
                       :collect (cons (field-name field)
                                      (next-field field)))))

;; Row-reader that returns a list of lists.
(def-row-reader list-row-reader (fields)
  (loop :while (next-row)
        :collect (loop :for field :across fields
                       :collect (next-field field))))

;; Row-reader that returns a vector of vectors.
(def-row-reader vector-row-reader (fields)
  (let ((rows (make-array 1 :adjustable t :fill-pointer 0)))
    (loop :for row = (make-array (length fields))
          :while (next-row)
          :do (progn
                (loop :for field :across fields
                      :for idx :upfrom 0
                      :do (setf (aref row idx) (next-field field)))
                (vector-push-extend row rows)))
    rows))

;; Row-reader that discards the query results.
(def-row-reader ignore-row-reader (fields)
  (loop :while (next-row)
        :do (loop :for field :across fields
                  :do (next-field field)))
  (values))

#+END_SRC

** [[/Users/Can/Develop/Lisp/document/postmodern/cl-postgres/protocol.lisp][protocol]]
#+BEGIN_SRC lisp 
(in-package :cl-postgres)

;; For more information about the PostgreSQL scocket protocol, see
;; http://www.postgresql.org/docs/current/interactive/protocol.html

(define-condition protocol-error (error)
  ((message :initarg :message))
  (:report (lambda (err stream)
             (format stream "PostgreSQL protocol error: ~A"
                     (slot-value err 'message))))
  (:documentation "This is raised if something really unexpected
happens in the communcation with the server. Should only happen in
case of a bug or a connection to something that is not a \(supported)
PostgreSQL server at all."))

(defmacro message-case (socket &body clauses)
  "Helper macro for reading messages from the server. A list of cases
\(characters that identify the message) can be given, each with a body
that handles the message, or the keyword :skip to skip the message.
Cases for error and warning messages are always added.

The body may contain an initial parameter of the form :LENGTH-SYM SYMBOL
where SYMBOL is a symbol to which the remaining length of the packet is
bound. This value indicates the number of bytes that have to be read
from the socket."
  (let ((socket-name (gensym))
        (size-name (gensym))
        (char-name (gensym))
        (iter-name (gensym))
        (t-found nil)
        (size-sym (and (eq (car clauses) :length-sym) (progn (pop clauses) (pop clauses)))))
    (flet ((expand-characters (chars)
             (cond ((eq chars t) (setf t-found t) t)
                   ((consp chars) (mapcar #'char-code chars))
                   (t (char-code chars)))))
      `(let* ((,socket-name ,socket))
        (declare (type stream ,socket-name))
        (labels ((,iter-name ()
                   (let ((,char-name (read-uint1 ,socket-name))
                         (,size-name (read-uint4 ,socket-name)))
                     (declare (type (unsigned-byte 8) ,char-name)
                              (type (unsigned-byte 32) ,size-name)
                              (ignorable ,size-name))
                     (case ,char-name
                       (#.(char-code #\A)
                          (get-notification ,socket-name)
                          (,iter-name))
                       (#.(char-code #\E) (get-error ,socket-name))
                       (#.(char-code #\S) ;; ParameterStatus: read and continue
                          (update-parameter ,socket-name)
                          (,iter-name))
                       (#.(char-code #\K) ;; Backendkey : read and continue
                          (update-backend-key-data ,socket-name)
                          (,iter-name))
                       (#.(char-code #\N) ;; A warning
                          (get-warning ,socket-name)
                          (,iter-name))
                       ,@(mapcar (lambda (clause)
                                   `(,(expand-characters (first clause))
                                      ,(if (eq (second clause) :skip)
                                           `(skip-bytes ,socket-name (- ,size-name 4))
                                           (if size-sym
                                               `(let ((,size-sym (- ,size-name 4)))
                                                  ,@(cdr clause))
                                               `(progn ,@(cdr clause))))))
                                 clauses)
                       ,@(unless t-found
                                 `((t (ensure-socket-is-closed ,socket-name)
                                      (error 'protocol-error
                                             :message (format nil "Unexpected message received: ~A"
                                                              (code-char ,char-name))))))))))
          (,iter-name))))))

(defparameter *connection-params* nil
  "Bound to the current connection's parameter table when executing
a query.")

(defun update-parameter (socket)
  (let ((name (read-str socket))
        (value (read-str socket)))
    (setf (gethash name *connection-params*) value)))

(defun update-backend-key-data (socket)
  (let ((pid (read-uint4 socket))
        (secret-key (read-uint4 socket)))
        (setf (gethash "pid" *connection-params*) pid)
        (setf (gethash "secret-key" *connection-params*) secret-key)))

(defun read-byte-delimited (socket)
  "Read the fields of a null-terminated list of byte + string values
and put them in an alist."
  (loop :for type = (read-uint1 socket)
        :until (zerop type)
        :collect (cons (code-char type) (read-simple-str socket))))

(define-condition postgresql-notification (simple-warning)
  ((pid :initarg :pid :accessor postgresql-notification-pid)
   (channel :initarg :channel :accessor postgresql-notification-channel)
   (payload :initarg :payload :accessor postgresql-notification-payload)))

(defun get-notification (socket)
  "Read an asynchronous notification message from the socket and
signal a condition for it."
  (let ((pid (read-int4 socket))
        (channel (read-str socket))
        (payload (read-str socket)))
    (warn 'postgresql-notification
          :pid pid
          :channel channel
          :payload payload
          :format-control "Asynchronous notification ~S~@[ (payload: ~S)~] received from ~
                           server process with PID ~D."
          :format-arguments (list channel payload pid))))

(defun get-error (socket)
  "Read an error message from the socket and raise the corresponding
database-error condition."
  (let ((data (read-byte-delimited socket)))
    (flet ((get-field (char)
             (cdr (assoc char data))))
      (let ((code (get-field #\C)))
        ;; These are the errors "ADMIN SHUTDOWN" and "CRASH SHUTDOWN",
        ;; in which case the server will close the connection right
        ;; away.
        (when (or (string= code "57P01") (string= code "57P02"))
          (ensure-socket-is-closed socket))
        (error (cl-postgres-error::get-error-type code)
               :code code
               :message (get-field #\M)
               :detail (get-field #\D)
               :hint (get-field #\H)
               :context (get-field #\W)
               :position (let ((position (get-field #\p)))
                           (when position (parse-integer position))))))))

(define-condition postgresql-warning (simple-warning)
  ())

(defun get-warning (socket)
  "Read a warning from the socket and emit it."
  (let ((data (read-byte-delimited socket)))
    (flet ((get-field (char)
             (cdr (assoc char data))))
      (warn 'postgresql-warning
            :format-control "PostgreSQL warning: ~A~@[~%~A~]"
            :format-arguments (list (get-field #\M) (or (get-field #\D) (get-field #\H)))))))

(defparameter *ssl-certificate-file* nil
  "When set to a filename, this file will be used as client
  certificate for SSL connections.")
(defparameter *ssl-key-file* nil
  "When set to a filename, this file will be used as client key for
  SSL connections.")

;; The let is used to remember that we have found the
;; cl+ssl:make-ssl-client-stream function before.
(let ((make-ssl-stream nil))
  (defun initiate-ssl (socket required hostname)
    "Initiate SSL handshake with the PostgreSQL server, and wrap the socket in
an SSL stream. When require is true, an error will be raised when the server
does not support SSL. When hostname is supplied, the server's certificate will
be matched against it."
    (unless make-ssl-stream
      (unless (find-package :cl+ssl)
        (error 'database-error :message "CL+SSL is not loaded. Load it to enable SSL."))
      (setf make-ssl-stream (intern (string '#:make-ssl-client-stream) :cl+ssl)))
    (ssl-request-message socket)
    (force-output socket)
    (ecase (read-byte socket)
      (#.(char-code #\S)
       (setf socket (funcall make-ssl-stream socket :key *ssl-key-file*
                                                    :certificate *ssl-certificate-file*
                                                    :hostname hostname)))
      (#.(char-code #\N)
       (when required
         (error 'database-error :message "Server does not support SSL encryption."))))))

(defun authenticate (socket conn)
  "Try to initiate a connection. Caller should close the socket if
this raises a condition."

  (let ((gss-context nil)
        (gss-init-function nil)
        (user (connection-user conn))
        (password (connection-password conn))
        (database (connection-db conn))
        (hostname (connection-host conn))
        (use-ssl (connection-use-ssl conn)))

    (unless (eq use-ssl :no)
      (setf socket (initiate-ssl socket (member use-ssl '(:yes :full))
                                 (if (eq use-ssl :full) hostname))))
    (startup-message socket user database)
    (force-output socket)

    (labels ((init-gss-msg (in-buffer)
               (when (null gss-init-function)
                 (when (null (find-package "CL-GSS"))
                   (error 'database-error :message  "To use GSS authentication, make sure the CL-GSS package is loaded."))
                 (setq gss-init-function (find-symbol "INIT-SEC" "CL-GSS"))
                 (unless gss-init-function
                   (error 'database-error :message "INIT-SEC not found in CL-GSS package")))
               (multiple-value-bind (continue-needed context buffer flags)
                   (funcall gss-init-function
                            (format nil "~a@~a" (connection-service conn) (connection-host conn))
                            :flags '(:mutual)
                            :context gss-context
                            :input-token in-buffer)
                 (declare (ignore flags))
                 (setq gss-context context)
                 (when buffer
                   (gss-auth-buffer-message socket buffer))
                 (force-output socket)
                 continue-needed)))

      (loop
         (message-case socket :length-sym size
           ;; Authentication message
           (#\R (let ((type (read-uint4 socket)))
                  (ecase type
                    (0 (return))
                    (2 (error 'database-error :message "Unsupported Kerberos authentication requested."))
                    (3 (unless password (error "Server requested plain-password authentication, but no password was given."))
                       (plain-password-message socket password)
                       (force-output socket))
                    (4 (error 'database-error :message "Unsupported crypt authentication requested."))
                    (5 (unless password (error "Server requested md5-password authentication, but no password was given."))
                       (md5-password-message socket password user (read-bytes socket 4))
                       (force-output socket))
                    (6 (error 'database-error :message "Unsupported SCM authentication requested."))
                    (7 (when gss-context
                         (error 'database-error :message "Got GSS init message when a context was already established"))
                       (init-gss-msg nil))
                    (8 (unless gss-context
                         (error 'database-error :message "Got GSS continuation message without a context"))
                       (init-gss-msg (read-bytes socket (- size 4)))))))))))
  (loop
   (message-case socket
     ;; ReadyForQuery
     (#\Z (read-uint1 socket)
          (return))))
  socket)

(defclass field-description ()
  ((name :initarg :name :accessor field-name)
   (type-id :initarg :type-id :accessor field-type)
   (interpreter :initarg :interpreter :accessor field-interpreter)
   (receive-binary-p :initarg :receive-binary-p :reader field-binary-p))
  (:documentation "Description of a field in a query result."))

(defun read-field-descriptions (socket)
  "Read the field descriptions for a query result and put them into an
array of field-description objects."
  (declare (type stream socket)
           #.*optimize*)
  (let* ((number (read-uint2 socket))
         (descriptions (make-array number)))
    (declare (type fixnum number)
             (type (simple-array field-description) descriptions))
    (dotimes (i number)
      (let* ((name (read-str socket))
             (table-oid (read-uint4 socket))
             (column (read-uint2 socket))
             (type-id (read-uint4 socket))
             (size (read-uint2 socket))
             (type-modifier (read-uint4 socket))
             (format (read-uint2 socket))
             (interpreter (get-type-interpreter type-id)))
        (declare (ignore table-oid column size type-modifier format)
                 (type string name)
                 (type (unsigned-byte 32) type-id))
        (setf (elt descriptions i)
              (if (interpreter-binary-p interpreter)
                  (make-instance 'field-description :name name :type-id type-id
                                 :interpreter (type-interpreter-binary-reader interpreter)
                                 :receive-binary-p t)
                  (make-instance 'field-description :name name :type-id type-id
                                 :interpreter (type-interpreter-text-reader interpreter)
                                 :receive-binary-p nil)))))
    descriptions))

(defun terminate-connection (socket)
  "Close a connection, notifying the server."
  (terminate-message socket)
  (close socket))

;; This is a hacky way to communicate the amount of effected rows up
;; from look-for-row to the send-execute or send-query that (directly
;; or indirectly) called it.
(defparameter *effected-rows* nil)

(defun look-for-row (socket)
  "Read server messages until either a new row can be read, or there
are no more results. Return a boolean indicating whether any more
results are available, and, if available, stores the amount of
effected rows in *effected-rows*. Also handle getting out of
copy-in/copy-out states \(which are not supported)."
  (declare (type stream socket)
           #.*optimize*)
  (loop
   (message-case socket
     ;; CommandComplete
     (#\C (let* ((command-tag (read-str socket))
                 (space (position #\Space command-tag :from-end t)))
            (when space
              (setf *effected-rows* (parse-integer command-tag :junk-allowed t
                                                   :start (1+ space))))
            (return-from look-for-row nil)))
     ;; CopyInResponse
     (#\G (read-uint1 socket)
          (skip-bytes socket (* 2 (read-uint2 socket))) ;; The field formats
          (copy-done-message socket)
          (error 'database-error :message "Copy-in not supported."))
     ;; CopyOutResponse
     (#\H (read-uint1 socket)
          (skip-bytes socket (* 2 (read-uint2 socket))) ;; The field formats
          (error 'database-error :message "Copy-out not supported."))
      ;; DataRow
     (#\D (skip-bytes socket 2)
          (return-from look-for-row t))
     ;; EmptyQueryResponse
     (#\I (warn "Empty query sent.")
          (return-from look-for-row nil)))))

(defun try-to-sync (socket sync-sent)
  "Try to re-synchronize a connection by sending a sync message if it
hasn't already been sent, and then looking for a ReadyForQuery
message."
  (when (open-stream-p socket)
    (let ((ok nil))
      (unwind-protect
           (progn
             (unless sync-sent
               (sync-message socket)
               (force-output socket))
             ;; TODO initiate timeout on the socket read, signal timeout error
             (loop :while (and (not ok) (open-stream-p socket))
                   :do (message-case socket
                         (#\Z (read-uint1 socket)
                              (setf ok t))
                         (t :skip))))
        (unless ok
          ;; if we can't sync, make sure the socket is shot
          ;; (e.g. a timeout, or aborting execution with a restart from sldb)
          (ensure-socket-is-closed socket :abort t))))))

(defmacro with-syncing (&body body)
  "Macro to wrap a block in a handler that will try to re-sync the
connection if something in the block raises a condition. Not hygienic
at all, only used right below here."
  `(let ((sync-sent nil)
         (ok nil))
    (handler-case
      (unwind-protect
           (multiple-value-prog1
               (progn ,@body)
             (setf ok t))
        (unless ok
          (try-to-sync socket sync-sent)))
      (end-of-file (c)
        (ensure-socket-is-closed socket :abort t)
        (error c)))))

(defmacro returning-effected-rows (value &body body)
  "Computes a value, then runs a body, then returns, as multiple
values, that value and the amount of effected rows, if any (see
*effected rows*)."
  (let ((value-name (gensym)))
    `(let* ((*effected-rows* nil)
            (,value-name ,value))
       ,@body
       (if *effected-rows*
           (values ,value-name *effected-rows*)
           ,value-name))))

(defun send-query (socket query row-reader)
  "Send a query to the server, and apply the given row-reader to the
results."
  (declare (type stream socket)
           (type string query)
           #.*optimize*)
  (with-syncing
    (with-query (query)
      (let ((row-description nil))
        (simple-parse-message socket query)
        (simple-describe-message socket)
        (flush-message socket)
        (force-output socket)
        (message-case socket
          ;; ParseComplete
          (#\1))
        (message-case socket
          ;; ParameterDescription
          (#\t :skip))
        (message-case socket
          ;; RowDescription
          (#\T (setf row-description (read-field-descriptions socket)))
          ;; NoData
          (#\n))
        (simple-bind-message socket (map 'vector 'field-binary-p row-description))
        (simple-execute-message socket)
        (sync-message socket)
        (setf sync-sent t)
        (force-output socket)
        (message-case socket
          ;; BindComplete
          (#\2))
        (returning-effected-rows
            (if row-description
                (funcall row-reader socket row-description)
                (look-for-row socket))
          (message-case socket
            ;; ReadyForQuery, skipping transaction status
            (#\Z (read-uint1 socket))))))))

(defun send-parse (socket name query)
  "Send a parse command to the server, giving it a name."
  (declare (type stream socket)
           (type string name query)
           #.*optimize*)
  (with-syncing
    (with-query (query)
      (parse-message socket name query)
      (flush-message socket)
      (force-output socket)
      (message-case socket
        ;; ParseComplete
        (#\1)))))

(defun send-close (socket name)
  "Send a close command to the server, giving it a name."
  (declare (type stream socket)
           (type string name)
           #.*optimize*)
  (with-syncing
    (close-prepared-message socket name)
    (flush-message socket)
    (force-output socket)
    (message-case socket
      ;; CloseComplete
      (#\3))))

(defun send-execute (socket name parameters row-reader)
  "Execute a previously parsed query, and apply the given row-reader
to the result."
  (declare (type stream socket)
           (type string name)
           (type list parameters)
           #.*optimize*)
  (with-syncing
    (let ((row-description nil)
          (n-parameters 0))
      (declare (type (unsigned-byte 16) n-parameters))
      (describe-prepared-message socket name)
      (flush-message socket)
      (force-output socket)
      (message-case socket
        ;; ParameterDescription
        (#\t (setf n-parameters (read-uint2 socket))
             (skip-bytes socket (* 4 n-parameters))))
      (message-case socket
        ;; RowDescription
        (#\T (setf row-description (read-field-descriptions socket)))
        ;; NoData
        (#\n))
      (unless (= (length parameters) n-parameters)
        (error 'database-error
               :message (format nil "Incorrect number of parameters given for prepared statement ~A. ~A parameters expected. ~A parameters received." name n-parameters (length parameters))))
      (bind-message socket name (map 'vector 'field-binary-p row-description)
                    parameters)
      (simple-execute-message socket)
      (sync-message socket)
      (setf sync-sent t)
      (force-output socket)
      (message-case socket
        ;; BindComplete
        (#\2))
      (returning-effected-rows
          (if row-description
              (funcall row-reader socket row-description)
              (look-for-row socket))
        (message-case socket
          ;; CommandComplete
          (#\C (read-str socket)
               (message-case socket
                 (#\Z (read-uint1 socket))))
          ;; ReadyForQuery, skipping transaction status
          (#\Z (read-uint1 socket)))))))

(defun build-row-reader (function-form fields body)
  "Helper for the following two macros."
  (let ((socket (gensym)))
    `(,@function-form (,socket ,fields)
      (declare (type stream ,socket)
               (type (simple-array field-description) ,fields))
      (flet ((next-row ()
               (look-for-row ,socket))
             (next-field (field)
               (declare (type field-description field))
               (let ((size (read-int4 ,socket)))
                 (declare (type (signed-byte 32) size))
                 (if (eq size -1)
                     :null
                     (funcall (field-interpreter field)
                              ,socket size)))))
        ,@body))))

(defmacro row-reader ((fields) &body body)
  "Create a row-reader, using the given name for the fields argument
and the given body for reading the rows. A row reader is a function
that is used to do something with the results of a query. It has two
local functions: next-row and next-field, the first should be called
once per row and will return a boolean indicating whether there are
any more rows, the second should be called once for every element in
the fields vector, with that field as argument, to read a single value
in a row. See list-row-reader in public.lisp for an example."
  (build-row-reader '(lambda) fields body))

(defmacro def-row-reader (name (fields) &body body)
  "Create a row reader, as in the row-reader macro, and assign a name
to it."
  (build-row-reader `(defun ,name) fields body))

#+END_SRC

** [[/Users/Can/Develop/Lisp/document/postmodern/cl-postgres/package.lisp][package]]
#+BEGIN_SRC lisp 
(defpackage :cl-postgres
  (:use :common-lisp)
  (:export #:database-error
           #:database-connection-lost
           #:database-error-message
           #:database-error-code
           #:database-error-detail
           #:database-error-query
           #:database-error-cause
           #:database-error-constraint-name
           #:database-error-extract-name
           #:database-connection
           #:database-connection-error
           #:database-socket-error
           #:connection-meta
           #:connection-parameters
           #:open-database
           #:reopen-database
           #:database-open-p
           #:close-database
           #:wait-for-notification
           #:exec-query
           #:prepare-query
           #:unprepare-query
           #:exec-prepared
           #:field-name
           #:field-type
           #:row-reader
           #:def-row-reader
           #:next-row
           #:next-field
           #:list-row-reader
           #:log-query
           #:vector-row-reader
           #:alist-row-reader
           #:postgresql-notification
           #:postgresql-notification-channel
           #:postgresql-notification-payload
           #:postgresql-notification-pid
           #:postgresql-warning
           #:ignore-row-reader
           #:*sql-readtable*
           #:copy-sql-readtable
           #:default-sql-readtable
           #:set-sql-reader
           #:set-sql-datetime-readers
           #:serialize-for-postgres
           #:to-sql-string
           #:*read-row-values-as-binary*
           #:with-binary-row-values
           #:with-text-row-values
           #:*silently-truncate-rationals*
           #:*silently-truncate-ratios*
           #:*query-callback*
           #:*query-log*
           #:open-db-writer
           #:db-write-row
           #:close-db-writer
           #:*ssl-certificate-file*
           #:*ssl-key-file*
           #:*retry-connect-times*
           #:*retry-connect-delay*
           #+(and sbcl unix) #:*unix-socket-dir*))

(defpackage :cl-postgres-error
  (:use :common-lisp :cl-postgres)
  (:export #:admin-shutdown
           #:cannot-connect-now
           #:check-violation
           #:columns-error
           #:crash-shutdown
           #:data-exception
           #:db-division-by-zero
           #:undefined-column
           #:duplicate-column
           #:duplicate-cursor
           #:duplicate-database
           #:duplicate-function
           #:duplicate-prepared-statement
           #:duplicate-schema
           #:duplicate-table
           #:duplicate-alias
           #:duplicate-object
           #:feature-not-supported
           #:floating-point-exception
           #:foreign-key-violation
           #:insufficient-resources
           #:insufficient-privilege
           #:transaction-rollback
           #:serialization-failure
           #:transaction-integrity-constraint-violation
           #:statement-completion-unknown
           #:deadlock-detected
           #:integrity-violation
           #:internal-error
           #:invalid-datetime-format
           #:invalid-sql-statement-name
           #:lock-not-available
           #:not-null-violation
           #:numeric-value-out-of-range
           #:object-in-use
           #:object-state-error
           #:operator-intervention
           #:program-limit-exceeded
           #:query-canceled
           #:restrict-violation
           #:server-shutdown
           #:syntax-error-or-access-violation
           #:system-error
           #:unique-violation))

(defpackage :cl-postgres-oid
  (:use :common-lisp)
  (:nicknames :oid)
  (:export #:+bool+
           #:+bytea+
           #:+char+
           #:+name+
           #:+int8+
           #:+int2+
           #:+int2vector+
           #:+int4+
           #:+regproc+
           #:+text+
           #:+oid+
           #:+tid+
           #:+xid+
           #:+cid+
           #:+oid-vector+
           #:+json+
           #:+xml+
           #:+pgnodetree+
           #:+pgddlcommand+
           #:+point+
           #:+lseg+
           #:+path+
           #:+box+
           #:+polygon+
           #:+line+
           #:+float4+
           #:+float8+
           #:+abstime+
           #:+reltime+
           #:+tinterval+
           #:+unknown+
           #:+circle+
           #:+cash+
           #:+macaddr+
           #:+inet+
           #:+cidr+
           #:+bool-array+
           #:+bytea-array+
           #:+char-array+
           #:+name-array+
           #:+int2-array+
           #:+int4-array+
           #:+text-array+
           #:+bpchar-array+
           #:+varchar-array+
           #:+int8-array+
           #:+point-array+
           #:+lseg-array+
           #:+box-array+
           #:+float4-array+
           #:+float8-array+
           #:+oid-array+
           #:+aclitem+
           #:+cstring-array+
           #:+bpchar+
           #:+varchar+
           #:+date+
           #:+time+
           #:+timestamp+
           #:+timestamp-array+
           #:+date-array+
           #:+time-array+
           #:+timestamptz+
           #:+timestamptz-array+
           #:+interval+
           #:+interval-array+
           #:+timetz+
           #:+bit+
           #:+bit-array+
           #:+varbit+
           #:+varbit-array+
           #:+numeric+
           #:+numeric-array+
           #:+refcursor+
           #:+regprocedure+
           #:+regoper+
           #:+regoperator+
           #:+regclass+
           #:+regtype+
           #:+regrole+
           #:+regnamespace+
           #:+regtype-array+
           #:+uuid+
           #:+lsn+
           #:+tsvector+
           #:+gtsvector+
           #:+tsquery+
           #:+regconfig+
           #:+regdictionary+
           #:+jsonb+
           #:+int4range+
           #:+record+
           #:+record-array+
           #:+cstring+
           #:+any+
           #:+any-array+
           #:+v-oid+
           #:+trigger+
           #:+evttrigger+
           #:+language-handler+
           #:+internal+
           #:+opaque+
           #:+anyelement+
           #:+anynon-array+
           #:+anyenum+
           #:+fdw-handler+
           #:+index-am-handler+
           #:+tsm-handler+
           #:+anyrange+))

(in-package :cl-postgres)

(eval-when (:compile-toplevel :load-toplevel :execute)
  ;; Optimization settings (only used by functions that need it).
  (defparameter *optimize*
    '(optimize
      (speed 3)
      #-ecl(safety 0) #+ecl(safety 1)
      (space 1)
      (debug 1)
      (compilation-speed 0))))

#+END_SRC

** [[/Users/Can/Develop/Lisp/document/postmodern/cl-postgres/oid.lisp][oid]]
#+BEGIN_SRC lisp 

(in-package :cl-postgres-oid)

(defconstant +bool+ 16)
(defconstant +bytea+ 17)
(defconstant +char+ 18)
(defconstant +name+ 19)
(defconstant +int8+ 20)
(defconstant +int2+ 21)
(defconstant +int2vector+ 22)
(defconstant +int4+ 23)
(defconstant +regproc+ 24)
(defconstant +text+ 25)
(defconstant +oid+ 26)
(defconstant +tid+ 27)
(defconstant +xid+ 28)
(defconstant +cid+ 29)
(defconstant +oid-vector+ 30)
(defconstant +json+ 114)
(defconstant +xml+ 142)
(defconstant +pgnodetree+ 194)
(defconstant +pgddlcommand+ 32)
(defconstant +point+ 600)
(defconstant +lseg+ 601)
(defconstant +path+ 602)
(defconstant +box+ 603)
(defconstant +polygon+ 604)
(defconstant +line+ 628)
(defconstant +float4+ 700)
(defconstant +float8+ 701)
(defconstant +abstime+ 702)
(defconstant +reltime+ 703)
(defconstant +tinterval+ 704)
(defconstant +unknown+ 705)
(defconstant +circle+ 718)
(defconstant +cash+ 790)
(defconstant +macaddr+ 829)
(defconstant +inet+ 869)
(defconstant +cidr+ 650)
(defconstant +bool-array+ 1000)
(defconstant +bytea-array+ 1001)
(defconstant +char-array+ 1002)
(defconstant +name-array+ 1003)
(defconstant +int2-array+ 1005)
(defconstant +int4-array+ 1007)
(defconstant +text-array+ 1009)
(defconstant +bpchar-array+ 1014)
(defconstant +varchar-array+ 1015)
(defconstant +int8-array+ 1016)
(defconstant +point-array+ 1017)
(defconstant +lseg-array+ 1018)
(defconstant +box-array+ 1020)
(defconstant +float4-array+ 1021)
(defconstant +float8-array+ 1022)
(defconstant +oid-array+ 1028)
(defconstant +aclitem+ 1033)
(defconstant +cstring-array+ 1263)
(defconstant +bpchar+ 1042)
(defconstant +varchar+ 1043)
(defconstant +date+ 1082)
(defconstant +time+ 1083)
(defconstant +timestamp+ 1114)
(defconstant +timestamp-array+ 1115)
(defconstant +date-array+ 1182)
(defconstant +time-array+ 1183)
(defconstant +timestamptz+ 1184)
(defconstant +timestamptz-array+ 1185)
(defconstant +interval+ 1186)
(defconstant +interval-array+ 1187)
(defconstant +timetz+ 1266)
(defconstant +bit+ 1560)
(defconstant +bit-array+ 1561)
(defconstant +varbit+ 1562)
(defconstant +varbit-array+ 1563)
(defconstant +numeric+ 1700)
(defconstant +numeric-array+ 1231)
(defconstant +refcursor+ 1790)
(defconstant +regprocedure+ 2202)
(defconstant +regoper+ 2203)
(defconstant +regoperator+ 2204)
(defconstant +regclass+ 2205)
(defconstant +regtype+ 2206)
(defconstant +regrole+ 4096)
(defconstant +regnamespace+ 4089)
(defconstant +regtype-array+ 2211)
(defconstant +uuid+ 2950)
(defconstant +lsn+ 3220)
(defconstant +tsvector+ 3614)
(defconstant +gtsvector+ 3642)
(defconstant +tsquery+ 3615)
(defconstant +regconfig+ 3734)
(defconstant +regdictionary+ 3769)
(defconstant +jsonb+ 3802)
(defconstant +int4range+ 3904)
(defconstant +record+ 2249)
(defconstant +record-array+ 2287)
(defconstant +cstring+ 2275)
(defconstant +any+ 2276)
(defconstant +any-array+ 2277)
(defconstant +v-oid+ 2278)
(defconstant +trigger+ 2279)
(defconstant +evttrigger+ 3838)
(defconstant +language-handler+ 2280)
(defconstant +internal+ 2281)
(defconstant +opaque+ 2282)
(defconstant +anyelement+ 2283)
(defconstant +anynon-array+ 2776)
(defconstant +anyenum+ 3500)
(defconstant +fdw-handler+ 3115)
(defconstant +index-am-handler+ 325)
(defconstant +tsm-handler+ 3310)
(defconstant +anyrange+ 3831)

#+END_SRC

** [[/Users/Can/Develop/Lisp/document/postmodern/cl-postgres/messages.lisp][messages]]
#+BEGIN_SRC lisp 
(in-package :cl-postgres)

;; For more information about the PostgreSQL scocket protocol, see
;; http://www.postgresql.org/docs/current/interactive/protocol.html

(defmacro define-message (name id (&rest arglist) &body parts)
  "This macro synthesizes a function to send messages of a specific
type. It takes care of the plumbing -- calling writer functions on a
stream, keeping track of the length of the message -- so that the
message definitions themselves stay readable."
  (let ((writers nil)
        (socket (gensym))
        (strings ())
        (base-length 4)
        (extra-length ()))
    (setf writers
          (mapcar (lambda (part)
                    (let ((name (gensym)))
                      (ecase (first part)
                        (uint
                         (incf base-length (second part))
                         `(,(integer-writer-name (second part) nil) ,socket ,(third part)))
                        (string
                         (push `(,name ,(second part)) strings)
                         (incf base-length 1) ;; The null terminator
                         (push `(enc-byte-length ,name) extra-length)
                         `(write-str ,socket ,name))
                        (bytes
                         (push `(,name ,(second part)) strings)
                         (push `(length ,name) extra-length)
                         `(write-bytes ,socket ,name)))))
                  parts))
    (push `(write-uint4 ,socket (+ ,base-length ,@extra-length))
          writers)
    (when id
      (push `(write-uint1 ,socket ,(char-code id)) writers))
    `(defun ,name ,(cons socket arglist)
      (declare (type stream ,socket)
               #.*optimize*)
      (let ,strings ,@writers))))

;; Try to enable SSL for a connection.
(define-message ssl-request-message nil ()
  (uint 4 80877103))

;; Sends the initial message and sets a few parameters.
(define-message startup-message nil (user database)
  (uint 4 196608) ;; Identifies protocol 3.0
  (string "user")
  (string user)
  (string "database")
  (string database)
  (string "client_encoding")
  (string *client-encoding*)
  (uint 1 0)) ;; Terminates the parameter list

;; Identify a user with a plain-text password.
(define-message plain-password-message #\p (password)
  (string password))

(defun bytes-to-hex-string (bytes)
  "Convert an array of 0-255 numbers into the corresponding string of
\(lowercase) hex codes."
  (declare (type (vector (unsigned-byte 8)) bytes)
           #.*optimize*)
  (let ((digits #.(coerce "0123456789abcdef" 'simple-base-string))
        (result (make-string (* (length bytes) 2) :element-type 'base-char)))
    (loop :for byte :across bytes
	  :for pos :from 0 :by 2
	  :do (setf (char result pos) (aref digits (ldb (byte 4 4) byte))
		    (char result (1+ pos)) (aref digits (ldb (byte 4 0) byte))))
    result))

(defun md5-password (password user salt)
  "Apply the hashing that PostgreSQL expects to a password."
  (declare (type string user password)
           (type (vector (unsigned-byte 8)) salt)
           #.*optimize*)
  (flet ((md5-and-hex (sequence)
           (bytes-to-hex-string (md5:md5sum-sequence sequence))))
    (let* ((pass1 (md5-and-hex (enc-string-bytes (concatenate 'string password user))))
           (pass2 (md5-and-hex (concatenate '(vector (unsigned-byte 8) *) (enc-string-bytes pass1) salt))))
      (concatenate 'string "md5" pass2))))

;; Identify a user with an MD5-hashed password.
(define-message md5-password-message #\p (password user salt)
  (string (md5-password password user salt)))

(define-message gss-auth-buffer-message #\p (buf)
  (bytes buf))

;; Send a query, the simple way.
(define-message query-message #\Q (query)
  (string query))

;; Parse a query
(define-message simple-parse-message #\P (query)
  (uint 1 0) ;; Name of the prepared statement
  (string query)
  (uint 2 0)) ;; Parameter types

;; Parse a query, giving it a name.
(define-message parse-message #\P (name query)
  (string name)
  (string query)
  (uint 2 0))

;; Close a named parsed query, freeing the name.
(define-message close-prepared-message #\C (name)
  (uint 1 #.(char-code #\S)) ;; Prepared statement
  (string name))

(defun formats-to-bytes (formats)
  "Formats have to be passed as arrays of 2-byte integers, with 1
indicating binary and 0 indicating plain text."
  (declare (type vector formats)
           #.*optimize*)
  (let* ((result (make-array (* 2 (length formats))
                             :element-type '(unsigned-byte 8)
                             :initial-element 0)))
    (loop :for format :across formats
          :for pos :from 1 :by 2
          :do (when format (setf (elt result pos) 1)))
    result))

;; Bind the unnamed prepared query, asking for the given result
;; formats.
(define-message simple-bind-message #\B (formats)
  (uint 1 0) ;; Name of the portal
  (uint 1 0) ;; Name of the prepared statement
  (uint 2 0) ;; Number of parameter format specs
  (uint 2 0) ;; Number of parameter specifications
  (uint 2 (length formats)) ;; Number of result format specifications
  (bytes (formats-to-bytes formats))) ;; Result format

;; This one was a bit too complex to put into define-message format,
;; so it does everything by hand.
(defun bind-message (socket name result-formats parameters)
  "Bind a prepared statement, ask for the given formats, and pass the
given parameters, that can be either string or byte vector.
\(vector \(unsigned-byte 8)) parameters will be sent as binary data, useful
for binding data for binary long object columns."
  (declare (type stream socket)
           (type string name)
           (type vector result-formats)
           (type list parameters)
           #.*optimize*)
  (let* ((n-params (length parameters))
         (param-formats (make-array n-params :element-type 'fixnum))
         (param-sizes (make-array n-params :element-type 'fixnum))
         (param-values (make-array n-params))
         (n-result-formats (length result-formats)))
    (declare (type (unsigned-byte 16) n-params n-result-formats))
    (loop :for param :in parameters
          :for i :from 0
          :do (flet ((set-param (format size value)
                       (setf (aref param-formats i) format
                             (aref param-sizes i) size
                             (aref param-values i) value)))
                (declare (inline set-param))
                (cond ((eq param :null)
                       (set-param 0 0 nil))
                      ((typep param '(vector (unsigned-byte 8)))
                       (set-param 1 (length param) param))
                      (t
                       (unless (typep param 'string)
                         (setf param (serialize-for-postgres param)))
                       (etypecase param
                         (string
                          (set-param 0 (enc-byte-length param) param))
                         ((vector (unsigned-byte 8))
                          (set-param 1 (length param) param)))))))
    (write-uint1 socket #.(char-code #\B))
    (write-uint4 socket (+ 12
                           (enc-byte-length name)
                           (* 6 n-params)   ;; Input formats and sizes
                           (* 2 n-result-formats)
                           (loop :for size :of-type fixnum :across param-sizes
                                 :sum size)))
    (write-uint1 socket 0)                  ;; Name of the portal
    (write-str socket name)                 ;; Name of the prepared statement
    (write-uint2 socket n-params)           ;; Number of parameter format specs
    (loop :for format :across param-formats ;; Param formats (text/binary)
          :do (write-uint2 socket format))
    (write-uint2 socket n-params)           ;; Number of parameter specifications
    (loop :for param :across param-values
          :for size :across param-sizes
          :do (write-int4 socket (if param size -1))
          :do (when param
                (if (typep param '(vector (unsigned-byte 8)))
                    (write-sequence param socket)
                    (enc-write-string param socket))))
    (write-uint2 socket n-result-formats)   ;; Number of result formats
    (loop :for format :across result-formats ;; Result formats (text/binary)
          :do (write-uint2 socket (if format 1 0)))))

;; Describe the anonymous portal, so we can find out what kind of
;; result types will be passed.
(define-message simple-describe-message #\D ()
  (uint 1 #.(char-code #\S)) ;; This is a statement describe
  (uint 1 0)) ;; Name of the portal

;; Describe a named portal.
(define-message describe-prepared-message #\D (name)
  (uint 1 #.(char-code #\S)) ;; This is a statement describe
  (string name))

;; Execute a bound statement.
(define-message simple-execute-message #\E ()
  (uint 1 0) ;; Name of the portal
  (uint 4 0)) ;; Max amount of rows (0 = all rows)

;; Flush the sent messages, force server to start responding.
(define-message flush-message #\H ())

;; For re-synchronizing a socket.
(define-message sync-message #\S ())

;; Tell the server we are about to close the connection.
(define-message terminate-message #\X ())

;; To get out of the copy-in protocol.
(define-message copy-done-message #\c ())

(defun copy-data-message (socket data)
  (declare (type string data)
           #.*optimize*)
  (write-uint1 socket 100)
  (write-uint4 socket (+ 4 (length data)))
  (enc-write-string data socket))

(define-message copy-fail-message #\f (reason)
  (string reason))

#+END_SRC

** [[/Users/Can/Develop/Lisp/document/postmodern/cl-postgres/interpret.lisp][interpret]]
#+BEGIN_SRC lisp 
(in-package :cl-postgres)

(defparameter *timestamp-format* :unbound
  "This is used to communicate the format \(integer or float) used for
timestamps and intervals in the current connection, so that the
interpreters for those types know how to parse them.")

(defparameter *sql-readtable* (make-hash-table)
  "The exported special var holding the current read table, a hash
mapping OIDs to instances of the type-interpreter class that contain
functions for retreiving values from the database in text, and
possible binary, form.")

(defun interpret-as-text (stream size)
  "This interpreter is used for types that we have no specific
interpreter for -- it just reads the value as a string. \(Values of
unknown types are passed in text form.)"
  (enc-read-string stream :byte-length size))

(defclass type-interpreter ()
  ((oid :initarg :oid :accessor type-interpreter-oid)
   (use-binary :initarg :use-binary :accessor type-interpreter-use-binary)
   (binary-reader :initarg :binary-reader :accessor type-interpreter-binary-reader)
   (text-reader :initarg :text-reader :accessor type-interpreter-text-reader))
  (:documentation "Information about type interpreter for types coming
  back from the database. use-binary is either T for binary, nil for
  text, or a function of no arguments to be called to determine if
  binary or text should be used. The idea is that there will always be
  a text reader, there may be a binary reader, and there may be times
  when one wants to use the text reader."))

(defun interpreter-binary-p (interp)
  "If the interpreter's use-binary field is a function, call it and
return the value, otherwise, return T or nil as appropriate."
  (let ((val (type-interpreter-use-binary interp)))
    (typecase val
      (function (funcall val))
      (t val))))

(defun interpreter-reader (interp)
  "Determine if we went the text or binary reader for this type
interpreter and return the appropriate reader."
  (if (interpreter-binary-p interp)
      (type-interpreter-binary-reader interp)
      (type-interpreter-text-reader interp)))

(let ((default-interpreter (make-instance 'type-interpreter
                                          :oid :default
                                          :use-binary nil
                                          :text-reader #'interpret-as-text)))
  (defun get-type-interpreter (oid)
    "Returns a type-interpreter containing interpretation rules for
this type."
    (gethash oid *sql-readtable* default-interpreter)))

(defun set-sql-reader (oid function &key (table *sql-readtable*) binary-p)
  "Add an sql reader to a readtable. When the reader is not binary, it
is wrapped by a function that will read the string from the socket."
  (assert (integerp oid))
  (if function
      (setf (gethash oid table)
            (make-instance 'type-interpreter
                           :oid oid
                           :use-binary binary-p
                           :binary-reader
                           (when binary-p function)
                           :text-reader
                           (if binary-p
                               'interpret-as-text
                               (lambda (stream size)
                                 (funcall function
                                          (enc-read-string stream :byte-length size))))))
      (remhash oid table))
  table)

(defmacro binary-reader (fields &body value)
  "A slightly convoluted macro for defining interpreter functions. It
allows two forms. The first is to pass a single type identifier, in
which case a value of this type will be read and returned directly.
The second is to pass a list of lists containing names and types, and
then a body. In this case the names will be bound to values read from
the socket and interpreted as the given types, and then the body will
be run in the resulting environment. If the last field is of type
bytes, string, or uint2s, all remaining data will be read and
interpreted as an array of the given type."
  (let ((stream-name (gensym))
        (size-name (gensym))
        (length-used 0))
    (flet ((read-type (type &optional modifier)
             (ecase type
               (bytes `(read-bytes ,stream-name (- ,size-name ,length-used)))
               (string `(enc-read-string ,stream-name :byte-length (- ,size-name ,length-used)))
               (uint2s `(let* ((size (/ (- ,size-name ,length-used) 2))
                               (result (make-array size :element-type '(unsigned-byte 16))))
                         (dotimes (i size)
                           (setf (elt result i) (read-uint2 ,stream-name)))
                         result))
               (int (assert (integerp modifier))
                    (incf length-used modifier)
                    `(,(integer-reader-name modifier t) ,stream-name))
               (uint (assert (integerp modifier))
                     (incf length-used modifier)
                     `(,(integer-reader-name modifier nil) ,stream-name)))))
      `(lambda (,stream-name ,size-name)
         (declare (type stream ,stream-name)
                  (type integer ,size-name)
                  (ignorable ,size-name))
         ,(if (consp fields)
              `(let ,(loop :for field :in fields
                           :collect `(,(first field) ,(apply #'read-type (cdr field))))
                 ,@value)
              (read-type fields (car value)))))))

(defmacro define-interpreter (oid name fields &body value)
  "Shorthand for defining binary readers."
  (declare (ignore name)) ;; Names are there just for clarity
  `(set-sql-reader ,oid (binary-reader ,fields ,@value) :binary-p t))

(define-interpreter oid:+char+ "char" int 1)
(define-interpreter oid:+int2+ "int2" int 2)
(define-interpreter oid:+int4+ "int4" int 4)
(define-interpreter oid:+int8+ "int8" int 8)

(define-interpreter oid:+oid+ "oid" uint 4)

(define-interpreter oid:+bool+ "bool" ((value int 1))
  (if (zerop value) nil t))

(define-interpreter oid:+bytea+ "bytea" bytes)
(define-interpreter oid:+text+ "text" string)
(define-interpreter oid:+bpchar+ "bpchar" string)
(define-interpreter oid:+varchar+ "varchar" string)

(define-interpreter oid:+json+ "json" string)
(define-interpreter oid:+jsonb+ "jsnob" ((version int 1)
                                         (content string))
  (unless (= 1 version)
    (warn "Unexpected JSONB version: ~S." version))
  content)

(defun read-row-value (stream size)
  (declare (type stream stream)
           (type integer size)
           (ignore size))
  (let ((num-fields (read-uint4 stream)))
    (loop for i below num-fields
       collect (let ((oid (read-uint4 stream))
                     (size (read-int4 stream)))
                 (declare (type (signed-byte 32) size))
                 (if (eq size -1)
                     :null
                     (funcall (interpreter-reader (get-type-interpreter oid)) stream size))))))

;; "row" types
(defparameter *read-row-values-as-binary* nil
  "Controls whether row values (as in select row(1, 'foo') ) should be
  received from the database in text or binary form. The default value
  is nil, specifying that the results be sent back as text. Set this
  to t to cause the results to be read as binary.")

(set-sql-reader oid:+record+ #'read-row-value :binary-p (lambda () *read-row-values-as-binary*))

(defmacro with-binary-row-values (&body body)
  "Helper macro to locally set *read-row-values-as-binary* to t while
executing body so that row values will be returned as binary."
  `(let ((*read-row-values-as-binary* t))
    ,@body))

(defmacro with-text-row-values (&body body)
  "Helper macro to locally set *read-row-values-as-binary* to nil while
executing body so that row values will be returned as t."
  `(let ((*read-row-values-as-binary* nil))
    ,@body))

(defun read-binary-bits (stream size)
  (declare (type stream stream)
           (type integer size))
  (let ((byte-count (- size 4))
        (bit-count (read-uint4 stream)))
    (let ((bit-bytes (read-bytes stream byte-count))
          (bit-array (make-array (list bit-count) :element-type 'bit)))
      (loop for i below bit-count
         do (let ((cur-byte (ash i -3))
                  (cur-bit (ldb (byte 3 0) i)))
              (setf (aref bit-array i)
                    (ldb (byte 1 (logxor cur-bit 7)) (aref bit-bytes cur-byte)))))
      bit-array)))

(set-sql-reader oid:+bit+ #'read-binary-bits :binary-p t)
(set-sql-reader oid:+varbit+ #'read-binary-bits :binary-p t)

(defun read-binary-array-value (stream size)
  (declare (type stream stream)
           (type integer size)
           (ignore size))
  (let ((num-dims (read-uint4 stream))
        (has-null (read-uint4 stream))
        (element-type (read-uint4 stream)))
     (cond
      ((zerop num-dims)
       ;; Should we return nil or a (make-array nil) when num-dims is
       ;; 0? Returning nil for now.
       nil)
      (t
       (let* ((array-dims
               (loop for i below num-dims
                  collect (let ((dim (read-uint4 stream))
                                (lb (read-uint4 stream)))
                            (declare (ignore lb))
                            dim)))
              (num-items (reduce #'* array-dims)))
         (let ((results (make-array array-dims)))
           (loop for i below num-items
              do (let ((size (read-int4 stream)))
                   (declare (type (signed-byte 32) size))
                   (setf (row-major-aref results i)
                         (if (eq size -1)
                             :null
                             (funcall (interpreter-reader (get-type-interpreter element-type)) stream size)))))
           results))))))

(dolist (oid (list oid:+bool-array+
                   oid:+bytea-array+
                   oid:+char-array+
                   oid:+name-array+ ;; (internal PG type)
                   oid:+int2-array+
                   oid:+int4-array+
                   oid:+text-array+
                   oid:+bpchar-array+
                   oid:+varchar-array+
                   oid:+int8-array+
                   oid:+point-array+
                   oid:+lseg-array+
                   oid:+box-array+
                   oid:+float4-array+
                   oid:+float8-array+
                   oid:+oid-array+
                   oid:+timestamp-array+
                   oid:+date-array+
                   oid:+time-array+
                   oid:+timestamptz-array+
                   oid:+interval-array+
                   oid:+bit-array+
                   oid:+varbit-array+
                   oid:+numeric-array+))
  (set-sql-reader oid #'read-binary-array-value :binary-p t))

;; record arrays
;;
;; NOTE: need to treat this separately because if we want
;; the record (row types) to come back as text, we have to read the
;; array value as text.
(set-sql-reader oid:+record-array+ #'read-binary-array-value :binary-p (lambda () *read-row-values-as-binary*))

(define-interpreter oid:+point+ "point" ((point-x-bits uint 8)
                                 (point-y-bits uint 8))
  (list (cl-postgres-ieee-floats:decode-float64 point-x-bits)
        (cl-postgres-ieee-floats:decode-float64 point-y-bits)))

(define-interpreter oid:+lseg+ "lseg" ((point-x1-bits uint 8)
                                (point-y1-bits uint 8)
                                (point-x2-bits uint 8)
                                (point-y2-bits uint 8))
  (list (list (cl-postgres-ieee-floats:decode-float64 point-x1-bits)
              (cl-postgres-ieee-floats:decode-float64 point-y1-bits))
        (list (cl-postgres-ieee-floats:decode-float64 point-x2-bits)
              (cl-postgres-ieee-floats:decode-float64 point-y2-bits))))

(define-interpreter oid:+box+ "box" ((point-x1-bits uint 8)
                               (point-y1-bits uint 8)
                               (point-x2-bits uint 8)
                               (point-y2-bits uint 8))
  (list (list (cl-postgres-ieee-floats:decode-float64 point-x1-bits)
              (cl-postgres-ieee-floats:decode-float64 point-y1-bits))
        (list (cl-postgres-ieee-floats:decode-float64 point-x2-bits)
              (cl-postgres-ieee-floats:decode-float64 point-y2-bits))))

(define-interpreter oid:+float4+ "float4" ((bits uint 4))
  (cl-postgres-ieee-floats:decode-float32 bits))
(define-interpreter oid:+float8+ "float8" ((bits uint 8))
  (cl-postgres-ieee-floats:decode-float64 bits))

;; Numeric types are rather involved. I got some clues on their
;; structure from http://archives.postgresql.org/pgsql-interfaces/2004-08/msg00000.php
(define-interpreter oid:+numeric+ "numeric"
    ((length uint 2)
     (weight int 2)
     (sign int 2)
     (dscale int 2)
     (digits uint2s))
  (declare (ignore dscale))
  (let ((total (loop :for i :from (1- length) :downto 0
                     :for scale = 1 :then (* scale #.(expt 10 4))
                     :summing (* scale (elt digits i))))
        (scale (- length weight 1)))
    (unless (zerop sign)
      (setf total (- total)))
    (/ total (expt 10000 scale))))

;; Since date and time types are the most likely to require custom
;; readers, there is a hook for easily adding binary readers for them.

(defun set-date-reader (f table)
  (set-sql-reader oid:+date+ (binary-reader ((days int 4))
                               (funcall f days))
                  :table table
                  :binary-p t))

(defun interpret-usec-bits (bits)
  "Decode a 64 bit time-related value based on the timestamp format
used. Correct for sign bit when using integer format."
  (ecase *timestamp-format*
    (:float (round (* (cl-postgres-ieee-floats:decode-float64 bits) 1000000)))
    (:integer (if (logbitp 63 bits)
                  (dpb bits (byte 63 0) -1)
                  bits))))

(defun set-interval-reader (f table)
  (set-sql-reader oid:+interval+ (binary-reader ((usec-bits uint 8) (days int 4) (months int 4))
                                   (funcall f months days (interpret-usec-bits usec-bits)))
                  :table table
                  :binary-p t))

(defun set-usec-reader (oid f table)
  (set-sql-reader oid (binary-reader ((usec-bits uint 8))
                        (funcall f (interpret-usec-bits usec-bits)))
                  :table table
                  :binary-p t))

;; Public interface for adding date/time readers

(defun set-sql-datetime-readers (&key date timestamp timestamp-with-timezone interval time
                                 (table *sql-readtable*))
  (when date (set-date-reader date table))
  (when timestamp (set-usec-reader oid:+timestamp+ timestamp table))
  (when timestamp-with-timezone (set-usec-reader oid:+timestamptz+ timestamp-with-timezone table))
  (when interval (set-interval-reader interval table))
  (when time (set-usec-reader oid:+time+ time table))
  table)

;; Provide meaningful defaults for the date/time readers.

(defconstant +start-of-2000+ (encode-universal-time 0 0 0 1 1 2000 0))
(defconstant +seconds-in-day+ (* 60 60 24))

(set-sql-datetime-readers
 :date (lambda (days-since-2000)
         (+ +start-of-2000+ (* days-since-2000 +seconds-in-day+)))
 :timestamp (lambda (useconds-since-2000)
              (+ +start-of-2000+ (floor useconds-since-2000 1000000)))
 :timestamp-with-timezone (lambda (useconds-since-2000)
                            (+ +start-of-2000+ (floor useconds-since-2000 1000000)))
 :interval (lambda (months days useconds)
             (multiple-value-bind (sec us) (floor useconds 1000000)
               `((:months ,months) (:days ,days) (:seconds ,sec) (:useconds ,us))))
 :time (lambda (usecs)
         (multiple-value-bind (seconds usecs)
             (floor usecs 1000000)
           (multiple-value-bind (minutes seconds)
               (floor seconds 60)
             (multiple-value-bind (hours minutes)
                 (floor minutes 60)
               `((:hours ,hours) (:minutes ,minutes) (:seconds ,seconds) (:microseconds ,usecs)))))))

;; Readers for a few of the array types

(defun read-array-value (transform)
  (declare #.*optimize*)
  (lambda (value)
    (declare (type string value))
    (let ((pos 0))
      (declare (type fixnum pos))
      (labels ((readelt ()
                 (case (char value pos)
                   (#\" (interpret
                         (with-output-to-string (out)
                           (loop :with escaped := nil :for ch := (char value (incf pos)) :do
                              (when (and (char= ch #\") (not escaped)) (return))
                              (setf escaped (and (not escaped) (char= ch #\\)))
                              (unless escaped (write-char ch out)))
                           (incf pos))))
                   (#\{ (incf pos)
                        (unless (char= (char value pos) #\})
                          (loop :for val := (readelt) :collect val :into vals :do
                             (let ((next (char value pos)))
                               (incf pos)
                               (ecase next (#\,) (#\} (return vals)))))))
                   (t (let ((start pos))
                        (loop :for ch := (char value pos) :do
                           (when (or (char= ch #\,) (char= ch #\}))
                             (return (interpret (subseq value start pos))))
                           (incf pos))))))
               (interpret (word)
                 (if (string= word "NULL") :null (funcall transform word))))
        (let* ((arr (readelt))
               (dim (if arr (loop :for x := arr :then (car x) :while (consp x) :collect (length x)) '(0))))
          (make-array dim :initial-contents arr))))))

;; Working with tables.

(defun copy-sql-readtable (&optional (table *sql-readtable*))
  (let ((new-table (make-hash-table)))
    (maphash (lambda (oid interpreter) (setf (gethash oid new-table) interpreter))
             table)
    new-table))

(defparameter *default-sql-readtable* (copy-sql-readtable *sql-readtable*)
  "A copy of the default readtable that client code can fall back
  on.")

(defun default-sql-readtable ()
  *default-sql-readtable*)

#+END_SRC

** [[/Users/Can/Develop/Lisp/document/postmodern/cl-postgres/ieee-floats.lisp][ieee-floats]]
#+BEGIN_SRC lisp 
;;; Functions for converting floating point numbers represented in
;;; IEEE 754 style to lisp numbers.
;;;
;;; See http://common-lisp.net/project/ieee-floats/

(defpackage :cl-postgres-ieee-floats
  (:use :common-lisp)
  (:export :make-float-converters
	   :encode-float32
	   :decode-float32
	   :encode-float64
	   :decode-float64))

(in-package :cl-postgres-ieee-floats)

;; The following macro may look a bit overcomplicated to the casual
;; reader. The main culprit is the fact that NaN and infinity can be
;; optionally included, which adds a bunch of conditional parts.
;;
;; Assuming you already know more or less how floating point numbers
;; are typically represented, I'll try to elaborate a bit on the more
;; confusing parts, as marked by letters:
;;
;; (A) Exponents in IEEE floats are offset by half their range, for
;;     example with 8 exponent bits a number with exponent 2 has 129
;;     stored in its exponent field.
;;
;; (B) The maximum possible exponent is reserved for special cases
;;     (NaN, infinity).
;;
;; (C) If the exponent fits in the exponent-bits, we have to adjust
;;     the significand for the hidden bit. Because decode-float will
;;     return a significand between 0 and 1, and we want one between 1
;;     and 2 to be able to hide the hidden bit, we double it and then
;;     subtract one (the hidden bit) before converting it to integer
;;     representation (to adjust for this, 1 is subtracted from the
;;     exponent earlier). When the exponent is too small, we set it to
;;     zero (meaning no hidden bit, exponent of 1), and adjust the
;;     significand downward to compensate for this.
;;
;; (D) Here the hidden bit is added. When the exponent is 0, there is
;;     no hidden bit, and the exponent is interpreted as 1.
;;
;; (E) Here the exponent offset is subtracted, but also an extra
;;     factor to account for the fact that the bits stored in the
;;     significand are supposed to come after the 'decimal dot'.

(defmacro make-float-converters (encoder-name
				 decoder-name
				 exponent-bits
				 significand-bits
				 support-nan-and-infinity-p)
  "Writes an encoder and decoder function for floating point
numbers with the given amount of exponent and significand
bits (plus an extra sign bit). If support-nan-and-infinity-p is
true, the decoders will also understand these special cases. NaN
is represented as :not-a-number, and the infinities as 
:positive-infinity and :negative-infinity. Note that this means
that the in- or output of these functions is not just floating
point numbers anymore, but also keywords."
  (let* ((total-bits (+ 1 exponent-bits significand-bits))
	 (exponent-offset (1- (expt 2 (1- exponent-bits)))) ; (A)
	 (sign-part `(ldb (byte 1 ,(1- total-bits)) bits))
	 (exponent-part `(ldb (byte ,exponent-bits ,significand-bits) bits))
	 (significand-part `(ldb (byte ,significand-bits 0) bits))
	 (nan support-nan-and-infinity-p)
	 (max-exponent (1- (expt 2 exponent-bits)))) ; (B)
    `(progn
       (defun ,encoder-name (float)
	 ,@(unless nan `((declare (type float float))))
         (multiple-value-bind (sign significand exponent)
             (cond ,@(when nan `(((eq float :not-a-number)
                                  (values 0 1 ,max-exponent))
                                 ((eq float :positive-infinity)
                                  (values 0 0 ,max-exponent))
                                 ((eq float :negative-infinity)
                                  (values 1 0 ,max-exponent))))
                   ((zerop float)
                    (values 0 0 0))
                   (t
                    (multiple-value-bind (significand exponent sign) (decode-float float)
                      (let ((exponent (+ (1- exponent) ,exponent-offset))
                            (sign (if (= sign 1.0) 0 1)))
                        (unless (< exponent ,(expt 2 exponent-bits))
                          (error "Floating point overflow when encoding ~A." float))
                        (if (< exponent 0) ; (C)
                            (values sign (ash (round (* ,(expt 2 significand-bits) significand)) exponent) 0)
                            (values sign (round (* ,(expt 2 significand-bits) (1- (* significand 2)))) exponent))))))
	   (let ((bits 0))
	     (declare (type (unsigned-byte ,total-bits) bits))
	     (setf ,sign-part sign
		   ,exponent-part exponent
		   ,significand-part significand)
	     bits)))

       (defun ,decoder-name (bits)
	 (declare (type (unsigned-byte ,total-bits) bits))
	 (let* ((sign ,sign-part)
		(exponent ,exponent-part)
		(significand ,significand-part))
	   ,@(when nan `((when (= exponent ,max-exponent)
			   (return-from ,decoder-name 
			     (cond ((not (zerop significand)) :not-a-number)
				   ((zerop sign) :positive-infinity)
				   (t :negative-infinity))))))
           (if (zerop exponent) ; (D)
               (setf exponent 1)
               (setf (ldb (byte 1 ,significand-bits) significand) 1))
	   (unless (zerop sign)
	     (setf significand (- significand)))
	   (scale-float (float significand ,(if (> total-bits 32) 1.0d0 1.0))
			(- exponent ,(+ exponent-offset significand-bits)))))))) ; (E)

;; And instances of the above for the common forms of floats.
(make-float-converters encode-float32 decode-float32 8 23 nil)
(make-float-converters encode-float64 decode-float64 11 52 nil)

;;; Copyright (c) 2006 Marijn Haverbeke
;;;
;;; This software is provided 'as-is', without any express or implied
;;; warranty. In no event will the authors be held liable for any
;;; damages arising from the use of this software.
;;;
;;; Permission is granted to anyone to use this software for any
;;; purpose, including commercial applications, and to alter it and
;;; redistribute it freely, subject to the following restrictions:
;;;
;;; 1. The origin of this software must not be misrepresented; you must
;;;    not claim that you wrote the original software. If you use this
;;;    software in a product, an acknowledgment in the product
;;;    documentation would be appreciated but is not required.
;;;
;;; 2. Altered source versions must be plainly marked as such, and must
;;;    not be misrepresented as being the original software.
;;;
;;; 3. This notice may not be removed or altered from any source
;;;    distribution.

#+END_SRC

** [[/Users/Can/Develop/Lisp/document/postmodern/cl-postgres/features.lisp][features]]
#+BEGIN_SRC lisp 
(defpackage :cl-postgres.features
  (:use :common-lisp)
  (:export #:sbcl-available
           #:sbcl-ipv6-available))
(in-package :cl-postgres.features)


(eval-when (:compile-toplevel :load-toplevel :execute)
  (when (find-package 'sb-bsd-sockets)
    (pushnew 'sbcl-available *features*)

    (when (find-symbol "INET6-SOCKET" 'sb-bsd-sockets)
      (pushnew 'sbcl-ipv6-available *features*))))

#+END_SRC

** [[/Users/Can/Develop/Lisp/document/postmodern/cl-postgres/errors.lisp][errors]]
#+BEGIN_SRC lisp 
(in-package :cl-postgres)

(defparameter *current-query* nil)
(defparameter *query-log* nil)
(defparameter *query-callback* 'log-query)

(defun log-query (query time-units)
  (when *query-log*
    (format *query-log* "CL-POSTGRES query (~ams): ~a~%"
            (round (/ (* 1000 time-units)
                      internal-time-units-per-second))
            query)))

(defmacro with-query ((query) &body body)
  (let ((time-name (gensym)))
    `(let ((*current-query* ,query)
           (,time-name (if *query-callback* (get-internal-real-time) 0)))
       (multiple-value-prog1 (progn ,@body)
         (when *query-callback*
           (funcall *query-callback*
                    *current-query*
                    (- (get-internal-real-time) ,time-name)))))))

;;
;; See http://www.postgresql.org/docs/9.3/static/protocol-error-fields.html
;; for details, including documentation strings.
;;
(define-condition database-error (error)
  ((error-code :initarg :code :initform nil :reader database-error-code
               :documentation "Code: the SQLSTATE code for the error (see Appendix A). Not localizable. Always present.")
   (message :initarg :message :accessor database-error-message
            :documentation "Message: the primary human-readable error message. This should be accurate but terse (typically one line). Always present.")
   (detail :initarg :detail :initform nil :reader database-error-detail
           :documentation "Detail: an optional secondary error message carrying more detail about the problem. Might run to multiple lines.")
   (hint :initarg :hint :initform nil :reader database-error-hint
         :documentation "Hint: an optional suggestion what to do about the problem.")
   (context :initarg :context :initform nil :reader database-error-context
            :documentation "Where: an indication of the context in which the error occurred. Presently this includes a call stack traceback of active procedural language functions and internally-generated queries. The trace is one entry per line, most recent first."
)
   (query :initform *current-query* :reader database-error-query
          :documentation "Query that led to the error, if any.")
   (position :initarg :position :initform nil :reader database-error-position
             :documentation "Position: the field value is a decimal ASCII integer, indicating an error cursor position as an index into the original query string. The first character has index 1, and positions are measured in characters not bytes.")
   (cause :initarg :cause :initform nil :reader database-error-cause))
  (:report (lambda (err stream)
             (format stream "Database error~@[ ~A~]: ~A~@[~&DETAIL: ~A~]~@[~&HINT: ~A~]~@[~&CONTEXT: ~A~]~@[~&QUERY: ~A~]~@[~VT^~]"
                     (database-error-code err)
                     (database-error-message err)
                     (database-error-detail err)
                     (database-error-hint err)
                     (database-error-context err)
                     (database-error-query err)
                     (database-error-position err))))
  (:documentation "This is the condition type that will be used to
signal virtually all database-related errors \(though in some cases
socket errors may be raised when a connection fails on the IP
level)."))

(defun database-error-constraint-name (err)
  "Given a database-error for an integrity violation, will attempt to
extract the constraint name."
  (labels ((extract-quoted-part (string n)
             "Extracts the Nth quoted substring from STRING."
             (let* ((start-quote-inst (* 2 n))
                    (start-quote-pos (position-nth #\" string start-quote-inst))
                    (end-quote-pos (position #\" string :start (1+ start-quote-pos))))
               (subseq string (1+ start-quote-pos) end-quote-pos)))
           (position-nth (item seq n)
             "Finds the position of the zero-indexed Nth ITEM in SEQ."
             (loop :with pos = -1 :repeat (1+ n)
                   :do (setf pos (position item seq :start (1+ pos)))
                   :finally (return pos))))
    (let ((message (database-error-message err)))
      (typecase err
        (cl-postgres-error:not-null-violation (extract-quoted-part message 0))
        (cl-postgres-error:unique-violation (extract-quoted-part message 0))
        (cl-postgres-error:foreign-key-violation (extract-quoted-part message 1))
        (cl-postgres-error:check-violation (extract-quoted-part message 1))))))

(defun database-error-extract-name (err)
  "Given a database-error, will extract the critical name from the error message."
  (labels ((extract-quoted-part (string n)
             "Extracts the Nth quoted substring from STRING."
             (let* ((start-quote-inst (* 2 n))
                    (start-quote-pos (position-nth #\" string start-quote-inst))
                    (end-quote-pos (position #\" string :start (1+ start-quote-pos))))
               (subseq string (1+ start-quote-pos) end-quote-pos)))
           (position-nth (item seq n)
             "Finds the position of the zero-indexed Nth ITEM in SEQ."
             (loop :with pos = -1 :repeat (1+ n)
                   :do (setf pos (position item seq :start (1+ pos)))
                :finally (return pos))))
    (let* ((message (database-error-message err)))
           (typecase err
             (cl-postgres-error:invalid-sql-statement-name
              (extract-quoted-part message 0))
             (cl-postgres-error:duplicate-prepared-statement
              (extract-quoted-part message 0))))))

(define-condition database-connection-error (database-error) ()
  (:documentation "Conditions of this type are signalled when an error
occurs that breaks the connection socket. They offer a :reconnect
restart."))
(define-condition database-connection-lost (database-connection-error) ()
  (:documentation "Raised when a query is initiated on a disconnected
connection object."))
(define-condition database-socket-error (database-connection-error) ()
  (:documentation "Used to wrap stream-errors and socket-errors,
giving them a database-connection-error superclass."))

(defun wrap-socket-error (err)
  (make-instance 'database-socket-error
                 :message (princ-to-string err)
                 :cause err))

(in-package :cl-postgres-error)

(defparameter *error-table* (make-hash-table :test 'equal))
(defmacro deferror (code typename &optional (superclass 'database-error))
  `(progn (define-condition ,typename (,superclass) ())
          (setf (gethash ,code *error-table*) ',typename)))

(deferror "0A" feature-not-supported)
(deferror "22" data-exception)
(deferror "22012" db-division-by-zero data-exception)
(deferror "22007" invalid-datetime-format data-exception)
(deferror "22003" numeric-value-out-of-range data-exception)
(deferror "22P01" floating-point-exception data-exception)
(deferror "23" integrity-violation)
(deferror "23001" restrict-violation integrity-violation)
(deferror "23502" not-null-violation integrity-violation)
(deferror "23503" foreign-key-violation integrity-violation)
(deferror "23505" unique-violation integrity-violation)
(deferror "23514" check-violation integrity-violation)
(deferror "26000" invalid-sql-statement-name)
(deferror "42" syntax-error-or-access-violation)
(deferror "42501" insufficient-privilege syntax-error-or-access-violation)
(deferror "40" transaction-rollback)
(deferror "40001" serialization-failure transaction-rollback)
(deferror "40002" transaction-integrity-constraint-violation transaction-rollback)
(deferror "40003" statement-completion-unknown transaction-rollback)
(deferror "40P01" deadlock-detected transaction-rollback)
(deferror "42P01" undefined-table syntax-error-or-access-violation)
(deferror "42601" columns-error syntax-error-or-access-violation)
(deferror "42703" undefined-column syntax-error-or-access-violation)
(deferror "42701" duplicate-column syntax-error-or-access-violation)
(deferror "42P03" duplicate-cursor syntax-error-or-access-violation)
(deferror "42P04" duplicate-database syntax-error-or-access-violation)
(deferror "42723" duplicate-function syntax-error-or-access-violation)
(deferror "42P05" duplicate-prepared-statement syntax-error-or-access-violation)
(deferror "42P06" duplicate-schema syntax-error-or-access-violation)
(deferror "42P07" duplicate-table syntax-error-or-access-violation)
(deferror "42712" duplicate-alias syntax-error-or-access-violation)
(deferror "42710" duplicate-object syntax-error-or-access-violation)
(deferror "53" insufficient-resources)
(deferror "54" program-limit-exceeded)
(deferror "55" object-state-error)
(deferror "55006" object-in-use object-state-error)
(deferror "55P03" lock-not-available object-state-error)
(deferror "57" operator-intervention)
(deferror "57014" query-canceled operator-intervention)
(define-condition server-shutdown (operator-intervention database-connection-error) ())
(deferror "57P01" admin-shutdown server-shutdown)
(deferror "57P02" crash-shutdown server-shutdown)
(deferror "57P03" cannot-connect-now operator-intervention)
(deferror "58" system-error)
(deferror "XX" internal-error)

(defun get-error-type (code)
  (or (gethash code *error-table*)
      (and code (gethash (subseq code 0 2) *error-table*))
      'database-error))

#+END_SRC

** [[/Users/Can/Develop/Lisp/document/postmodern/cl-postgres/communicate.lisp][communicate]]
#+BEGIN_SRC lisp 
(in-package :cl-postgres)

;; These are used to synthesize reader and writer names for integer
;; reading/writing functions when the amount of bytes and the
;; signedness is known. Both the macro that creates the functions and
;; some macros that use them create names this way.
(eval-when (:compile-toplevel :load-toplevel :execute)
  (defun integer-reader-name (bytes signed)
    (intern (with-standard-io-syntax
              (format nil "~a~a~a~a" '#:read- (if signed "" '#:u) '#:int bytes))))
  (defun integer-writer-name (bytes signed)
    (intern (with-standard-io-syntax
              (format nil "~a~a~a~a" '#:write- (if signed "" '#:u) '#:int bytes)))))

(defmacro integer-reader (bytes)
  "Create a function to read integers from a binary stream."
  (let ((bits (* bytes 8)))
    (labels ((return-form (signed)
               (if signed
                   `(if (logbitp ,(1- bits) result)
                        (dpb result (byte ,(1- bits) 0) -1)
                        result)
                   `result))
             (generate-reader (signed)
               `(defun ,(integer-reader-name bytes signed) (socket)
                  (declare (type stream socket)
                           #.*optimize*)
                  ,(if (= bytes 1)
                       `(let ((result (the (unsigned-byte 8) (read-byte socket))))
                          (declare (type (unsigned-byte 8) result))
                          ,(return-form signed))
                       `(let ((result 0))
                          (declare (type (unsigned-byte ,bits) result))
                          ,@(loop :for byte :from (1- bytes) :downto 0
                                   :collect `(setf (ldb (byte 8 ,(* 8 byte)) result)
                                                   (the (unsigned-byte 8) (read-byte socket))))
                          ,(return-form signed))))))
      `(progn
;; This causes weird errors on SBCL in some circumstances. Disabled for now.
;;         (declaim (inline ,(integer-reader-name bytes t)
;;                          ,(integer-reader-name bytes nil)))
         (declaim (ftype (function (t) (signed-byte ,bits))
                         ,(integer-reader-name bytes t)))
         ,(generate-reader t)
         (declaim (ftype (function (t) (unsigned-byte ,bits))
                         ,(integer-reader-name bytes nil)))
         ,(generate-reader nil)))))

(defmacro integer-writer (bytes)
  "Create a function to write integers to a binary stream."
  (let ((bits (* 8 bytes)))
    `(progn
      (declaim (inline ,(integer-writer-name bytes t)
                       ,(integer-writer-name bytes nil)))
      (defun ,(integer-writer-name bytes nil) (socket value)
        (declare (type stream socket)
                 (type (unsigned-byte ,bits) value)
                 #.*optimize*)
        ,@(if (= bytes 1)
              `((write-byte value socket))
              (loop :for byte :from (1- bytes) :downto 0
                    :collect `(write-byte (ldb (byte 8 ,(* byte 8)) value)
                               socket)))
        (values))
      (defun ,(integer-writer-name bytes t) (socket value)
        (declare (type stream socket)
                 (type (signed-byte ,bits) value)
                 #.*optimize*)
        ,@(if (= bytes 1)
              `((write-byte (ldb (byte 8 0) value) socket))
              (loop :for byte :from (1- bytes) :downto 0
                    :collect `(write-byte (ldb (byte 8 ,(* byte 8)) value)
                               socket)))
        (values)))))

;; All the instances of the above that we need.

(integer-reader 1)
(integer-reader 2)
(integer-reader 4)
(integer-reader 8)

(integer-writer 1)
(integer-writer 2)
(integer-writer 4)

(defun write-bytes (socket bytes)
  "Write a byte-array to a stream."
  (declare (type stream socket)
           (type (simple-array (unsigned-byte 8)) bytes)
           #.*optimize*)
  (write-sequence bytes socket))

(defun write-str (socket string)
  "Write a null-terminated string to a stream \(encoding it when UTF-8
support is enabled.)."
  (declare (type stream socket)
           (type string string)
           #.*optimize*)
  (enc-write-string string socket)
  (write-uint1 socket 0))

(declaim (ftype (function (t unsigned-byte)
                          (simple-array (unsigned-byte 8) (*)))
                read-bytes))
(defun read-bytes (socket length)
  "Read a byte array of the given length from a stream."
  (declare (type stream socket)
           (type fixnum length)
           #.*optimize*)
  (let ((result (make-array length :element-type '(unsigned-byte 8))))
    (read-sequence result socket)
    result))

(declaim (ftype (function (t) string) read-str))
(defun read-str (socket)
  "Read a null-terminated string from a stream. Takes care of encoding
when UTF-8 support is enabled."
  (declare (type stream socket)
           #.*optimize*)
  (enc-read-string socket :null-terminated t))

(declaim (ftype (function (t) string) read-simple-str))
(defun read-simple-str (socket)
  "Read a null-terminated string from a stream. Interprets it as ASCII."
  (declare (type stream socket)
           #.*optimize*)
  (with-output-to-string (out)
    (loop :for b := (read-byte socket nil 0) :do
       (cond ((eq b 0) (return))
             ((< b 128) (write-char (code-char b) out))))))

(defun skip-bytes (socket length)
  "Skip a given number of bytes in a binary stream."
  (declare (type stream socket)
           (type (unsigned-byte 32) length)
           #.*optimize*)
  (dotimes (i length)
    (read-byte socket)))

(defun skip-str (socket)
  "Skip a null-terminated string."
  (declare (type stream socket)
           #.*optimize*)
  (loop :for char :of-type fixnum = (read-byte socket)
        :until (zerop char)))

(defun ensure-socket-is-closed (socket &key abort)
  (when (open-stream-p socket)
    (handler-case
        (close socket :abort abort)
      (error (error)
        (warn "Ignoring the error which happened while trying to close PostgreSQL socket: ~A" error)))))

#+END_SRC

** [[/Users/Can/Develop/Lisp/document/postmodern/cl-postgres/bulk-copy.lisp][bulk-copy]]
#+BEGIN_SRC lisp 

(in-package :cl-postgres)

(defclass bulk-copier ()
  ((own-connection :initarg :own-connection :reader bulk-copier-own-connection)
   (database :initarg :database :reader copier-database)
   (table :initarg :table :reader copier-table)
   (columns :initarg :columns :reader copier-columns)
   (count :initform 0 :accessor copier-count)))

(defmethod print-object ((self bulk-copier) stream)
  (print-unreadable-object (self stream :type t :identity t)
    (format stream "~a ~a" (copier-table self)
	    (copier-columns self))))


(defun open-db-writer (db-spec table columns)
  (let* ((own-connection (listp db-spec))
         (copier (make-instance 'bulk-copier
                   :own-connection own-connection
                   :database (if own-connection (apply 'open-database db-spec) db-spec)
                   :table table
                   :columns columns)))
    (initialize-copier copier)
    copier))

(defun close-db-writer (self &key (abort nil))
  (unwind-protect
       (let* ((connection (copier-database self))
              (socket (connection-socket connection)))
         (with-reconnect-restart connection
           (using-connection connection
             (send-copy-done socket))))
    (when (or abort (bulk-copier-own-connection self))
      (close-database (copier-database self))))
  (copier-count self))

(defun db-write-row (self row &optional (data (prepare-row self row)))
  (let* ((connection (copier-database self))
	 (socket (connection-socket connection)))
    (with-reconnect-restart connection
      (using-connection connection
        (with-syncing
          (copy-data-message socket data)))))
  (incf (copier-count self)))

(defun copy-query (self)
  (format nil "~%copy ~a ~@[(~{~a~^,~})~] ~a ~a"
    (copier-table self)
    (copier-columns self)
    "FROM"
    "STDIN"))

(defun send-copy-start (socket query)
  (with-syncing
    (query-message socket query)
    (flush-message socket)
    (force-output socket)
    (message-case socket
      ;; Ignore the field formats because we're only supporting plain
      ;; text for now
      (#\G (read-uint1 socket)
	   (skip-bytes socket (* 2 (read-uint2 socket)))))))

(defun initialize-copier (self)
  (let* ((query (copy-query self))
	 (connection (copier-database self))
	 (socket (connection-socket connection)))
    (with-reconnect-restart connection
      (using-connection connection
	(send-copy-start socket query)))))


(defun copier-write-value (s val)
  (typecase val
    (string (let ((pg-string (with-output-to-string (str)
                               (loop for byte across (cl-postgres-trivial-utf-8:string-to-utf-8-bytes val) do
                                    (case (code-char byte)
                                      (#\Space (princ " " str))
                                      ((#\Newline #\Tab) (format str "\\~a" (code-char byte)))
                                      (#\\ (progn (princ #\\ str) (princ #\\ str)))
                                      (otherwise (if (and (< 32 byte)
                                                          (> 127 byte))
                                                     (write-char (code-char byte) str)
                                                     (princ (format nil "\\~o" byte) str))))))))
              #+nil(print `(:loading ,pg-string))
              (princ pg-string s)))
    (number (princ val s))
    (null (princ "false" s))
    (symbol (case val
              (:null (princ "\\N" s))
              ((t) (princ "true" s))
              (otherwise (error "copier-write-val: Symbols shouldn't be getting this far ~a" val))))))

(defun copier-write-sequence (s vector)
  (write-char #\{ s)
  (loop for (item . more-p) on (coerce vector 'list)
     do (cond
          ((null item) (copier-write-value s :null))
          ((atom item) (copier-write-value s item))
          (t (copier-write-sequence s item)))
     when more-p
     do (write-char #\, s))
  (write-char #\} s))

(defmethod prepare-row (self row)
  (declare (ignore self))
  (with-output-to-string (s)
    (loop for (val . more-p) on row
		   do (progn
            (if (typep val '(or string
                             (not vector)))
                (copier-write-value s val)
                (copier-write-sequence s val)))
		   if more-p do (write-char #\Tab s)
		   finally
         (write-char #\Newline s))))

(defun send-copy-done (socket)
  (with-syncing
    (setf sync-sent t)
    (copy-done-message socket)
    (force-output socket)
    (message-case socket
      (#\C (let* ((command-tag (read-str socket))
		  (space (position #\Space command-tag :from-end t)))
	     (when space
	       (parse-integer command-tag :junk-allowed t :start (1+ space))))))
    (block find-ready
      (loop (message-case socket
              (#\Z (read-uint1 socket)
                   (return-from find-ready))
              (t :skip))))))


#+END_SRC

* Cl-Ppcre-1.2.3
** [[/Users/Can/Develop/Lisp/document/pcl/code/libraries/cl-ppcre-1.2.3/util.lisp][util]]
#+BEGIN_SRC lisp 
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-PPCRE; Base: 10 -*-
;;; $Header: /usr/local/cvsrep/cl-ppcre/util.lisp,v 1.27 2005/01/24 14:06:38 edi Exp $

;;; Utility functions and constants dealing with the hash-tables
;;; we use to encode character classes

;;; Hash-tables are treated like sets, i.e. a character C is a member of the
;;; hash-table H iff (GETHASH C H) is true.

;;; Copyright (c) 2002-2004, Dr. Edmund Weitz. All rights reserved.

;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:

;;;   * Redistributions of source code must retain the above copyright
;;;     notice, this list of conditions and the following disclaimer.

;;;   * Redistributions in binary form must reproduce the above
;;;     copyright notice, this list of conditions and the following
;;;     disclaimer in the documentation and/or other materials
;;;     provided with the distribution.

;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

(in-package #:cl-ppcre)

(defmacro with-unique-names ((&rest bindings) &body body)
  "Syntax: WITH-UNIQUE-NAMES ( { var | (var x) }* ) declaration* form*

Executes a series of forms with each VAR bound to a fresh,
uninterned symbol. The uninterned symbol is as if returned by a call
to GENSYM with the string denoted by X - or, if X is not supplied, the
string denoted by VAR - as argument.

The variable bindings created are lexical unless special declarations
are specified. The scopes of the name bindings and declarations do not
include the Xs.

The forms are evaluated in order, and the values of all but the last
are discarded \(that is, the body is an implicit PROGN)."
  ;; reference implementation posted to comp.lang.lisp as
  ;; <cy3bshuf30f.fsf@ljosa.com> by Vebjorn Ljosa - see also
  ;; <http://www.cliki.net/Common%20Lisp%20Utilities>
  `(let ,(mapcar #'(lambda (binding)
                     (check-type binding (or cons symbol))
                     (if (consp binding)
                       (destructuring-bind (var x) binding
                         (check-type var symbol)
                         `(,var (gensym ,(etypecase x
                                          (symbol (symbol-name x))
                                          (character (string x))
                                          (string x)))))
                       `(,binding (gensym ,(symbol-name binding)))))
                 bindings)
         ,@body))

(defmacro with-rebinding (bindings &body body)
  "WITH-REBINDING ( { var | (var prefix) }* ) form*

Evaluates a series of forms in the lexical environment that is
formed by adding the binding of each VAR to a fresh, uninterned
symbol, and the binding of that fresh, uninterned symbol to VAR's
original value, i.e., its value in the current lexical environment.

The uninterned symbol is created as if by a call to GENSYM with the
string denoted by PREFIX - or, if PREFIX is not supplied, the string
denoted by VAR - as argument.

The forms are evaluated in order, and the values of all but the last
are discarded \(that is, the body is an implicit PROGN)."
  ;; reference implementation posted to comp.lang.lisp as
  ;; <cy3wv0fya0p.fsf@ljosa.com> by Vebjorn Ljosa - see also
  ;; <http://www.cliki.net/Common%20Lisp%20Utilities>
  (loop for binding in bindings
        for var = (if (consp binding) (car binding) binding)
        for name = (gensym)
        collect `(,name ,var) into renames
        collect ``(,,var ,,name) into temps
        finally (return `(let ,renames
                          (with-unique-names ,bindings
                            `(let (,,@temps)
                              ,,@body))))))

(eval-when (:compile-toplevel :execute :load-toplevel)
  (defvar *regex-char-code-limit* char-code-limit
    "The upper exclusive bound on the char-codes of characters
which can occur in character classes.
Change this value BEFORE creating scanners if you don't need
the full Unicode support of LW, ACL, or CLISP.")
  (declaim (type fixnum *regex-char-code-limit*))
  
  (defun make-char-hash (test)
    (declare (optimize speed space))
    "Returns a hash-table of all characters satisfying test."
    (loop with hash = (make-hash-table)
          for c of-type fixnum from 0 below char-code-limit
          for chr = (code-char c)
          if (and chr (funcall test chr))
            do (setf (gethash chr hash) t)
          finally (return hash)))

  (declaim (inline word-char-p))
  
  (defun word-char-p (chr)
    (declare (optimize speed
                       (safety 0)
                       (space 0)
                       (debug 0)
                       (compilation-speed 0)
                       #+:lispworks (hcl:fixnum-safety 0)))
    "Tests whether a character is a \"word\" character.
In the ASCII charset this is equivalent to a-z, A-Z, 0-9, or _,
i.e. the same as Perl's [\\w]."
    (or (alphanumericp chr)
        (char= chr #\_)))

  (unless (boundp '+whitespace-char-string+)
    (defconstant +whitespace-char-string+
      (coerce
       '(#\Space #\Tab #\Linefeed #\Return #\Page)
       'string)
      "A string of all characters which are considered to be whitespace.
Same as Perl's [\\s]."))

  (defun whitespacep (chr)
    (declare (optimize speed space))
    "Tests whether a character is whitespace,
i.e. whether it would match [\\s] in Perl."
    (find chr +whitespace-char-string+ :test #'char=)))

;; the following DEFCONSTANT statements are wrapped with
;; (UNLESS (BOUNDP ...) ...) to make SBCL happy

(unless (boundp '+digit-hash+)
  (defconstant +digit-hash+
    (make-char-hash (lambda (chr) (char<= #\0 chr #\9)))
    "Hash-table containing the digits from 0 to 9."))

(unless (boundp '+word-char-hash+)
  (defconstant +word-char-hash+
    (make-char-hash #'word-char-p)
    "Hash-table containing all \"word\" characters."))

(unless (boundp '+whitespace-char-hash+)
  (defconstant +whitespace-char-hash+
    (make-char-hash #'whitespacep)
    "Hash-table containing all whitespace characters."))

(defun merge-hash (hash1 hash2)
  (declare (optimize speed
                     (safety 0)
                     (space 0)
                     (debug 0)
                     (compilation-speed 0)
                     #+:lispworks (hcl:fixnum-safety 0)))
  "Returns the \"sum\" of two hashes. This is a destructive operation
on HASH1."
  (cond ((> (hash-table-count hash2)
            *regex-char-code-limit*)
          ;; don't walk through, e.g., the whole +WORD-CHAR-HASH+ if
          ;; the user has set *REGEX-CHAR-CODE-LIMIT* to a lower value
          (loop for c of-type fixnum from 0 below *regex-char-code-limit*
                for chr = (code-char c)
                if (and chr (gethash chr hash2))
                do (setf (gethash chr hash1) t)))
        (t
          (loop for chr being the hash-keys of hash2
                do (setf (gethash chr hash1) t))))
  hash1)

(defun merge-inverted-hash (hash1 hash2)
  (declare (optimize speed
                     (safety 0)
                     (space 0)
                     (debug 0)
                     (compilation-speed 0)
                     #+:lispworks (hcl:fixnum-safety 0)))
  "Returns the \"sum\" of HASH1 and the \"inverse\" of HASH2. This is
a destructive operation on HASH1."
  (loop for c of-type fixnum from 0 below *regex-char-code-limit*
        for chr = (code-char c)
        if (and chr (not (gethash chr hash2)))
          do (setf (gethash chr hash1) t))
  hash1)

(defun create-ranges-from-hash (hash &key downcasep)
  (declare (optimize speed
                     (safety 0)
                     (space 0)
                     (debug 0)
                     (compilation-speed 0)
                     #+:lispworks (hcl:fixnum-safety 0)))
  "Tries to identify up to three intervals (with respect to CHAR<)
which together comprise HASH. Returns NIL if this is not possible.
If DOWNCASEP is true it will treat the hash-table as if it represents
both the lower-case and the upper-case variants of its members and
will only return the respective lower-case intervals."
  ;; discard empty hash-tables
  (unless (and hash (plusp (hash-table-count hash)))
    (return-from create-ranges-from-hash nil))
  (loop with min1 and min2 and min3
        and max1 and max2 and max3
        ;; loop through all characters in HASH, sorted by CHAR<
        for chr in (sort (the list
                           (loop for chr being the hash-keys of hash
                                 collect (if downcasep
                                           (char-downcase chr)
                                           chr)))
		         #'char<)
        for code = (char-code chr)
        ;; MIN1, MAX1, etc. are _exclusive_
        ;; bounds of the intervals identified so far
        do (cond
             ((not min1)
               ;; this will only happen once, for the first character
               (setq min1 (1- code)
                     max1 (1+ code)))
             ((<= (the fixnum min1) code (the fixnum max1))
               ;; we're here as long as CHR fits into the first interval
               (setq min1 (min (the fixnum min1) (1- code))
                     max1 (max (the fixnum max1) (1+ code))))
             ((not min2)
               ;; we need to open a second interval
               ;; this'll also happen only once
               (setq min2 (1- code)
                     max2 (1+ code)))
             ((<= (the fixnum min2) code (the fixnum max2))
               ;; CHR fits into the second interval
               (setq min2 (min (the fixnum min2) (1- code))
                     max2 (max (the fixnum max2) (1+ code))))
             ((not min3)
               ;; we need to open the third interval
               ;; happens only once
               (setq min3 (1- code)
                     max3 (1+ code)))
             ((<= (the fixnum min3) code (the fixnum max3))
               ;; CHR fits into the third interval
               (setq min3 (min (the fixnum min3) (1- code))
                     max3 (max (the fixnum max3) (1+ code))))
             (t
               ;; we're out of luck, CHR doesn't fit
               ;; into one of the three intervals
               (return nil)))
        ;; on success return all bounds
        ;; make them inclusive bounds before returning
        finally (return (values (code-char (1+ min1))
                                (code-char (1- max1))
                                (and min2 (code-char (1+ min2)))
                                (and max2 (code-char (1- max2)))
                                (and min3 (code-char (1+ min3)))
                                (and max3 (code-char (1- max3)))))))

(defmacro maybe-coerce-to-simple-string (string)
  (with-unique-names (=string=)
    `(let ((,=string= ,string))
      (cond ((simple-string-p ,=string=)
              ,=string=)
            (t
              (coerce ,=string= 'simple-string))))))

(declaim (inline nsubseq))
(defun nsubseq (sequence start &optional (end (length sequence)))
  "Return a subsequence by pointing to location in original sequence."
  (make-array (- end start)
              :element-type (array-element-type sequence)
              :displaced-to sequence
              :displaced-index-offset start))

(defun normalize-var-list (var-list)
  "Utility function for REGISTER-GROUPS-BIND and
DO-REGISTER-GROUPS. Creates the long form \(a list of \(FUNCTION VAR)
entries) out of the short form of VAR-LIST."
  (loop for element in var-list
        if (consp element)
          nconc (loop for var in (rest element)
                      collect (list (first element) var))
        else
          collect (list '(function identity) element)))

(defun string-list-to-simple-string (string-list)
  (declare (optimize speed
                     (safety 0)
                     (space 0)
                     (debug 0)
                     (compilation-speed 0)
                     #+:lispworks (hcl:fixnum-safety 0)))
  "Concatenates a list of strings to one simple-string."
  ;; this function provided by JP Massar; note that we can't use APPLY
  ;; with CONCATENATE here because of CALL-ARGUMENTS-LIMIT
  (let ((total-size 0))
    (declare (type fixnum total-size))
    (dolist (string string-list)
      #-genera (declare (type string string))
      (incf total-size (length string)))
    (let ((result-string (make-sequence 'simple-string total-size))
          (curr-pos 0))
      (declare (type fixnum curr-pos))
      (dolist (string string-list)
        #-genera (declare (type string string))
        (replace result-string string :start1 curr-pos)
        (incf curr-pos (length string)))
      result-string)))

#+END_SRC

** [[/Users/Can/Develop/Lisp/document/pcl/code/libraries/cl-ppcre-1.2.3/specials.lisp][specials]]
#+BEGIN_SRC lisp 
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-PPCRE; Base: 10 -*-
;;; $Header: /usr/local/cvsrep/cl-ppcre/specials.lisp,v 1.19 2004/04/22 18:50:16 edi Exp $

;;; globally declared special variables

;;; Copyright (c) 2002-2004, Dr. Edmund Weitz. All rights reserved.

;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:

;;;   * Redistributions of source code must retain the above copyright
;;;     notice, this list of conditions and the following disclaimer.

;;;   * Redistributions in binary form must reproduce the above
;;;     copyright notice, this list of conditions and the following
;;;     disclaimer in the documentation and/or other materials
;;;     provided with the distribution.

;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

(in-package #:cl-ppcre)

;;; special variables used by the lexer/parser combo

(defvar *extended-mode-p* nil
  "Whether the parser will start in extended mode.")
(declaim (type boolean *extended-mode-p*))

;;; special variables used by the SCAN function and the matchers

(defvar *string* ""
  "The string which is currently scanned by SCAN.
Will always be coerced to a SIMPLE-STRING.")
(declaim (type simple-string *string*))

(defvar *start-pos* 0
  "Where to start scanning within *STRING*.")
(declaim (type fixnum *start-pos*))

(defvar *real-start-pos* nil
  "The real start of *STRING*. This is for repeated scans and is only used internally.")
(declaim (type (or null fixnum) *real-start-pos*))

(defvar *end-pos* 0
  "Where to stop scanning within *STRING*.")
(declaim (type fixnum *end-pos*))

(defvar *reg-starts* (make-array 0)
  "An array which holds the start positions
of the current register candidates.")
(declaim (type simple-vector *reg-starts*))
  
(defvar *regs-maybe-start* (make-array 0)
  "An array which holds the next start positions
of the current register candidates.")
(declaim (type simple-vector *regs-maybe-start*))

(defvar *reg-ends* (make-array 0)
  "An array which holds the end positions
of the current register candidates.")
(declaim (type simple-vector *reg-ends*))

(defvar *end-string-pos* nil
  "Start of the next possible end-string candidate.")

(defvar *rep-num* 0
  "Counts the number of \"complicated\" repetitions while the matchers
are built.")
(declaim (type fixnum *rep-num*))

(defvar *zero-length-num* 0
  "Counts the number of repetitions the inner regexes of which may
have zero-length while the matchers are built.")
(declaim (type fixnum *zero-length-num*))

(defvar *repeat-counters* (make-array 0
                                      :initial-element 0
                                      :element-type 'fixnum)
  "An array to keep track of how often
repetitive patterns have been tested already.")
(declaim (type (array fixnum (*)) *repeat-counters*))

(defvar *last-pos-stores* (make-array 0)
  "An array to keep track of the last positions
where we saw repetitive patterns.
Only used for patterns which might have zero length.")
(declaim (type simple-vector *last-pos-stores*))

(defvar *use-bmh-matchers* t
  "Whether the scanners created by CREATE-SCANNER should use the \(fast
but large) Boyer-Moore-Horspool matchers.")

(defvar *allow-quoting* nil
  "Whether the parser should support Perl's \\Q and \\E.")

(pushnew :cl-ppcre *features*)

;; stuff for Nikodemus Siivola's HYPERDOC
;; see <http://common-lisp.net/project/hyperdoc/>
;; and <http://www.cliki.net/hyperdoc>

(defvar *hyperdoc-base-uri* "http://weitz.de/cl-ppcre/")

(let ((exported-symbols-alist
       (loop for symbol being the external-symbols of :cl-ppcre
             collect (cons symbol
                           (concatenate 'string
                                        "#"
                                        (string-downcase symbol))))))
  (defun hyperdoc-lookup (symbol type)
    (declare (ignore type))
    (cdr (assoc symbol
                exported-symbols-alist
                :test #'eq))))
               
#+END_SRC

** [[/Users/Can/Develop/Lisp/document/pcl/code/libraries/cl-ppcre-1.2.3/scanner.lisp][scanner]]
#+BEGIN_SRC lisp 
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-PPCRE; Base: 10 -*-
;;; $Header: /usr/local/cvsrep/cl-ppcre/scanner.lisp,v 1.22 2004/12/09 09:23:37 edi Exp $

;;; Here the scanner for the actual regex as well as utility scanners
;;; for the constant start and end strings are created.

;;; Copyright (c) 2002-2004, Dr. Edmund Weitz. All rights reserved.

;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:

;;;   * Redistributions of source code must retain the above copyright
;;;     notice, this list of conditions and the following disclaimer.

;;;   * Redistributions in binary form must reproduce the above
;;;     copyright notice, this list of conditions and the following
;;;     disclaimer in the documentation and/or other materials
;;;     provided with the distribution.

;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

(in-package #:cl-ppcre)

(defmacro bmh-matcher-aux (&key case-insensitive-p)
  "Auxiliary macro used by CREATE-BMH-MATCHER."
  (let ((char-compare (if case-insensitive-p 'char-equal 'char=)))
    `(lambda (start-pos)
      (declare (type fixnum start-pos))
      (if (or (minusp start-pos)
              (> (the fixnum (+ start-pos m)) *end-pos*))
        nil
        (loop named bmh-matcher
              for k of-type fixnum = (+ start-pos m -1)
                then (+ k (max 1 (aref skip (char-code (schar *string* k)))))
              while (< k *end-pos*)
              do (loop for j of-type fixnum downfrom (1- m)
                       for i of-type fixnum downfrom k
                       while (and (>= j 0)
                                  (,char-compare (schar *string* i)
                                                 (schar pattern j)))
                       finally (if (minusp j)
                                 (return-from bmh-matcher (1+ i)))))))))

(defun create-bmh-matcher (pattern case-insensitive-p)
  (declare (optimize speed
                     (safety 0)
                     (space 0)
                     (debug 0)
                     (compilation-speed 0)
                     #+:lispworks (hcl:fixnum-safety 0)))
  "Returns a Boyer-Moore-Horspool matcher which searches the (special)
simple-string *STRING* for the first occurence of the substring
PATTERN. The search starts at the position START-POS within *STRING*
and stops before *END-POS* is reached. Depending on the second
argument the search is case-insensitive or not. If the special
variable *USE-BMH-MATCHERS* is NIL, use the standard SEARCH function
instead. (BMH matchers are faster but need much more space.)"
  ;; see <http://www-igm.univ-mlv.fr/~lecroq/string/node18.html> for
  ;; details
  (unless *use-bmh-matchers*
    (let ((test (if case-insensitive-p #'char-equal #'char=)))
      (return-from create-bmh-matcher
        (lambda (start-pos)
          (declare (type fixnum start-pos))
          (and (not (minusp start-pos))
               (search pattern
                       *string*
                       :start2 start-pos
                       :end2 *end-pos*
                       :test test))))))
  (let* ((m (length pattern))
	 (skip (make-array *regex-char-code-limit*
			  :element-type 'fixnum
			  :initial-element m)))
    (declare (type fixnum m))
    (loop for k of-type fixnum below m
          if case-insensitive-p
            do (setf (aref skip (char-code (char-upcase (schar pattern k)))) (- m k 1)
                     (aref skip (char-code (char-downcase (schar pattern k)))) (- m k 1))
	  else
	    do (setf (aref skip (char-code (schar pattern k))) (- m k 1)))
    (if case-insensitive-p
      (bmh-matcher-aux :case-insensitive-p t)
      (bmh-matcher-aux))))

(defmacro char-searcher-aux (&key case-insensitive-p)
  "Auxiliary macro used by CREATE-CHAR-SEARCHER."
  (let ((char-compare (if case-insensitive-p 'char-equal 'char=)))
    `(lambda (start-pos)
      (declare (type fixnum start-pos))
      (loop for i of-type fixnum from start-pos below *end-pos*
            thereis (and (,char-compare (schar *string* i) chr) i)))))

(defun create-char-searcher (chr case-insensitive-p)
  (declare (optimize speed
                     (safety 0)
                     (space 0)
                     (debug 0)
                     (compilation-speed 0)
                     #+:lispworks (hcl:fixnum-safety 0)))
  "Returns a function which searches the (special) simple-string
*STRING* for the first occurence of the character CHR. The search
starts at the position START-POS within *STRING* and stops before
*END-POS* is reached. Depending on the second argument the search is
case-insensitive or not."
  (if case-insensitive-p
    (char-searcher-aux :case-insensitive-p t)
    (char-searcher-aux)))

(declaim (inline newline-skipper))

(defun newline-skipper (start-pos)
  (declare (optimize speed
                     (safety 0)
                     (space 0)
                     (debug 0)
                     (compilation-speed 0)
                     #+:lispworks (hcl:fixnum-safety 0)))
  (declare (type fixnum start-pos))
  "Find the next occurence of a character in *STRING* which is behind
a #\Newline."
  ;; we can start with (1- START-POS) without testing for (PLUSP
  ;; START-POS) because we know we'll never call NEWLINE-SKIPPER on
  ;; the first iteration
  (loop for i of-type fixnum from (1- start-pos) below *end-pos*
        thereis (and (char= (schar *string* i)
                            #\Newline)
                     (1+ i))))

(defmacro insert-advance-fn (advance-fn)
  "Creates the actual closure returned by CREATE-SCANNER-AUX by
replacing '(ADVANCE-FN-DEFINITION) with a suitable definition for
ADVANCE-FN. This is a utility macro used by CREATE-SCANNER-AUX."
  (subst
   advance-fn '(advance-fn-definition)
   '(lambda (string start end)
     (block scan
       ;; initialize a couple of special variables used by the
       ;; matchers (see file specials.lisp)
       (let* ((*string* string)
              (*start-pos* start)
              (*end-pos* end)
              ;; we will search forward for END-STRING if this value
              ;; isn't at least as big as POS (see ADVANCE-FN), so it
              ;; is safe to start to the left of *START-POS*; note
              ;; that this value will _never_ be decremented - this
              ;; is crucial to the scanning process
              (*end-string-pos* (1- *start-pos*))
              ;; the next five will shadow the variables defined by
              ;; DEFPARAMETER; at this point, we don't know if we'll
              ;; actually use them, though
              (*repeat-counters* *repeat-counters*)
              (*last-pos-stores* *last-pos-stores*)
              (*reg-starts* *reg-starts*)
              (*regs-maybe-start* *regs-maybe-start*)
              (*reg-ends* *reg-ends*)
              ;; we might be able to optimize the scanning process by
              ;; (virtually) shifting *START-POS* to the right
              (scan-start-pos *start-pos*)
              (starts-with-str (if start-string-test
                                 (str starts-with)
                                 nil))
              ;; we don't need to try further than MAX-END-POS
              (max-end-pos (- *end-pos* min-len)))
         (declare (type fixnum scan-start-pos)
                  (type function match-fn))
         ;; definition of ADVANCE-FN will be inserted here by macrology
         (labels ((advance-fn-definition))
           (declare (inline advance-fn))
           (when (plusp rep-num)
             ;; we have at least one REPETITION which needs to count
             ;; the number of repetitions
             (setq *repeat-counters* (make-array rep-num
                                                 :initial-element 0
                                                 :element-type 'fixnum)))
           (when (plusp zero-length-num)
             ;; we have at least one REPETITION which needs to watch
             ;; out for zero-length repetitions
             (setq *last-pos-stores* (make-array zero-length-num
                                                 :initial-element nil)))
           (when (plusp reg-num)
             ;; we have registers in our regular expression
             (setq *reg-starts* (make-array reg-num :initial-element nil)
                   *regs-maybe-start* (make-array reg-num :initial-element nil)
                   *reg-ends* (make-array reg-num :initial-element nil)))
           (when end-anchored-p
             ;; the regular expression has a constant end string which
             ;; is anchored at the very end of the target string
             ;; (perhaps modulo a #\Newline)
             (let ((end-test-pos (- *end-pos* (the fixnum end-string-len))))
               (declare (type fixnum end-test-pos)
                        (type function end-string-test))
               (unless (setq *end-string-pos* (funcall end-string-test
                                                       end-test-pos))
                 (when (and (= 1 (the fixnum end-anchored-p))
                            (> *end-pos* scan-start-pos)
                            (char= #\Newline (schar *string* (1- *end-pos*))))
                   ;; if we didn't find an end string candidate from
                   ;; END-TEST-POS and if a #\Newline at the end is
                   ;; allowed we try it again from one position to the
                   ;; left
                   (setq *end-string-pos* (funcall end-string-test
                                                   (1- end-test-pos))))))
             (unless (and *end-string-pos*
                          (<= *start-pos* *end-string-pos*))
               ;; no end string candidate found, so give up
               (return-from scan nil))
             (when end-string-offset
               ;; if the offset of the constant end string from the
               ;; left of the regular expression is known we can start
               ;; scanning further to the right; this is similar to
               ;; what we might do in ADVANCE-FN
               (setq scan-start-pos (max scan-start-pos
                                         (- (the fixnum *end-string-pos*)
                                            (the fixnum end-string-offset))))))
             (cond
               (start-anchored-p
                 ;; we're anchored at the start of the target string,
                 ;; so no need to try again after first failure
                 (when (or (/= *start-pos* scan-start-pos)
                           (< max-end-pos *start-pos*))
                   ;; if END-STRING-OFFSET has proven that we don't
                   ;; need to bother to scan from *START-POS* or if the
                   ;; minimal length of the regular expression is
                   ;; longer than the target string we give up
                   (return-from scan nil))
                 (when starts-with-str
                   (locally
                     (declare (type fixnum starts-with-len))
                     (cond ((and (case-insensitive-p starts-with)
                                 (not (*string*-equal starts-with-str
                                                      *start-pos*
                                                      (+ *start-pos*
                                                         starts-with-len)
                                                      0 starts-with-len)))
                             ;; the regular expression has a
                             ;; case-insensitive constant start string
                             ;; and we didn't find it
                             (return-from scan nil))
                           ((and (not (case-insensitive-p starts-with))
                                 (not (*string*= starts-with-str
                                            *start-pos*
                                            (+ *start-pos* starts-with-len)
                                            0 starts-with-len)))
                             ;; the regular expression has a
                             ;; case-sensitive constant start string
                             ;; and we didn't find it
                             (return-from scan nil))
                           (t nil))))
                 (when (and end-string-test
                            (not end-anchored-p))
                   ;; the regular expression has a constant end string
                   ;; which isn't anchored so we didn't check for it
                   ;; already
                   (block end-string-loop
                     ;; we temporarily use *END-STRING-POS* as our
                     ;; starting position to look for end string
                     ;; candidates
                     (setq *end-string-pos* *start-pos*)
                     (loop
                       (unless (setq *end-string-pos*
                                       (funcall (the function end-string-test)
                                                *end-string-pos*))
                         ;; no end string candidate found, so give up
                         (return-from scan nil))
                       (unless end-string-offset
                         ;; end string doesn't have an offset so we
                         ;; can start scanning now
                         (return-from end-string-loop))
                       (let ((maybe-start-pos (- (the fixnum *end-string-pos*)
                                                 (the fixnum end-string-offset))))
                         (cond ((= maybe-start-pos *start-pos*)
                                 ;; offset of end string into regular
                                 ;; expression matches start anchor -
                                 ;; fine...
                                 (return-from end-string-loop))
                               ((and (< maybe-start-pos *start-pos*)
                                     (< (+ *end-string-pos* end-string-len) *end-pos*))
                                 ;; no match but maybe we find another
                                 ;; one to the right - try again
                                 (incf *end-string-pos*))
                               (t
                                 ;; otherwise give up
                                 (return-from scan nil)))))))
                 ;; if we got here we scan exactly once
                 (let ((next-pos (funcall match-fn *start-pos*)))
                   (when next-pos
                     (values (if next-pos *start-pos* nil)
                             next-pos
                             *reg-starts*
                             *reg-ends*))))
               (t
                 (loop for pos = (if starts-with-everything
                                   ;; don't jump to the next
                                   ;; #\Newline on the first
                                   ;; iteration
                                   scan-start-pos
                                   (advance-fn scan-start-pos))
                           then (advance-fn pos)
                       ;; give up if the regular expression can't fit
                       ;; into the rest of the target string
                       while (and pos
                                  (<= (the fixnum pos) max-end-pos))
                       do (let ((next-pos (funcall match-fn pos)))
                            (when next-pos
                              (return-from scan (values pos
                                                        next-pos
                                                        *reg-starts*
                                                        *reg-ends*)))
                            ;; not yet found, increment POS
                            #-cormanlisp (incf (the fixnum pos))
                            #+cormanlisp (incf pos)))))))))
    :test #'equalp))

(defun create-scanner-aux (match-fn
                           min-len
                           start-anchored-p
                           starts-with
                           start-string-test
                           end-anchored-p
                           end-string-test
                           end-string-len
                           end-string-offset
                           rep-num
                           zero-length-num
                           reg-num)
  (declare (optimize speed
                     (safety 0)
                     (space 0)
                     (debug 0)
                     (compilation-speed 0)
                     #+:lispworks (hcl:fixnum-safety 0)))
  (declare (type fixnum min-len zero-length-num rep-num reg-num))
  "Auxiliary function to create and return a scanner \(which is
actually a closure). Used by CREATE-SCANNER."
  (let ((starts-with-len (if (typep starts-with 'str)
                           (len starts-with)))
        (starts-with-everything (typep starts-with 'everything)))
    (cond
      ;; this COND statement dispatches on the different versions we
      ;; have for ADVANCE-FN and creates different closures for each;
      ;; note that you see only the bodies of ADVANCE-FN below - the
      ;; actual scanner is defined in INSERT-ADVANCE-FN above; (we
      ;; could have done this with closures instead of macrology but
      ;; would have consed a lot more)
      ((and start-string-test end-string-test end-string-offset)
        ;; we know that the regular expression has constant start and
        ;; end strings and we know the end string's offset (from the
        ;; left)
        (insert-advance-fn
          (advance-fn (pos)
            (declare (type fixnum end-string-offset starts-with-len)
                     (type function start-string-test end-string-test))
            (loop
              (unless (setq pos (funcall start-string-test pos))
                ;; give up completely if we can't find a start string
                ;; candidate
                (return-from scan nil))
              (locally
                ;; from here we know that POS is a FIXNUM
                (declare (type fixnum pos))
                (when (= pos (- (the fixnum *end-string-pos*) end-string-offset))
                  ;; if we already found an end string candidate the
                  ;; position of which matches the start string
                  ;; candidate we're done
                  (return-from advance-fn pos))
                (let ((try-pos (+ pos starts-with-len)))
                  ;; otherwise try (again) to find an end string
                  ;; candidate which starts behind the start string
                  ;; candidate
                  (loop
                    (unless (setq *end-string-pos*
                                    (funcall end-string-test try-pos))
                      ;; no end string candidate found, so give up
                      (return-from scan nil))
                    ;; NEW-POS is where we should start scanning
                    ;; according to the end string candidate
                    (let ((new-pos (- (the fixnum *end-string-pos*)
                                      end-string-offset)))
                      (declare (type fixnum new-pos *end-string-pos*))
                      (cond ((= new-pos pos)
                              ;; if POS and NEW-POS are equal then the
                              ;; two candidates agree so we're fine
                              (return-from advance-fn pos))
                            ((> new-pos pos)
                              ;; if NEW-POS is further to the right we
                              ;; advance POS and try again, i.e. we go
                              ;; back to the start of the outer LOOP
                              (setq pos new-pos)
                              ;; this means "return from inner LOOP"
                              (return))
                            (t
                              ;; otherwise NEW-POS is smaller than POS,
                              ;; so we have to redo the inner LOOP to
                              ;; find another end string candidate
                              ;; further to the right
                              (setq try-pos (1+ *end-string-pos*))))))))))))
      ((and starts-with-everything end-string-test end-string-offset)
        ;; we know that the regular expression starts with ".*" (which
        ;; is not in single-line-mode, see CREATE-SCANNER-AUX) and ends
        ;; with a constant end string and we know the end string's
        ;; offset (from the left)
        (insert-advance-fn
          (advance-fn (pos)
            (declare (type fixnum end-string-offset)
                     (type function end-string-test))
            (loop
              (unless (setq pos (newline-skipper pos))
                ;; if we can't find a #\Newline we give up immediately
                (return-from scan nil))
              (locally
                ;; from here we know that POS is a FIXNUM
                (declare (type fixnum pos))
                (when (= pos (- (the fixnum *end-string-pos*) end-string-offset))
                  ;; if we already found an end string candidate the
                  ;; position of which matches the place behind the
                  ;; #\Newline we're done
                  (return-from advance-fn pos))
                (let ((try-pos pos))
                  ;; otherwise try (again) to find an end string
                  ;; candidate which starts behind the #\Newline
                  (loop
                    (unless (setq *end-string-pos*
                                    (funcall end-string-test try-pos))
                      ;; no end string candidate found, so we give up
                      (return-from scan nil))
                    ;; NEW-POS is where we should start scanning
                    ;; according to the end string candidate
                    (let ((new-pos (- (the fixnum *end-string-pos*)
                                      end-string-offset)))
                      (declare (type fixnum new-pos *end-string-pos*))
                      (cond ((= new-pos pos)
                              ;; if POS and NEW-POS are equal then the
                              ;; the end string candidate agrees with
                              ;; the #\Newline so we're fine
                              (return-from advance-fn pos))
                            ((> new-pos pos)
                              ;; if NEW-POS is further to the right we
                              ;; advance POS and try again, i.e. we go
                              ;; back to the start of the outer LOOP
                              (setq pos new-pos)
                              ;; this means "return from inner LOOP"
                              (return))
                            (t
                              ;; otherwise NEW-POS is smaller than POS,
                              ;; so we have to redo the inner LOOP to
                              ;; find another end string candidate
                              ;; further to the right
                              (setq try-pos (1+ *end-string-pos*))))))))))))
      ((and start-string-test end-string-test)
        ;; we know that the regular expression has constant start and
        ;; end strings; similar to the first case but we only need to
        ;; check for the end string, it doesn't provide enough
        ;; information to advance POS
        (insert-advance-fn
          (advance-fn (pos)
            (declare (type function start-string-test end-string-test))
            (unless (setq pos (funcall start-string-test pos))
              (return-from scan nil))
            (if (<= (the fixnum pos)
                    (the fixnum *end-string-pos*))
              (return-from advance-fn pos))
            (unless (setq *end-string-pos* (funcall end-string-test pos))
              (return-from scan nil))
            pos)))
      ((and starts-with-everything end-string-test)
        ;; we know that the regular expression starts with ".*" (which
        ;; is not in single-line-mode, see CREATE-SCANNER-AUX) and ends
        ;; with a constant end string; similar to the second case but we
        ;; only need to check for the end string, it doesn't provide
        ;; enough information to advance POS
        (insert-advance-fn
          (advance-fn (pos)
            (declare (type function end-string-test))
            (unless (setq pos (newline-skipper pos))
              (return-from scan nil))
            (if (<= (the fixnum pos)
                    (the fixnum *end-string-pos*))
              (return-from advance-fn pos))
            (unless (setq *end-string-pos* (funcall end-string-test pos))
              (return-from scan nil))
            pos)))
      (start-string-test
        ;; just check for constant start string candidate
        (insert-advance-fn
          (advance-fn (pos)
            (declare (type function start-string-test))
            (unless (setq pos (funcall start-string-test pos))
              (return-from scan nil))
            pos)))
      (starts-with-everything
        ;; just advance POS with NEWLINE-SKIPPER
        (insert-advance-fn
          (advance-fn (pos)
            (unless (setq pos (newline-skipper pos))
              (return-from scan nil))
            pos)))
      (end-string-test
        ;; just check for the next end string candidate if POS has
        ;; advanced beyond the last one
        (insert-advance-fn
          (advance-fn (pos)
            (declare (type function end-string-test))
            (if (<= (the fixnum pos)
                    (the fixnum *end-string-pos*))
              (return-from advance-fn pos))
            (unless (setq *end-string-pos* (funcall end-string-test pos))
              (return-from scan nil))
            pos)))
      (t
        ;; not enough optimization information about the regular
        ;; expression to optimize so we just return POS
        (insert-advance-fn
          (advance-fn (pos)
            pos))))))
#+END_SRC

** [[/Users/Can/Develop/Lisp/document/pcl/code/libraries/cl-ppcre-1.2.3/repetition-closures.lisp][repetition-closures]]
#+BEGIN_SRC lisp 
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-PPCRE; Base: 10 -*-
;;; $Header: /usr/local/cvsrep/cl-ppcre/repetition-closures.lisp,v 1.20 2004/04/20 11:37:36 edi Exp $

;;; This is actually a part of closures.lisp which we put into a
;;; separate file because it is rather complex. We only deal with
;;; REPETITIONs here. Note that this part of the code contains some
;;; rather crazy micro-optimizations which were introduced to be as
;;; competitive with Perl as possible in tight loops.

;;; Copyright (c) 2002-2004, Dr. Edmund Weitz. All rights reserved.

;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:

;;;   * Redistributions of source code must retain the above copyright
;;;     notice, this list of conditions and the following disclaimer.

;;;   * Redistributions in binary form must reproduce the above
;;;     copyright notice, this list of conditions and the following
;;;     disclaimer in the documentation and/or other materials
;;;     provided with the distribution.

;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

(in-package #:cl-ppcre)

(defmacro incf-after (place &optional (delta 1) &environment env)
  "Utility macro inspired by C's \"place++\", i.e. first return the
value of PLACE and afterwards increment it by DELTA."
  (with-unique-names (%temp)
    (multiple-value-bind (vars vals store-vars writer-form reader-form)
        (get-setf-expansion place env)
      `(let* (,@(mapcar #'list vars vals)
              (,%temp ,reader-form)
              (,(car store-vars) (+ ,%temp ,delta)))
        ,writer-form
        ,%temp))))

;; code for greedy repetitions with minimum zero

(defmacro greedy-constant-length-closure (check-curr-pos)
  "This is the template for simple greedy repetitions (where simple
means that the minimum number of repetitions is zero, that the inner
regex to be checked is of fixed length LEN, and that it doesn't
contain registers, i.e. there's no need for backtracking).
CHECK-CURR-POS is a form which checks whether the inner regex of the
repetition matches at CURR-POS."
  `(if maximum
    (lambda (start-pos)
      (declare (type fixnum start-pos maximum))
      ;; because we know LEN we know in advance where to stop at the
      ;; latest; we also take into consideration MIN-REST, i.e. the
      ;; minimal length of the part behind the repetition
      (let ((target-end-pos (min (1+ (- *end-pos* len min-rest))
                                 ;; don't go further than MAXIMUM
                                 ;; repetitions, of course
                                 (+ start-pos
                                    (the fixnum (* len maximum)))))
            (curr-pos start-pos))
        (declare (type fixnum target-end-pos curr-pos))
        (block greedy-constant-length-matcher
          ;; we use an ugly TAGBODY construct because this might be a
          ;; tight loop and this version is a bit faster than our LOOP
          ;; version (at least in CMUCL)
          (tagbody
            forward-loop
            ;; first go forward as far as possible, i.e. while
            ;; the inner regex matches
            (when (>= curr-pos target-end-pos)
              (go backward-loop))
            (when ,check-curr-pos
              (incf curr-pos len)
              (go forward-loop))
            backward-loop
            ;; now go back LEN steps each until we're able to match
            ;; the rest of the regex
            (when (< curr-pos start-pos)
              (return-from greedy-constant-length-matcher nil))
            (let ((result (funcall next-fn curr-pos)))
              (when result
                (return-from greedy-constant-length-matcher result)))
            (decf curr-pos len)
            (go backward-loop)))))
    ;; basically the same code; it's just a bit easier because we're
    ;; not bounded by MAXIMUM
    (lambda (start-pos)
      (declare (type fixnum start-pos))
      (let ((target-end-pos (1+ (- *end-pos* len min-rest)))
            (curr-pos start-pos))
        (declare (type fixnum target-end-pos curr-pos))
        (block greedy-constant-length-matcher
          (tagbody
            forward-loop
            (when (>= curr-pos target-end-pos)
              (go backward-loop))
            (when ,check-curr-pos
              (incf curr-pos len)
              (go forward-loop))
            backward-loop
            (when (< curr-pos start-pos)
              (return-from greedy-constant-length-matcher nil))
            (let ((result (funcall next-fn curr-pos)))
              (when result
                (return-from greedy-constant-length-matcher result)))
            (decf curr-pos len)
            (go backward-loop)))))))

(defun create-greedy-everything-matcher (maximum min-rest next-fn)
  (declare (optimize speed
                     (safety 0)
                     (space 0)
                     (debug 0)
                     (compilation-speed 0)
                     #+:lispworks (hcl:fixnum-safety 0)))
  (declare (type fixnum min-rest)
           (type function next-fn))
  "Creates a closure which just matches as far ahead as possible,
i.e. a closure for a dot in single-line mode."
  (if maximum
    (lambda (start-pos)
      (declare (type fixnum start-pos maximum))
      ;; because we know LEN we know in advance where to stop at the
      ;; latest; we also take into consideration MIN-REST, i.e. the
      ;; minimal length of the part behind the repetition
      (let ((target-end-pos (min (+ start-pos maximum)
                                 (- *end-pos* min-rest))))
        (declare (type fixnum target-end-pos))
        ;; start from the highest possible position and go backward
        ;; until we're able to match the rest of the regex
        (loop for curr-pos of-type fixnum from target-end-pos downto start-pos
              thereis (funcall next-fn curr-pos))))
    ;; basically the same code; it's just a bit easier because we're
    ;; not bounded by MAXIMUM
    (lambda (start-pos)
      (declare (type fixnum start-pos))
      (let ((target-end-pos (- *end-pos* min-rest)))
        (declare (type fixnum target-end-pos))
        (loop for curr-pos of-type fixnum from target-end-pos downto start-pos
              thereis (funcall next-fn curr-pos))))))

(defmethod create-greedy-constant-length-matcher ((repetition repetition)
                                                  next-fn)
  (declare (optimize speed
                     (safety 0)
                     (space 0)
                     (debug 0)
                     (compilation-speed 0)
                     #+:lispworks (hcl:fixnum-safety 0)))
  "Creates a closure which tries to match REPETITION. It is assumed
that REPETITION is greedy and the minimal number of repetitions is
zero. It is furthermore assumed that the inner regex of REPETITION is
of fixed length and doesn't contain registers."
  (let ((len (len repetition))
        (maximum (maximum repetition))
        (regex (regex repetition))
        (min-rest (min-rest repetition)))
    (declare (type fixnum len min-rest)
             (type function next-fn))
    (cond ((zerop len)
            ;; inner regex has zero-length, so we can discard it
            ;; completely
            next-fn)
          (t
            ;; now first try to optimize for a couple of common cases
            (typecase regex
              (str
                (let ((str (str regex)))
                  (if (= 1 len)
                    ;; a single character
                    (let ((chr (schar str 0)))
                      (if (case-insensitive-p regex)
                        (greedy-constant-length-closure
                         (char-equal chr (schar *string* curr-pos)))
                        (greedy-constant-length-closure
                         (char= chr (schar *string* curr-pos)))))
                    ;; a string
                    (if (case-insensitive-p regex)
                      (greedy-constant-length-closure
                       (*string*-equal str curr-pos (+ curr-pos len) 0 len))
                      (greedy-constant-length-closure
                       (*string*= str curr-pos (+ curr-pos len) 0 len))))))
              (char-class
                ;; a character class
                (insert-char-class-tester (regex (schar *string* curr-pos))
                  (if (invertedp regex)
                    (greedy-constant-length-closure
                     (not (char-class-test)))
                    (greedy-constant-length-closure
                     (char-class-test)))))
              (everything
                ;; an EVERYTHING object, i.e. a dot
                (if (single-line-p regex)
                  (create-greedy-everything-matcher maximum min-rest next-fn)
                  (greedy-constant-length-closure
                   (char/= #\Newline (schar *string* curr-pos)))))
              (t
                ;; the general case - we build an inner matcher which
                ;; just checks for immediate success, i.e. NEXT-FN is
                ;; #'IDENTITY
                (let ((inner-matcher (create-matcher-aux regex #'identity)))
                  (declare (type function inner-matcher))
                  (greedy-constant-length-closure
                   (funcall inner-matcher curr-pos)))))))))
  
(defmethod create-greedy-no-zero-matcher ((repetition repetition) next-fn)
  (declare (optimize speed
                     (safety 0)
                     (space 0)
                     (debug 0)
                     (compilation-speed 0)
                     #+:lispworks (hcl:fixnum-safety 0)))
  "Creates a closure which tries to match REPETITION. It is assumed
that REPETITION is greedy and the minimal number of repetitions is
zero. It is furthermore assumed that the inner regex of REPETITION can
never match a zero-length string (or instead the maximal number of
repetitions is 1)."
  (let ((maximum (maximum repetition))
        ;; REPEAT-MATCHER is part of the closure's environment but it
        ;; can only be defined after GREEDY-AUX is defined
        repeat-matcher)
    (declare (type function next-fn))
    (cond
      ((eql maximum 1)
        ;; this is essentially like the next case but with a known
        ;; MAXIMUM of 1 we can get away without a counter; note that
        ;; we always arrive here if CONVERT optimizes <regex>* to
        ;; (?:<regex'>*<regex>)?
        (setq repeat-matcher
                (create-matcher-aux (regex repetition) next-fn))
        (lambda (start-pos)
          (declare (type function repeat-matcher))
          (or (funcall repeat-matcher start-pos)
              (funcall next-fn start-pos))))
      (maximum
        ;; we make a reservation for our slot in *REPEAT-COUNTERS*
        ;; because we need to keep track whether we've reached MAXIMUM
        ;; repetitions
        (let ((rep-num (incf-after *rep-num*)))
          (flet ((greedy-aux (start-pos)
                   (declare (type fixnum start-pos maximum rep-num)
                            (type function repeat-matcher))
                   ;; the actual matcher which first tries to match the
                   ;; inner regex of REPETITION (if we haven't done so
                   ;; too often) and on failure calls NEXT-FN
                   (or (and (< (aref *repeat-counters* rep-num) maximum)
                            (incf (aref *repeat-counters* rep-num))
                            ;; note that REPEAT-MATCHER will call
                            ;; GREEDY-AUX again recursively
                            (prog1
                              (funcall repeat-matcher start-pos)
                              (decf (aref *repeat-counters* rep-num))))
                       (funcall next-fn start-pos))))
            ;; create a closure to match the inner regex and to
            ;; implement backtracking via GREEDY-AUX
            (setq repeat-matcher
                    (create-matcher-aux (regex repetition) #'greedy-aux))
            ;; the closure we return is just a thin wrapper around
            ;; GREEDY-AUX to initialize the repetition counter
            (lambda (start-pos)
              (declare (type fixnum start-pos))
              (setf (aref *repeat-counters* rep-num) 0)
              (greedy-aux start-pos)))))
      (t
        ;; easier code because we're not bounded by MAXIMUM, but
        ;; basically the same
        (flet ((greedy-aux (start-pos)
                 (declare (type fixnum start-pos)
                          (type function repeat-matcher))
                 (or (funcall repeat-matcher start-pos)
                     (funcall next-fn start-pos))))
          (setq repeat-matcher
                  (create-matcher-aux (regex repetition) #'greedy-aux))
          #'greedy-aux)))))

(defmethod create-greedy-matcher ((repetition repetition) next-fn)
  (declare (optimize speed
                     (safety 0)
                     (space 0)
                     (debug 0)
                     (compilation-speed 0)
                     #+:lispworks (hcl:fixnum-safety 0)))
  "Creates a closure which tries to match REPETITION. It is assumed
that REPETITION is greedy and the minimal number of repetitions is
zero."
  (let ((maximum (maximum repetition))
        ;; we make a reservation for our slot in *LAST-POS-STORES* because
        ;; we have to watch out for endless loops as the inner regex might
        ;; match zero-length strings
        (zero-length-num (incf-after *zero-length-num*))
        ;; REPEAT-MATCHER is part of the closure's environment but it
        ;; can only be defined after GREEDY-AUX is defined
        repeat-matcher)
    (declare (type fixnum zero-length-num)
             (type function next-fn))
    (cond
      (maximum
        ;; we make a reservation for our slot in *REPEAT-COUNTERS*
        ;; because we need to keep track whether we've reached MAXIMUM
        ;; repetitions
        (let ((rep-num (incf-after *rep-num*)))
          (flet ((greedy-aux (start-pos)
                   ;; the actual matcher which first tries to match the
                   ;; inner regex of REPETITION (if we haven't done so
                   ;; too often) and on failure calls NEXT-FN
                   (declare (type fixnum start-pos maximum rep-num)
                            (type function repeat-matcher))
                   (let ((old-last-pos
                           (svref *last-pos-stores* zero-length-num)))
                     (when (and old-last-pos
                                (= (the fixnum old-last-pos) start-pos))
                       ;; stop immediately if we've been here before,
                       ;; i.e. if the last attempt matched a zero-length
                       ;; string
                       (return-from greedy-aux (funcall next-fn start-pos)))
                     ;; otherwise remember this position for the next
                     ;; repetition
                     (setf (svref *last-pos-stores* zero-length-num) start-pos)
                     (or (and (< (aref *repeat-counters* rep-num) maximum)
                              (incf (aref *repeat-counters* rep-num))
                              ;; note that REPEAT-MATCHER will call
                              ;; GREEDY-AUX again recursively
                              (prog1
                                (funcall repeat-matcher start-pos)
                                (decf (aref *repeat-counters* rep-num))
                                (setf (svref *last-pos-stores* zero-length-num)
                                        old-last-pos)))
                         (funcall next-fn start-pos)))))
            ;; create a closure to match the inner regex and to
            ;; implement backtracking via GREEDY-AUX
            (setq repeat-matcher
                    (create-matcher-aux (regex repetition) #'greedy-aux))
            ;; the closure we return is just a thin wrapper around
            ;; GREEDY-AUX to initialize the repetition counter and our
            ;; slot in *LAST-POS-STORES*
            (lambda (start-pos)
              (declare (type fixnum start-pos))
              (setf (aref *repeat-counters* rep-num) 0
                    (svref *last-pos-stores* zero-length-num) nil)
              (greedy-aux start-pos)))))
      (t
        ;; easier code because we're not bounded by MAXIMUM, but
        ;; basically the same
        (flet ((greedy-aux (start-pos)
                 (declare (type fixnum start-pos)
                          (type function repeat-matcher))
                 (let ((old-last-pos
                         (svref *last-pos-stores* zero-length-num)))
                   (when (and old-last-pos
                              (= (the fixnum old-last-pos) start-pos))
                     (return-from greedy-aux (funcall next-fn start-pos)))
                   (setf (svref *last-pos-stores* zero-length-num) start-pos)
                   (or (prog1
                         (funcall repeat-matcher start-pos)
                         (setf (svref *last-pos-stores* zero-length-num) old-last-pos))
                       (funcall next-fn start-pos)))))
          (setq repeat-matcher
                  (create-matcher-aux (regex repetition) #'greedy-aux))
          (lambda (start-pos)
            (declare (type fixnum start-pos))
            (setf (svref *last-pos-stores* zero-length-num) nil)
            (greedy-aux start-pos)))))))
  
;; code for non-greedy repetitions with minimum zero

(defmacro non-greedy-constant-length-closure (check-curr-pos)
  "This is the template for simple non-greedy repetitions (where
simple means that the minimum number of repetitions is zero, that the
inner regex to be checked is of fixed length LEN, and that it doesn't
contain registers, i.e. there's no need for backtracking).
CHECK-CURR-POS is a form which checks whether the inner regex of the
repetition matches at CURR-POS."
  `(if maximum
    (lambda (start-pos)
      (declare (type fixnum start-pos maximum))
      ;; because we know LEN we know in advance where to stop at the
      ;; latest; we also take into consideration MIN-REST, i.e. the
      ;; minimal length of the part behind the repetition
      (let ((target-end-pos (min (1+ (- *end-pos* len min-rest))
                                 (+ start-pos
                                    (the fixnum (* len maximum))))))
        ;; move forward by LEN and always try NEXT-FN first, then
        ;; CHECK-CUR-POS
        (loop for curr-pos of-type fixnum from start-pos
                                          below target-end-pos
                                          by len
              thereis (funcall next-fn curr-pos)
              while ,check-curr-pos
              finally (return (funcall next-fn curr-pos)))))
  ;; basically the same code; it's just a bit easier because we're
  ;; not bounded by MAXIMUM
  (lambda (start-pos)
    (declare (type fixnum start-pos))
    (let ((target-end-pos (1+ (- *end-pos* len min-rest))))
      (loop for curr-pos of-type fixnum from start-pos
                                        below target-end-pos
                                        by len
            thereis (funcall next-fn curr-pos)
            while ,check-curr-pos
            finally (return (funcall next-fn curr-pos)))))))

(defmethod create-non-greedy-constant-length-matcher ((repetition repetition) next-fn)
  (declare (optimize speed
                     (safety 0)
                     (space 0)
                     (debug 0)
                     (compilation-speed 0)
                     #+:lispworks (hcl:fixnum-safety 0)))
  "Creates a closure which tries to match REPETITION. It is assumed
that REPETITION is non-greedy and the minimal number of repetitions is
zero. It is furthermore assumed that the inner regex of REPETITION is
of fixed length and doesn't contain registers."
  (let ((len (len repetition))
        (maximum (maximum repetition))
        (regex (regex repetition))
        (min-rest (min-rest repetition)))
    (declare (type fixnum len min-rest)
             (type function next-fn))
    (cond ((zerop len)
            ;; inner regex has zero-length, so we can discard it
            ;; completely
            next-fn)
          (t
            ;; now first try to optimize for a couple of common cases
            (typecase regex
              (str
                (let ((str (str regex)))
                  (if (= 1 len)
                    ;; a single character
                    (let ((chr (schar str 0)))
                      (if (case-insensitive-p regex)
                        (non-greedy-constant-length-closure
                         (char-equal chr (schar *string* curr-pos)))
                        (non-greedy-constant-length-closure
                         (char= chr (schar *string* curr-pos)))))
                    ;; a string
                    (if (case-insensitive-p regex)
                      (non-greedy-constant-length-closure
                       (*string*-equal str curr-pos (+ curr-pos len) 0 len))
                      (non-greedy-constant-length-closure
                       (*string*= str curr-pos (+ curr-pos len) 0 len))))))
              (char-class
                ;; a character class
                (insert-char-class-tester (regex (schar *string* curr-pos))
                  (if (invertedp regex)
                    (non-greedy-constant-length-closure
                     (not (char-class-test)))
                    (non-greedy-constant-length-closure
                     (char-class-test)))))
              (everything
                (if (single-line-p regex)
                  ;; a dot which really can match everything; we rely
                  ;; on the compiler to optimize this away
                  (non-greedy-constant-length-closure
                   t)
                  ;; a dot which has to watch out for #\Newline
                  (non-greedy-constant-length-closure
                   (char/= #\Newline (schar *string* curr-pos)))))
              (t
                ;; the general case - we build an inner matcher which
                ;; just checks for immediate success, i.e. NEXT-FN is
                ;; #'IDENTITY
                (let ((inner-matcher (create-matcher-aux regex #'identity)))
                  (declare (type function inner-matcher))
                  (non-greedy-constant-length-closure
                   (funcall inner-matcher curr-pos)))))))))

(defmethod create-non-greedy-no-zero-matcher ((repetition repetition) next-fn)
  (declare (optimize speed
                     (safety 0)
                     (space 0)
                     (debug 0)
                     (compilation-speed 0)
                     #+:lispworks (hcl:fixnum-safety 0)))
  "Creates a closure which tries to match REPETITION. It is assumed
that REPETITION is non-greedy and the minimal number of repetitions is
zero. It is furthermore assumed that the inner regex of REPETITION can
never match a zero-length string (or instead the maximal number of
repetitions is 1)."
  (let ((maximum (maximum repetition))
        ;; REPEAT-MATCHER is part of the closure's environment but it
        ;; can only be defined after NON-GREEDY-AUX is defined
        repeat-matcher)
    (declare (type function next-fn))
    (cond
      ((eql maximum 1)
        ;; this is essentially like the next case but with a known
        ;; MAXIMUM of 1 we can get away without a counter
        (setq repeat-matcher
                (create-matcher-aux (regex repetition) next-fn))
        (lambda (start-pos)
          (declare (type function repeat-matcher))
          (or (funcall next-fn start-pos)
              (funcall repeat-matcher start-pos))))
      (maximum
        ;; we make a reservation for our slot in *REPEAT-COUNTERS*
        ;; because we need to keep track whether we've reached MAXIMUM
        ;; repetitions
        (let ((rep-num (incf-after *rep-num*)))
          (flet ((non-greedy-aux (start-pos)
                   ;; the actual matcher which first calls NEXT-FN and
                   ;; on failure tries to match the inner regex of
                   ;; REPETITION (if we haven't done so too often)
                   (declare (type fixnum start-pos maximum rep-num)
                            (type function repeat-matcher))
                   (or (funcall next-fn start-pos)
                       (and (< (aref *repeat-counters* rep-num) maximum)
                            (incf (aref *repeat-counters* rep-num))
                            ;; note that REPEAT-MATCHER will call
                            ;; NON-GREEDY-AUX again recursively
                            (prog1
                              (funcall repeat-matcher start-pos)
                              (decf (aref *repeat-counters* rep-num)))))))
            ;; create a closure to match the inner regex and to
            ;; implement backtracking via NON-GREEDY-AUX
            (setq repeat-matcher
                    (create-matcher-aux (regex repetition) #'non-greedy-aux))
            ;; the closure we return is just a thin wrapper around
            ;; NON-GREEDY-AUX to initialize the repetition counter
            (lambda (start-pos)
              (declare (type fixnum start-pos))
              (setf (aref *repeat-counters* rep-num) 0)
              (non-greedy-aux start-pos)))))
      (t
        ;; easier code because we're not bounded by MAXIMUM, but
        ;; basically the same
        (flet ((non-greedy-aux (start-pos)
                 (declare (type fixnum start-pos)
                          (type function repeat-matcher))
                 (or (funcall next-fn start-pos)
                     (funcall repeat-matcher start-pos))))
          (setq repeat-matcher
                  (create-matcher-aux (regex repetition) #'non-greedy-aux))
          #'non-greedy-aux)))))
  
(defmethod create-non-greedy-matcher ((repetition repetition) next-fn)
  (declare (optimize speed
                     (safety 0)
                     (space 0)
                     (debug 0)
                     (compilation-speed 0)
                     #+:lispworks (hcl:fixnum-safety 0)))
  "Creates a closure which tries to match REPETITION. It is assumed
that REPETITION is non-greedy and the minimal number of repetitions is
zero."
  ;; we make a reservation for our slot in *LAST-POS-STORES* because
  ;; we have to watch out for endless loops as the inner regex might
  ;; match zero-length strings
  (let ((zero-length-num (incf-after *zero-length-num*))
        (maximum (maximum repetition))
        ;; REPEAT-MATCHER is part of the closure's environment but it
        ;; can only be defined after NON-GREEDY-AUX is defined
        repeat-matcher)
    (declare (type fixnum zero-length-num)
             (type function next-fn))
    (cond
      (maximum
        ;; we make a reservation for our slot in *REPEAT-COUNTERS*
        ;; because we need to keep track whether we've reached MAXIMUM
        ;; repetitions
        (let ((rep-num (incf-after *rep-num*)))
          (flet ((non-greedy-aux (start-pos)
                   ;; the actual matcher which first calls NEXT-FN and
                   ;; on failure tries to match the inner regex of
                   ;; REPETITION (if we haven't done so too often)
                   (declare (type fixnum start-pos maximum rep-num)
                            (type function repeat-matcher))
                   (let ((old-last-pos
                           (svref *last-pos-stores* zero-length-num)))
                     (when (and old-last-pos
                                (= (the fixnum old-last-pos) start-pos))
                       ;; stop immediately if we've been here before,
                       ;; i.e. if the last attempt matched a zero-length
                       ;; string
                       (return-from non-greedy-aux (funcall next-fn start-pos)))
                     ;; otherwise remember this position for the next
                     ;; repetition
                     (setf (svref *last-pos-stores* zero-length-num) start-pos)
                     (or (funcall next-fn start-pos)
                         (and (< (aref *repeat-counters* rep-num) maximum)
                              (incf (aref *repeat-counters* rep-num))
                              ;; note that REPEAT-MATCHER will call
                              ;; NON-GREEDY-AUX again recursively
                              (prog1
                                (funcall repeat-matcher start-pos)
                                (decf (aref *repeat-counters* rep-num))
                                (setf (svref *last-pos-stores* zero-length-num)
                                        old-last-pos)))))))
            ;; create a closure to match the inner regex and to
            ;; implement backtracking via NON-GREEDY-AUX
            (setq repeat-matcher
                    (create-matcher-aux (regex repetition) #'non-greedy-aux))
            ;; the closure we return is just a thin wrapper around
            ;; NON-GREEDY-AUX to initialize the repetition counter and our
            ;; slot in *LAST-POS-STORES*
            (lambda (start-pos)
              (declare (type fixnum start-pos))
              (setf (aref *repeat-counters* rep-num) 0
                    (svref *last-pos-stores* zero-length-num) nil)
              (non-greedy-aux start-pos)))))
      (t
        ;; easier code because we're not bounded by MAXIMUM, but
        ;; basically the same
        (flet ((non-greedy-aux (start-pos)
                 (declare (type fixnum start-pos)
                          (type function repeat-matcher))
                 (let ((old-last-pos
                         (svref *last-pos-stores* zero-length-num)))
                   (when (and old-last-pos
                              (= (the fixnum old-last-pos) start-pos))
                     (return-from non-greedy-aux (funcall next-fn start-pos)))
                   (setf (svref *last-pos-stores* zero-length-num) start-pos)
                   (or (funcall next-fn start-pos)
                       (prog1
                         (funcall repeat-matcher start-pos)
                         (setf (svref *last-pos-stores* zero-length-num)
                                 old-last-pos))))))
          (setq repeat-matcher
                  (create-matcher-aux (regex repetition) #'non-greedy-aux))
          (lambda (start-pos)
            (declare (type fixnum start-pos))
            (setf (svref *last-pos-stores* zero-length-num) nil)
            (non-greedy-aux start-pos)))))))
  
;; code for constant repetitions, i.e. those with a fixed number of repetitions
                      
(defmacro constant-repetition-constant-length-closure (check-curr-pos)
  "This is the template for simple constant repetitions (where simple
means that the inner regex to be checked is of fixed length LEN, and
that it doesn't contain registers, i.e. there's no need for
backtracking) and where constant means that MINIMUM is equal to
MAXIMUM. CHECK-CURR-POS is a form which checks whether the inner regex
of the repetition matches at CURR-POS."
  `(lambda (start-pos)
    (declare (type fixnum start-pos))
      (let ((target-end-pos (+ start-pos
                               (the fixnum (* len repetitions)))))
        (declare (type fixnum target-end-pos))
        ;; first check if we won't go beyond the end of the string
        (and (>= *end-pos* target-end-pos)
             ;; then loop through all repetitions step by step
             (loop for curr-pos of-type fixnum from start-pos
                                               below target-end-pos
                                               by len
                   always ,check-curr-pos)
             ;; finally call NEXT-FN if we made it that far
             (funcall next-fn target-end-pos)))))

(defmethod create-constant-repetition-constant-length-matcher
       ((repetition repetition) next-fn)
  (declare (optimize speed
                     (safety 0)
                     (space 0)
                     (debug 0)
                     (compilation-speed 0)
                     #+:lispworks (hcl:fixnum-safety 0)))
  "Creates a closure which tries to match REPETITION. It is assumed
that REPETITION has a constant number of repetitions. It is
furthermore assumed that the inner regex of REPETITION is of fixed
length and doesn't contain registers."
  (let ((len (len repetition))
        (repetitions (minimum repetition))
        (regex (regex repetition)))
    (declare (type fixnum len repetitions)
             (type function next-fn))
    (if (zerop len)
      ;; if the length is zero it suffices to try once
      (create-matcher-aux regex next-fn)
      ;; otherwise try to optimize for a couple of common cases
      (typecase regex
        (str
          (let ((str (str regex)))
            (if (= 1 len)
              ;; a single character
              (let ((chr (schar str 0)))
                (if (case-insensitive-p regex)
                  (constant-repetition-constant-length-closure
                   (and (char-equal chr (schar *string* curr-pos))
                        (1+ curr-pos)))
                  (constant-repetition-constant-length-closure
                   (and (char= chr (schar *string* curr-pos))
                        (1+ curr-pos)))))
              ;; a string
              (if (case-insensitive-p regex)
                (constant-repetition-constant-length-closure
                 (let ((next-pos (+ curr-pos len)))
                   (declare (type fixnum next-pos))
                   (and (*string*-equal str curr-pos next-pos 0 len)
                        next-pos)))
                (constant-repetition-constant-length-closure
                 (let ((next-pos (+ curr-pos len)))
                   (declare (type fixnum next-pos))
                   (and (*string*= str curr-pos next-pos 0 len)
                        next-pos)))))))
        (char-class
          ;; a character class
          (insert-char-class-tester (regex (schar *string* curr-pos))
            (if (invertedp regex)
              (constant-repetition-constant-length-closure
               (and (not (char-class-test))
                    (1+ curr-pos)))
              (constant-repetition-constant-length-closure
               (and (char-class-test)
                    (1+ curr-pos))))))
        (everything
          (if (single-line-p regex)
            ;; a dot which really matches everything - we just have to
            ;; advance the index into *STRING* accordingly and check
            ;; if we didn't go past the end
            (lambda (start-pos)
              (declare (type fixnum start-pos))
              (let ((next-pos (+ start-pos repetitions)))
                (declare (type fixnum next-pos))
                (and (<= next-pos *end-pos*)
                     (funcall next-fn next-pos))))
            ;; a dot which is not in single-line-mode - make sure we
            ;; don't match #\Newline
            (constant-repetition-constant-length-closure
             (and (char/= #\Newline (schar *string* curr-pos))
                  (1+ curr-pos)))))
        (t
          ;; the general case - we build an inner matcher which just
          ;; checks for immediate success, i.e. NEXT-FN is #'IDENTITY
          (let ((inner-matcher (create-matcher-aux regex #'identity)))
            (declare (type function inner-matcher))
            (constant-repetition-constant-length-closure
             (funcall inner-matcher curr-pos))))))))
  
(defmethod create-constant-repetition-matcher ((repetition repetition) next-fn)
  (declare (optimize speed
                     (safety 0)
                     (space 0)
                     (debug 0)
                     (compilation-speed 0)
                     #+:lispworks (hcl:fixnum-safety 0)))
  "Creates a closure which tries to match REPETITION. It is assumed
that REPETITION has a constant number of repetitions."
  (let ((repetitions (minimum repetition))
        ;; we make a reservation for our slot in *REPEAT-COUNTERS*
        ;; because we need to keep track of the number of repetitions
        (rep-num (incf-after *rep-num*))
        ;; REPEAT-MATCHER is part of the closure's environment but it
        ;; can only be defined after NON-GREEDY-AUX is defined
        repeat-matcher)
    (declare (type fixnum repetitions rep-num)
             (type function next-fn))
    (if (zerop (min-len repetition))
      ;; we make a reservation for our slot in *LAST-POS-STORES*
      ;; because we have to watch out for needless loops as the inner
      ;; regex might match zero-length strings
      (let ((zero-length-num (incf-after *zero-length-num*)))
        (declare (type fixnum zero-length-num))
        (flet ((constant-aux (start-pos)
                 ;; the actual matcher which first calls NEXT-FN and
                 ;; on failure tries to match the inner regex of
                 ;; REPETITION (if we haven't done so too often)
                 (declare (type fixnum start-pos)
                          (type function repeat-matcher))
                 (let ((old-last-pos
                         (svref *last-pos-stores* zero-length-num)))
                   (when (and old-last-pos
                              (= (the fixnum old-last-pos) start-pos))
                     ;; if we've been here before we matched a
                     ;; zero-length string the last time, so we can
                     ;; just carry on because we will definitely be
                     ;; able to do this again often enough
                     (return-from constant-aux (funcall next-fn start-pos)))
                   ;; otherwise remember this position for the next
                   ;; repetition
                   (setf (svref *last-pos-stores* zero-length-num) start-pos)
                   (cond ((< (aref *repeat-counters* rep-num) repetitions)
                           ;; not enough repetitions yet, try it again
                           (incf (aref *repeat-counters* rep-num))
                           ;; note that REPEAT-MATCHER will call
                           ;; CONSTANT-AUX again recursively
                           (prog1
                             (funcall repeat-matcher start-pos)
                             (decf (aref *repeat-counters* rep-num))
                             (setf (svref *last-pos-stores* zero-length-num)
                                     old-last-pos)))
                         (t
                           ;; we're done - call NEXT-FN
                           (funcall next-fn start-pos))))))
          ;; create a closure to match the inner regex and to
          ;; implement backtracking via CONSTANT-AUX
          (setq repeat-matcher
                  (create-matcher-aux (regex repetition) #'constant-aux))
          ;; the closure we return is just a thin wrapper around
          ;; CONSTANT-AUX to initialize the repetition counter
          (lambda (start-pos)
            (declare (type fixnum start-pos))
            (setf (aref *repeat-counters* rep-num) 0
                  (aref *last-pos-stores* zero-length-num) nil)
            (constant-aux start-pos))))
      ;; easier code because we don't have to care about zero-length
      ;; matches but basically the same
      (flet ((constant-aux (start-pos)
               (declare (type fixnum start-pos)
                        (type function repeat-matcher))
               (cond ((< (aref *repeat-counters* rep-num) repetitions)
                       (incf (aref *repeat-counters* rep-num))
                       (prog1
                         (funcall repeat-matcher start-pos)
                         (decf (aref *repeat-counters* rep-num))))
                     (t (funcall next-fn start-pos)))))
        (setq repeat-matcher
                (create-matcher-aux (regex repetition) #'constant-aux))
        (lambda (start-pos)
          (declare (type fixnum start-pos))
          (setf (aref *repeat-counters* rep-num) 0)
          (constant-aux start-pos))))))
  
;; the actual CREATE-MATCHER-AUX method for REPETITION objects which
;; utilizes all the functions and macros defined above

(defmethod create-matcher-aux ((repetition repetition) next-fn)
  (with-slots ((minimum minimum)
               (maximum maximum)
               (len len)
               (min-len min-len)
               (greedyp greedyp)
               (contains-register-p contains-register-p))
      repetition
    (cond ((and maximum
                (zerop maximum))
            ;; this should have been optimized away by CONVERT but just
            ;; in case...
            (error "Got REPETITION with MAXIMUM 0 \(should not happen)"))
          ((and maximum
                (= minimum maximum 1))
            ;; this should have been optimized away by CONVERT but just
            ;; in case...
            (error "Got REPETITION with MAXIMUM 1 and MINIMUM 1 \(should not happen)"))
          ((and (eql minimum maximum)
                len
                (not contains-register-p))
            (create-constant-repetition-constant-length-matcher repetition next-fn))
          ((eql minimum maximum)
            (create-constant-repetition-matcher repetition next-fn))
          ((and greedyp
                len
                (not contains-register-p))
            (create-greedy-constant-length-matcher repetition next-fn))
          ((and greedyp
                (or (plusp min-len)
                    (eql maximum 1)))
            (create-greedy-no-zero-matcher repetition next-fn))
          (greedyp
            (create-greedy-matcher repetition next-fn))
          ((and len
                (plusp len)
                (not contains-register-p))
            (create-non-greedy-constant-length-matcher repetition next-fn))
          ((or (plusp min-len)
               (eql maximum 1))
            (create-non-greedy-no-zero-matcher repetition next-fn))
          (t
            (create-non-greedy-matcher repetition next-fn)))))

#+END_SRC

** [[/Users/Can/Develop/Lisp/document/pcl/code/libraries/cl-ppcre-1.2.3/regex-class.lisp][regex-class]]
#+BEGIN_SRC lisp 
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-PPCRE; Base: 10 -*-
;;; $Header: /usr/local/cvsrep/cl-ppcre/regex-class.lisp,v 1.21 2005/02/02 17:47:38 edi Exp $

;;; This file defines the REGEX class and some utility methods for
;;; this class. REGEX objects are used to represent the (transformed)
;;; parse trees internally

;;; Copyright (c) 2002-2004, Dr. Edmund Weitz. All rights reserved.

;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:

;;;   * Redistributions of source code must retain the above copyright
;;;     notice, this list of conditions and the following disclaimer.

;;;   * Redistributions in binary form must reproduce the above
;;;     copyright notice, this list of conditions and the following
;;;     disclaimer in the documentation and/or other materials
;;;     provided with the distribution.

;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

(in-package #:cl-ppcre)

;; Genera need the eval-when, here, or the types created by the class
;; definitions aren't seen by the typep calls later in the file.
(eval-when (:compile-toplevel :load-toplevel :execute)
  (locally
    (declare (optimize speed
                       (safety 0)
                       (space 0)
                       (debug 0)
                       (compilation-speed 0)
                       #+:lispworks (hcl:fixnum-safety 0)))
    (defclass regex ()
         ()
      (:documentation "The REGEX base class. All other classes inherit
from this one."))


    (defclass seq (regex)
         ((elements :initarg :elements
                    :accessor elements
                    :type cons
                    :documentation "A list of REGEX objects."))
      (:documentation "SEQ objects represents sequences of
regexes. (Like \"ab\" is the sequence of \"a\" and \"b\".)"))

    (defclass alternation (regex)
         ((choices :initarg :choices
                   :accessor choices
                   :type cons
                   :documentation "A list of REGEX objects"))
      (:documentation "ALTERNATION objects represent alternations of
regexes. (Like \"a|b\" ist the alternation of \"a\" or \"b\".)"))

    (defclass lookahead (regex)
         ((regex :initarg :regex
                 :accessor regex
                 :documentation "The REGEX object we're checking.")
          (positivep :initarg :positivep
                     :reader positivep
                     :documentation "Whether this assertion is positive."))
      (:documentation "LOOKAHEAD objects represent look-ahead assertions."))

    (defclass lookbehind (regex)
         ((regex :initarg :regex
                 :accessor regex
                 :documentation "The REGEX object we're checking.")
          (positivep :initarg :positivep
                     :reader positivep
                     :documentation "Whether this assertion is positive.")
          (len :initarg :len
               :accessor len
               :type fixnum
               :documentation "The (fixed) length of the enclosed regex."))
      (:documentation "LOOKBEHIND objects represent look-behind assertions."))

    (defclass repetition (regex)
         ((regex :initarg :regex
                 :accessor regex
                 :documentation "The REGEX that's repeated.")
          (greedyp :initarg :greedyp
                   :reader greedyp
                   :documentation "Whether the repetition is greedy.")
          (minimum :initarg :minimum
                   :accessor minimum
                   :type fixnum
                   :documentation "The minimal number of repetitions.")
          (maximum :initarg :maximum
                   :accessor maximum
                   :documentation "The maximal number of repetitions.
Can be NIL for unbounded.")
          (min-len :initarg :min-len
                   :reader min-len
                   :documentation "The minimal length of the enclosed regex.")
          (len :initarg :len
               :reader len
               :documentation "The length of the enclosed regex. NIL
if unknown.")
          (min-rest :initform 0
                    :accessor min-rest
                    :type fixnum
                    :documentation "The minimal number of characters which must
appear after this repetition.")
          (contains-register-p :initarg :contains-register-p
                               :reader contains-register-p
                               :documentation "If the regex contains a register."))
      (:documentation "REPETITION objects represent repetitions of regexes."))

    (defclass register (regex)
         ((regex :initarg :regex
                 :accessor regex
                 :documentation "The inner regex.")
          (num :initarg :num
               :reader num
               :type fixnum
               :documentation "The number of this register, starting from 0.
This is the index into *REGS-START* and *REGS-END*."))
      (:documentation "REGISTER objects represent register groups."))

    (defclass standalone (regex)
         ((regex :initarg :regex
                 :accessor regex
                 :documentation "The inner regex."))
      (:documentation "A standalone regular expression."))
  
    (defclass back-reference (regex)
         ((num :initarg :num
               :accessor num
               :type fixnum
               :documentation "The number of the register this
reference refers to.")
          (case-insensitive-p :initarg :case-insensitive-p
                              :reader case-insensitive-p
                              :documentation "Whether we check
case-insensitively."))
      (:documentation "BACK-REFERENCE objects represent backreferences."))

    (defclass char-class (regex)
         ((hash :initarg :hash
                :reader hash
                :type (or hash-table null)
                :documentation "A hash table the keys of which are the
characters; the values are always T.")
          (case-insensitive-p :initarg :case-insensitive-p
                              :reader case-insensitive-p
                              :documentation "If the char class
case-insensitive.")
          (invertedp :initarg :invertedp
                     :reader invertedp
                     :documentation "Whether we mean the inverse of
the char class.")
          (word-char-class-p :initarg :word-char-class-p
                             :reader word-char-class-p
                             :documentation "Whether this CHAR CLASS
represents the special class WORD-CHAR-CLASS."))
      (:documentation "CHAR-CLASS objects represent character classes."))

    (defclass str (regex)
         ((str :initarg :str
               :accessor str
               :type string
               :documentation "The actual string.")
          (len :initform 0
               :accessor len
               :type fixnum
               :documentation "The length of the string.")
          (case-insensitive-p :initarg :case-insensitive-p
                              :reader case-insensitive-p
                              :documentation "If we match case-insensitively.")
          (offset :initform nil
                  :accessor offset
                  :documentation "Offset from the left of the whole
parse tree. The first regex has offset 0. NIL if unknown, i.e. behind
a variable-length regex.")
          (skip :initform nil
                :initarg :skip
                :accessor skip
                :documentation "If we can avoid testing for this
string because the SCAN function has done this already.")
          (start-of-end-string-p :initform nil
                                 :accessor start-of-end-string-p
                                 :documentation "If this is the unique
STR which starts END-STRING (a slot of MATCHER)."))
      (:documentation "STR objects represent string."))

    (defclass anchor (regex)
         ((startp :initarg :startp
                  :reader startp
                  :documentation "Whether this is a \"start anchor\".")
          (multi-line-p :initarg :multi-line-p
                        :reader multi-line-p
                        :documentation "Whether we're in multi-line mode,
i.e. whether each #\\Newline is surrounded by anchors.")
          (no-newline-p :initarg :no-newline-p
                        :reader no-newline-p
                        :documentation "Whether we ignore #\\Newline at the end."))
      (:documentation "ANCHOR objects represent anchors like \"^\" or \"$\"."))

    (defclass everything (regex)
         ((single-line-p :initarg :single-line-p
                         :reader single-line-p
                         :documentation "Whether we're in single-line mode,
i.e. whether we also match #\\Newline."))
      (:documentation "EVERYTHING objects represent regexes matching
\"everything\", i.e. dots."))

    (defclass word-boundary (regex)
         ((negatedp :initarg :negatedp
                    :reader negatedp
                    :documentation "Whether we mean the opposite,
i.e. no word-boundary."))
      (:documentation "WORD-BOUNDARY objects represent word-boundary assertions."))

    (defclass branch (regex)
         ((test :initarg :test
                :accessor test
                :documentation "The test of this branch, one of
LOOKAHEAD, LOOKBEHIND, or a number.")
          (then-regex :initarg :then-regex
                      :accessor then-regex
                      :documentation "The regex that's to be matched if the
test succeeds.")
          (else-regex :initarg :else-regex
                      :initform (make-instance 'void)
                      :accessor else-regex
                      :documentation "The regex that's to be matched if the
test fails."))
      (:documentation "BRANCH objects represent Perl's conditional regular
expressions."))
    
    (defclass filter (regex)
         ((fn :initarg :fn
              :accessor fn
              :type (or function symbol)
              :documentation "The user-defined function.")
          (len :initarg :len
               :reader len
               :documentation "The fixed length of this filter or NIL."))
      (:documentation "FILTER objects represent arbitrary functions
defined by the user."))

    (defclass void (regex)
         ()
      (:documentation "VOID objects represent empty regular expressions."))))

(defmethod initialize-instance :after ((char-class char-class) &rest init-args)
  (declare (optimize speed
                     (safety 0)
                     (space 0)
                     (debug 0)
                     (compilation-speed 0)
                     #+:lispworks (hcl:fixnum-safety 0)))
  "Make large hash tables smaller, if possible."
  (let ((hash (getf init-args :hash)))
    (when (and hash
               (> *regex-char-code-limit* 256)
               (> (hash-table-count hash)
                  (/ *regex-char-code-limit* 2)))
      (setf (slot-value char-class 'hash)
              (merge-inverted-hash (make-hash-table)
                                   hash)
            (slot-value char-class 'invertedp)
              (not (slot-value char-class 'invertedp))))))

(declaim (ftype (function (t) simple-string) str))

;;; The following four methods allow a VOID object to behave like a
;;; zero-length STR object (only readers needed)

(defmethod initialize-instance :after ((str str) &rest init-args)
  (declare (optimize speed
                     (safety 0)
                     (space 0)
                     (debug 0)
                     (compilation-speed 0)
                     #+:lispworks (hcl:fixnum-safety 0)))
  (declare (ignore init-args))
  "Automatically computes the length of a STR after initialization."
  (let ((str-slot (slot-value str 'str)))
    (unless (typep str-slot 'simple-string)
      (setf (slot-value str 'str) (coerce str-slot 'simple-string))))
  (setf (len str) (length (str str))))

(defmethod len ((void void))
  (declare (optimize speed
                     (safety 0)
                     (space 0)
                     (debug 0)
                     (compilation-speed 0)
                     #+:lispworks (hcl:fixnum-safety 0)))
  0)

(defmethod str ((void void))
  (declare (optimize speed
                     (safety 0)
                     (space 0)
                     (debug 0)
                     (compilation-speed 0)
                     #+:lispworks (hcl:fixnum-safety 0)))
  "")

(defmethod skip ((void void))
  (declare (optimize speed
                     (safety 0)
                     (space 0)
                     (debug 0)
                     (compilation-speed 0)
                     #+:lispworks (hcl:fixnum-safety 0)))
  nil)

(defmethod start-of-end-string-p ((void void))
  (declare (optimize speed
                     (safety 0)
                     (space 0)
                     (debug 0)
                     (compilation-speed 0)
                     #+:lispworks (hcl:fixnum-safety 0)))
  nil)

(defgeneric case-mode (regex old-case-mode)
  (declare (optimize speed
                     (safety 0)
                     (space 0)
                     (debug 0)
                     (compilation-speed 0)
                     #+:lispworks (hcl:fixnum-safety 0)))
  (:documentation "Utility function used by the optimizer (see GATHER-STRINGS).
Returns a keyword denoting the case-(in)sensitivity of a STR or its
second argument if the STR has length 0. Returns NIL for REGEX objects
which are not of type STR."))

(defmethod case-mode ((str str) old-case-mode)
  (cond ((zerop (len str))
          old-case-mode)
        ((case-insensitive-p str)
          :case-insensitive)
        (t
          :case-sensitive)))

(defmethod case-mode ((regex regex) old-case-mode)
  (declare (ignore old-case-mode))
  nil)

(defgeneric copy-regex (regex)
  (declare (optimize speed
                     (safety 0)
                     (space 0)
                     (debug 0)
                     (compilation-speed 0)
                     #+:lispworks (hcl:fixnum-safety 0)))
  (:documentation "Implements a deep copy of a REGEX object."))

(defmethod copy-regex ((anchor anchor))
  (make-instance 'anchor
                 :startp (startp anchor)
                 :multi-line-p (multi-line-p anchor)
                 :no-newline-p (no-newline-p anchor)))

(defmethod copy-regex ((everything everything))
  (make-instance 'everything
                 :single-line-p (single-line-p everything)))

(defmethod copy-regex ((word-boundary word-boundary))
  (make-instance 'word-boundary
                 :negatedp (negatedp word-boundary)))

(defmethod copy-regex ((void void))
  (make-instance 'void))

(defmethod copy-regex ((lookahead lookahead))
  (make-instance 'lookahead
                 :regex (copy-regex (regex lookahead))
                 :positivep (positivep lookahead)))

(defmethod copy-regex ((seq seq))
  (make-instance 'seq
                 :elements (mapcar #'copy-regex (elements seq))))

(defmethod copy-regex ((alternation alternation))
  (make-instance 'alternation
                 :choices (mapcar #'copy-regex (choices alternation))))

(defmethod copy-regex ((branch branch))
  (with-slots ((test test))
      branch
    (make-instance 'branch
                   :test (if (typep test 'regex)
                           (copy-regex test)
                           test)
                   :then-regex (copy-regex (then-regex branch))
                   :else-regex (copy-regex (else-regex branch)))))

(defmethod copy-regex ((lookbehind lookbehind))
  (make-instance 'lookbehind
                 :regex (copy-regex (regex lookbehind))
                 :positivep (positivep lookbehind)
                 :len (len lookbehind)))

(defmethod copy-regex ((repetition repetition))
  (make-instance 'repetition
                 :regex (copy-regex (regex repetition))
                 :greedyp (greedyp repetition)
                 :minimum (minimum repetition)
                 :maximum (maximum repetition)
                 :min-len (min-len repetition)
                 :len (len repetition)
                 :contains-register-p (contains-register-p repetition)))

(defmethod copy-regex ((register register))
  (make-instance 'register
                 :regex (copy-regex (regex register))
                 :num (num register)))

(defmethod copy-regex ((standalone standalone))
  (make-instance 'standalone
                 :regex (copy-regex (regex standalone))))

(defmethod copy-regex ((back-reference back-reference))
  (make-instance 'back-reference
                 :num (num back-reference)
                 :case-insensitive-p (case-insensitive-p back-reference)))

(defmethod copy-regex ((char-class char-class))
  (make-instance 'char-class
                 :hash (hash char-class)
                 :case-insensitive-p (case-insensitive-p char-class)
                 :invertedp (invertedp char-class)
                 :word-char-class-p (word-char-class-p char-class)))

(defmethod copy-regex ((str str))
  (make-instance 'str
                 :str (str str)
                 :case-insensitive-p (case-insensitive-p str)))

(defmethod copy-regex ((filter filter))
  (make-instance 'filter
                 :fn (fn filter)
                 :len (len filter)))

;;; Note that COPY-REGEX and REMOVE-REGISTERS could have easily been
;;; wrapped into one function. Maybe in the next release...

;;; Further note that this function is used by CONVERT to factor out
;;; complicated repetitions, i.e. cases like
;;;   (a)* -> (?:a*(a))?
;;; This won't work for, say,
;;;   ((a)|(b))* -> (?:(?:a|b)*((a)|(b)))?
;;; and therefore we stop REGISTER removal once we see an ALTERNATION.

(defgeneric remove-registers (regex)
  (declare (optimize speed
                     (safety 0)
                     (space 0)
                     (debug 0)
                     (compilation-speed 0)
                     #+:lispworks (hcl:fixnum-safety 0)))
  (:documentation "Returns a deep copy of a REGEX (see COPY-REGEX) and
optionally removes embedded REGISTER objects if possible and if the
special variable REMOVE-REGISTERS-P is true."))

(defmethod remove-registers ((register register))
  (declare (special remove-registers-p reg-seen))
  (cond (remove-registers-p
          (remove-registers (regex register)))
        (t
          ;; mark REG-SEEN as true so enclosing REPETITION objects
          ;; (see method below) know if they contain a register or not
          (setq reg-seen t)
          (copy-regex register))))

(defmethod remove-registers ((repetition repetition))
  (let* (reg-seen
         (inner-regex (remove-registers (regex repetition))))
    ;; REMOVE-REGISTERS will set REG-SEEN (see method above) if
    ;; (REGEX REPETITION) contains a REGISTER
    (declare (special reg-seen))
    (make-instance 'repetition
                   :regex inner-regex
                   :greedyp (greedyp repetition)
                   :minimum (minimum repetition)
                   :maximum (maximum repetition)
                   :min-len (min-len repetition)
                   :len (len repetition)
                   :contains-register-p reg-seen)))

(defmethod remove-registers ((standalone standalone))
  (make-instance 'standalone
                 :regex (remove-registers (regex standalone))))

(defmethod remove-registers ((lookahead lookahead))
  (make-instance 'lookahead
                 :regex (remove-registers (regex lookahead))
                 :positivep (positivep lookahead)))

(defmethod remove-registers ((lookbehind lookbehind))
  (make-instance 'lookbehind
                 :regex (remove-registers (regex lookbehind))
                 :positivep (positivep lookbehind)
                 :len (len lookbehind)))

(defmethod remove-registers ((branch branch))
  (with-slots ((test test))
      branch
    (make-instance 'branch
                   :test (if (typep test 'regex)
                           (remove-registers test)
                           test)
                   :then-regex (remove-registers (then-regex branch))
                   :else-regex (remove-registers (else-regex branch)))))

(defmethod remove-registers ((alternation alternation))
  (declare (special remove-registers-p))
  ;; an ALTERNATION, so we can't remove REGISTER objects further down
  (setq remove-registers-p nil)
  (copy-regex alternation))

(defmethod remove-registers ((regex regex))
  (copy-regex regex))

(defmethod remove-registers ((seq seq))
  (make-instance 'seq
                 :elements (mapcar #'remove-registers (elements seq))))

(defgeneric everythingp (regex)
  (declare (optimize speed
                     (safety 0)
                     (space 0)
                     (debug 0)
                     (compilation-speed 0)
                     #+:lispworks (hcl:fixnum-safety 0)))
  (:documentation "Returns an EVERYTHING object if REGEX is equivalent
to this object, otherwise NIL. So, \"(.){1}\" would return true
(i.e. the object corresponding to \".\", for example."))

(defmethod everythingp ((seq seq))
  ;; we might have degenerate cases like (:SEQUENCE :VOID ...)
  ;; due to the parsing process
  (let ((cleaned-elements (remove-if #'(lambda (element)
                                         (typep element 'void))
                                     (elements seq))))
    (and (= 1 (length cleaned-elements))
         (everythingp (first cleaned-elements)))))

(defmethod everythingp ((alternation alternation))
  (with-slots ((choices choices))
      alternation
    (and (= 1 (length choices))
         ;; this is unlikely to happen for human-generated regexes,
         ;; but machine-generated ones might look like this
         (everythingp (first choices)))))

(defmethod everythingp ((repetition repetition))
  (with-slots ((maximum maximum)
               (minimum minimum)
               (regex regex))
      repetition
    (and maximum
         (= 1 minimum maximum)
         ;; treat "<regex>{1,1}" like "<regex>"
         (everythingp regex))))

(defmethod everythingp ((register register))
  (everythingp (regex register)))

(defmethod everythingp ((standalone standalone))
  (everythingp (regex standalone)))

(defmethod everythingp ((everything everything))
  everything)

(defmethod everythingp ((regex regex))
  ;; the general case for ANCHOR, BACK-REFERENCE, BRANCH, CHAR-CLASS,
  ;; LOOKAHEAD, LOOKBEHIND, STR, VOID, FILTER, and WORD-BOUNDARY
  nil)

(defgeneric regex-length (regex)
  (declare (optimize speed
                     (safety 0)
                     (space 0)
                     (debug 0)
                     (compilation-speed 0)
                     #+:lispworks (hcl:fixnum-safety 0)))
  (:documentation "Return the length of REGEX if it is fixed, NIL otherwise."))

(defmethod regex-length ((seq seq))
  ;; simply add all inner lengths unless one of them is NIL
  (loop for sub-regex in (elements seq)
        for len = (regex-length sub-regex)
        if (not len) do (return nil)
        sum len))

(defmethod regex-length ((alternation alternation))
  ;; only return a true value if all inner lengths are non-NIL and
  ;; mutually equal
  (loop for sub-regex in (choices alternation)
        for old-len = nil then len
        for len = (regex-length sub-regex)
        if (or (not len)
               (and old-len (/= len old-len))) do (return nil)
        finally (return len)))

(defmethod regex-length ((branch branch))
  ;; only return a true value if both alternations have a length and
  ;; if they're equal
  (let ((then-length (regex-length (then-regex branch))))
    (and then-length
         (eql then-length (regex-length (else-regex branch)))
         then-length)))

(defmethod regex-length ((repetition repetition))
  ;; we can only compute the length of a REPETITION object if the
  ;; number of repetitions is fixed; note that we don't call
  ;; REGEX-LENGTH for the inner regex, we assume that the LEN slot is
  ;; always set correctly
  (with-slots ((len len)
               (minimum minimum)
               (maximum maximum))
      repetition
    (if (and len
             (eq minimum maximum))
      (* minimum len)
      nil)))

(defmethod regex-length ((register register))
  (regex-length (regex register)))

(defmethod regex-length ((standalone standalone))
  (regex-length (regex standalone)))

(defmethod regex-length ((back-reference back-reference))
  ;; with enough effort we could possibly do better here, but
  ;; currently we just give up and return NIL
  nil)
    
(defmethod regex-length ((char-class char-class))
  1)

(defmethod regex-length ((everything everything))
  1)

(defmethod regex-length ((str str))
  (len str))

(defmethod regex-length ((filter filter))
  (len filter))

(defmethod regex-length ((regex regex))
  ;; the general case for ANCHOR, LOOKAHEAD, LOOKBEHIND, VOID, and
  ;; WORD-BOUNDARY (which all have zero-length)
  0)

(defgeneric regex-min-length (regex)
  (declare (optimize speed
                     (safety 0)
                     (space 0)
                     (debug 0)
                     (compilation-speed 0)
                     #+:lispworks (hcl:fixnum-safety 0)))
  (:documentation "Returns the minimal length of REGEX."))

(defmethod regex-min-length ((seq seq))
  ;; simply add all inner minimal lengths
  (loop for sub-regex in (elements seq)
        for len = (regex-min-length sub-regex)
        sum len))

(defmethod regex-min-length ((alternation alternation))
  ;; minimal length of an alternation is the minimal length of the
  ;; "shortest" element
  (loop for sub-regex in (choices alternation)
        for len = (regex-min-length sub-regex)
        minimize len))

(defmethod regex-min-length ((branch branch))
  ;; minimal length of both alternations
  (min (regex-min-length (then-regex branch))
       (regex-min-length (else-regex branch))))

(defmethod regex-min-length ((repetition repetition))
  ;; obviously the product of the inner minimal length and the minimal
  ;; number of repetitions
  (* (minimum repetition) (min-len repetition)))
    
(defmethod regex-min-length ((register register))
  (regex-min-length (regex register)))
    
(defmethod regex-min-length ((standalone standalone))
  (regex-min-length (regex standalone)))
    
(defmethod regex-min-length ((char-class char-class))
  1)

(defmethod regex-min-length ((everything everything))
  1)

(defmethod regex-min-length ((str str))
  (len str))
    
(defmethod regex-min-length ((filter filter))
  (or (len filter)
      0))

(defmethod regex-min-length ((regex regex))
  ;; the general case for ANCHOR, BACK-REFERENCE, LOOKAHEAD,
  ;; LOOKBEHIND, VOID, and WORD-BOUNDARY
  0)

(defgeneric compute-offsets (regex start-pos)
  (declare (optimize speed
                     (safety 0)
                     (space 0)
                     (debug 0)
                     (compilation-speed 0)
                     #+:lispworks (hcl:fixnum-safety 0)))
  (:documentation "Returns the offset the following regex would have
relative to START-POS or NIL if we can't compute it. Sets the OFFSET
slot of REGEX to START-POS if REGEX is a STR. May also affect OFFSET
slots of STR objects further down the tree."))

;; note that we're actually only interested in the offset of
;; "top-level" STR objects (see ADVANCE-FN in the SCAN function) so we
;; can stop at variable-length alternations and don't need to descend
;; into repetitions

(defmethod compute-offsets ((seq seq) start-pos)
  (loop for element in (elements seq)
        ;; advance offset argument for next call while looping through
        ;; the elements
        for pos = start-pos then curr-offset
        for curr-offset = (compute-offsets element pos)
        while curr-offset
        finally (return curr-offset)))

(defmethod compute-offsets ((alternation alternation) start-pos)
  (loop for choice in (choices alternation)
        for old-offset = nil then curr-offset
        for curr-offset = (compute-offsets choice start-pos)
        ;; we stop immediately if two alternations don't result in the
        ;; same offset
        if (or (not curr-offset)
               (and old-offset (/= curr-offset old-offset)))
          do (return nil)
        finally (return curr-offset)))

(defmethod compute-offsets ((branch branch) start-pos)
  ;; only return offset if both alternations have equal value
  (let ((then-offset (compute-offsets (then-regex branch) start-pos)))
    (and then-offset
         (eql then-offset (compute-offsets (else-regex branch) start-pos))
         then-offset)))

(defmethod compute-offsets ((repetition repetition) start-pos)
  ;; no need to descend into the inner regex
  (with-slots ((len len)
               (minimum minimum)
               (maximum maximum))
      repetition
    (if (and len
             (eq minimum maximum))
      ;; fixed number of repetitions, so we know how to proceed
      (+ start-pos (* minimum len))
      ;; otherwise return NIL
      nil)))

(defmethod compute-offsets ((register register) start-pos)
  (compute-offsets (regex register) start-pos))
    
(defmethod compute-offsets ((standalone standalone) start-pos)
  (compute-offsets (regex standalone) start-pos))
    
(defmethod compute-offsets ((char-class char-class) start-pos)
  (1+ start-pos))
    
(defmethod compute-offsets ((everything everything) start-pos)
  (1+ start-pos))
    
(defmethod compute-offsets ((str str) start-pos)
  (setf (offset str) start-pos)
  (+ start-pos (len str)))

(defmethod compute-offsets ((back-reference back-reference) start-pos)
  ;; with enough effort we could possibly do better here, but
  ;; currently we just give up and return NIL
  (declare (ignore start-pos))
  nil)

(defmethod compute-offsets ((filter filter) start-pos)
  (let ((len (len filter)))
    (if len
      (+ start-pos len)
      nil)))

(defmethod compute-offsets ((regex regex) start-pos)
  ;; the general case for ANCHOR, LOOKAHEAD, LOOKBEHIND, VOID, and
  ;; WORD-BOUNDARY (which all have zero-length)
  start-pos)

#+END_SRC

** [[/Users/Can/Develop/Lisp/document/pcl/code/libraries/cl-ppcre-1.2.3/ppcre-tests.lisp][ppcre-tests]]
#+BEGIN_SRC lisp 
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-PPCRE-TEST; Base: 10 -*-
;;; $Header: /usr/local/cvsrep/cl-ppcre/ppcre-tests.lisp,v 1.26 2004/09/30 09:58:42 edi Exp $

;;; Copyright (c) 2002-2004, Dr. Edmund Weitz. All rights reserved.

;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:

;;;   * Redistributions of source code must retain the above copyright
;;;     notice, this list of conditions and the following disclaimer.

;;;   * Redistributions in binary form must reproduce the above
;;;     copyright notice, this list of conditions and the following
;;;     disclaimer in the documentation and/or other materials
;;;     provided with the distribution.

;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

(in-package #:cl-ppcre-test)

(defparameter *cl-ppcre-test-base-directory*
  (make-pathname :name nil :type nil :version nil
                 :defaults (parse-namestring *load-truename*)))

(defun full-gc ()
  "Start a full garbage collection."
  ;; what are the corresponding values for MCL and OpenMCL?
  #+:allegro (excl:gc t)
  #+(or :cmu :scl) (ext:gc :full t)
  #+:ecl (si:gc t)
  #+:clisp (ext:gc)
  #+:cormanlisp (loop for i from 0 to 3 do (cormanlisp:gc i))
  #+:lispworks (hcl:mark-and-sweep 3)
  #+:sbcl (sb-ext:gc :full t))

;; warning: ugly code ahead!!
;; this is just a quick hack for testing purposes

(defun time-regex (factor regex string
                          &key case-insensitive-mode
                               multi-line-mode
                               single-line-mode
                               extended-mode)
  (declare (optimize speed
                     (safety 0)
                     (space 0)
                     (debug 0)
                     (compilation-speed 0)
                     #+:lispworks (hcl:fixnum-safety 0)))
  "Auxiliary function used by TEST to benchmark a regex scanner
against Perl timings."
  (declare (type string string))
  (let* ((scanner (create-scanner regex
                                  :case-insensitive-mode case-insensitive-mode
                                  :multi-line-mode multi-line-mode
                                  :single-line-mode single-line-mode
                                  :extended-mode extended-mode))
         ;; make sure GC doesn't invalidate our benchmarking
         (dummy (full-gc))
         (start (get-internal-real-time)))
    (declare (ignore dummy))
    (dotimes (i factor)
      (funcall scanner string 0 (length string)))
    (float (/ (- (get-internal-real-time) start) internal-time-units-per-second))))

#+(or scl
      lispworks
      (and sbcl sb-thread))
(defun threaded-scan (scanner target-string &key (threads 10) (repetitions 5000))
  (declare (optimize speed
                     (safety 0)
                     (space 0)
                     (debug 0)
                     (compilation-speed 0)
                     #+:lispworks (hcl:fixnum-safety 0)))
  "Auxiliary function used by TEST to check whether SCANNER is thread-safe."
  (full-gc)
  (let ((collector (make-array threads))
        (counter 0))
    (loop for i below threads
          do (let* ((j i)
                    (fn
                      (lambda ()
                        (let ((r (random repetitions)))
                          (loop for k below repetitions
                                if (= k r)
                                  do (setf (aref collector j)
                                             (let ((result
                                                     (multiple-value-list
                                                       (cl-ppcre:scan scanner target-string))))
                                               (unless (cdr result)
                                                 (setq result '(nil nil #() #())))
                                               result))
                                else
                                  do (cl-ppcre:scan scanner target-string))
                          (incf counter)))))
               #+scl (thread:thread-create fn)
               #+lispworks (mp:process-run-function "" nil fn)
               #+(and sbcl sb-thread) (sb-thread:make-thread fn)))
    (loop while (< counter threads)
          do (sleep .1))
    (destructuring-bind (first-start first-end first-reg-starts first-reg-ends)
        (aref collector 0)
      (loop for (start end reg-starts reg-ends) across collector
            if (or (not (eql first-start start))
                   (not (eql first-end end))
                   (/= (length first-reg-starts) (length reg-starts))
                   (/= (length first-reg-ends) (length reg-ends))
                   (loop for first-reg-start across first-reg-starts
                         for reg-start across reg-starts
                         thereis (not (eql first-reg-start reg-start)))
                   (loop for first-reg-end across first-reg-ends
                         for reg-end across reg-ends
                         thereis (not (eql first-reg-end reg-end))))
            do (return (format nil "~&Inconsistent results during multi-threading"))))))

(defun create-string-from-input (input)
  (cond ((or (null input)
             (stringp input))
          input)
        (t
          (cl-ppcre::string-list-to-simple-string
           (loop for element in input
                 if (stringp element)
                 collect element
                 else
                 collect (string (code-char element)))))))

(defun test (&key (file-name 
                   (make-pathname :name "testdata"
                                  :type nil :version nil
                                  :defaults *cl-ppcre-test-base-directory*)
                   file-name-provided-p)
                  threaded)
  (declare (optimize speed
                     (safety 0)
                     (space 0)
                     (debug 0)
                     (compilation-speed 0)
                     #+:lispworks (hcl:fixnum-safety 0)))
  (declare (ignorable threaded))
  "Loop through all test cases in FILE-NAME and print report. Only in
LispWorks and SCL: If THREADED is true, also test whether the scanners
work multi-threaded."
  (with-open-file (stream file-name
                          #+(or :allegro :clisp :scl)
                          :external-format
                          #+(or :allegro :clisp :scl)
                          (if file-name-provided-p
                            :default
                            #+:allegro :iso-8859-1
                            #+:clisp charset:iso-8859-1
                            #+:scl :iso-8859-1))
    (loop with testcount of-type fixnum = 0
          with *regex-char-code-limit* = (if file-name-provided-p
                                           *regex-char-code-limit*
                                           ;; the standard test suite
                                           ;; doesn't need full
                                           ;; Unicode support
                                           255)
          with *allow-quoting* = (if file-name-provided-p
                                   *allow-quoting*
                                   t)
          for input-line = (read stream nil nil)
          for (counter info-string regex
                       case-insensitive-mode multi-line-mode
                       single-line-mode extended-mode
                       string perl-error factor
                       perl-time ex-result ex-subs) = input-line
          while input-line
          do (let ((info-string (create-string-from-input info-string))
                   (regex (create-string-from-input regex))
                   (string (create-string-from-input string))
                   (ex-result (create-string-from-input ex-result))
                   (ex-subs (mapcar #'create-string-from-input ex-subs))
                   (errors '()))
               ;; provide some visual feedback for slow CL
               ;; implementations; suggested by JP Massar
               (incf testcount)
               #+(or scl
                     lispworks
                     (and sbcl sb-thread))
               (when threaded
                 (format t "Test #~A (ID ~A)~%" testcount counter)
                 (force-output))
               (unless #-(or scl
                             lispworks
                             (and sbcl sb-thread))
                       nil
                       #+(or scl
                             lispworks
                             (and sbcl sb-thread))
                       threaded
                 (when (zerop (mod testcount 10))
                   (format t ".")
                   (force-output))
                 (when (zerop (mod testcount 100))
                   (terpri)))
               (handler-case
                 (let* ((*use-bmh-matchers* (if (and (> factor 1) (plusp perl-time))
                                              *use-bmh-matchers*
                                              ;; if we only check for
                                              ;; correctness we don't
                                              ;; care about speed that
                                              ;; match (but rather
                                              ;; about space
                                              ;; constraints of the
                                              ;; trial versions)
                                              nil))
                        (scanner (create-scanner regex
                                                :case-insensitive-mode case-insensitive-mode
                                                :multi-line-mode multi-line-mode
                                                :single-line-mode single-line-mode
                                                :extended-mode extended-mode)))
                   (multiple-value-bind (result1 result2 sub-starts sub-ends)
                       (scan scanner string)
                     (cond (perl-error
                             (push (format nil
                                           "~&expected an error but got a result")
                                   errors))
                           (t
                             (when (not (eq result1 ex-result))
                               (if result1
                                 (let ((result (subseq string result1 result2)))
                                   (unless (string= result ex-result)
                                     (push (format nil
                                                   "~&expected ~S but got ~S"
                                                   ex-result result)
                                           errors))
                                   (setq sub-starts (coerce sub-starts 'list)
                                         sub-ends (coerce sub-ends 'list))
                                   (loop for i from 0
                                         for ex-sub in ex-subs
                                         for sub-start = (nth i sub-starts)
                                         for sub-end = (nth i sub-ends)
                                         for sub = (if (and sub-start sub-end)
                                                     (subseq string sub-start sub-end)
                                                     nil)
                                         unless (string= ex-sub sub)
                                           do (push (format nil
                                                            "~&\\~A: expected ~S but got ~S"
                                                            (1+ i) ex-sub sub) errors)))
                                 (push (format nil
                                               "~&expected ~S but got ~S"
                                               ex-result result1)
                                       errors)))))
                     #+(or scl
                           lispworks
                           (and sbcl sb-thread))
                     (when threaded
                       (let ((thread-result (threaded-scan scanner string)))
                         (when thread-result
                         (push thread-result errors))))))
                 (condition (msg)
                   (unless perl-error
                     (push (format nil "~&got an unexpected error: '~A'" msg)
                           errors))))
               (setq errors (nreverse errors))
               (cond (errors
                       (when (or (<= factor 1) (zerop perl-time))
                         (format t "~&~4@A (~A):~{~&   ~A~}~%"
                                 counter info-string errors)))
                     ((and (> factor 1) (plusp perl-time))
                       (let ((result (time-regex factor regex string
                                                 :case-insensitive-mode case-insensitive-mode
                                                 :multi-line-mode multi-line-mode
                                                 :single-line-mode single-line-mode
                                                 :extended-mode extended-mode)))
                         (format t "~&~4@A: ~,4F (~A repetitions, Perl: ~,4F seconds, CL-PPCRE: ~,4F seconds)" counter
                                 (float (/ result perl-time)) factor perl-time result)
                         #+:cormanlisp (force-output *standard-output*)))
                     (t nil))))
    (values)))

#+END_SRC

** [[/Users/Can/Develop/Lisp/document/pcl/code/libraries/cl-ppcre-1.2.3/parser.lisp][parser]]
#+BEGIN_SRC lisp 
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-PPCRE; Base: 10 -*-
;;; $Header: /usr/local/cvsrep/cl-ppcre/parser.lisp,v 1.17 2004/04/20 11:37:36 edi Exp $

;;; The parser will - with the help of the lexer - parse a regex
;;; string and convert it into a "parse tree" (see docs for details
;;; about the syntax of these trees). Note that the lexer might return
;;; illegal parse trees. It is assumed that the conversion process
;;; later on will track them down.

;;; Copyright (c) 2002-2004, Dr. Edmund Weitz. All rights reserved.

;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:

;;;   * Redistributions of source code must retain the above copyright
;;;     notice, this list of conditions and the following disclaimer.

;;;   * Redistributions in binary form must reproduce the above
;;;     copyright notice, this list of conditions and the following
;;;     disclaimer in the documentation and/or other materials
;;;     provided with the distribution.

;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

(in-package #:cl-ppcre)

(defun group (lexer)
  (declare (optimize speed
                     (safety 0)
                     (space 0)
                     (debug 0)
                     (compilation-speed 0)
                     #+:lispworks (hcl:fixnum-safety 0)))
  "Parses and consumes a <group>.
The productions are: <group> -> \"(\"<regex>\")\"
                                \"(?:\"<regex>\")\"
                                \"(?<\"<regex>\")\"
                                \"(?<flags>:\"<regex>\")\"
                                \"(?=\"<regex>\")\"
                                \"(?!\"<regex>\")\"
                                \"(?<=\"<regex>\")\"
                                \"(?<!\"<regex>\")\"
                                \"(?(\"<num>\")\"<regex>\")\"
                                \"(?(\"<regex>\")\"<regex>\")\"
                                <legal-token>
where <flags> is parsed by the lexer function MAYBE-PARSE-FLAGS.
Will return <parse-tree> or (<grouping-type> <parse-tree>) where
<grouping-type> is one of six keywords - see source for details."
  (multiple-value-bind (open-token flags)
      (get-token lexer)
    (cond ((eq open-token :open-paren-paren)
            ;; special case for conditional regular expressions; note
            ;; that at this point we accept a couple of illegal
            ;; combinations which'll be sorted out later by the
            ;; converter
            (let* ((open-paren-pos (car (lexer-last-pos lexer)))
                   ;; check if what follows "(?(" is a number
                   (number (try-number lexer :no-whitespace-p t))
                   ;; make changes to extended-mode-p local
                   (*extended-mode-p* *extended-mode-p*))
              (declare (type fixnum open-paren-pos))
              (cond (number
                      ;; condition is a number (i.e. refers to a
                      ;; back-reference)
                      (let* ((inner-close-token (get-token lexer))
                             (reg-expr (reg-expr lexer))
                             (close-token (get-token lexer)))
                        (unless (eq inner-close-token :close-paren)
                          (signal-ppcre-syntax-error*
                           (+ open-paren-pos 2)
                           "Opening paren has no matching closing paren"))
                        (unless (eq close-token :close-paren)
                          (signal-ppcre-syntax-error*
                           open-paren-pos
                           "Opening paren has no matching closing paren"))
                        (list :branch number reg-expr)))
                    (t
                      ;; condition must be a full regex (actually a
                      ;; look-behind or look-ahead); and here comes a
                      ;; terrible kludge: instead of being cleanly
                      ;; separated from the lexer, the parser pushes
                      ;; back the lexer by one position, thereby
                      ;; landing in the middle of the 'token' "(?(" -
                      ;; yuck!!
                      (decf (lexer-pos lexer))
                      (let* ((inner-reg-expr (group lexer))
                             (reg-expr (reg-expr lexer))
                             (close-token (get-token lexer)))
                        (unless (eq close-token :close-paren)
                          (signal-ppcre-syntax-error*
                           open-paren-pos
                           "Opening paren has no matching closing paren"))
                        (list :branch inner-reg-expr reg-expr))))))
          ((member open-token '(:open-paren
                                :open-paren-colon
                                :open-paren-greater
                                :open-paren-equal
                                :open-paren-exclamation
                                :open-paren-less-equal
                                :open-paren-less-exclamation)
                   :test #'eq)
            ;; make changes to extended-mode-p local
            (let ((*extended-mode-p* *extended-mode-p*))
              ;; we saw one of the six token representing opening
              ;; parentheses
              (let* ((open-paren-pos (car (lexer-last-pos lexer)))
                     (reg-expr (reg-expr lexer))
                     (close-token (get-token lexer)))
                (when (eq open-token :open-paren)
                  ;; if this is the "("<regex>")" production we have to
                  ;; increment the register counter of the lexer
                  (incf (lexer-reg lexer)))
                (unless (eq close-token :close-paren)
                  ;; the token following <regex> must be the closing
                  ;; parenthesis or this is a syntax error
                  (signal-ppcre-syntax-error*
                   open-paren-pos
                   "Opening paren has no matching closing paren"))
                (if flags
                  ;; if the lexer has returned a list of flags this must
                  ;; have been the "(?:"<regex>")" production
                  (cons :group (nconc flags (list reg-expr)))
                  (list (case open-token
                          ((:open-paren)
                            :register)
                          ((:open-paren-colon)
                            :group)
                          ((:open-paren-greater)
                            :standalone)
                          ((:open-paren-equal)
                            :positive-lookahead)
                          ((:open-paren-exclamation)
                            :negative-lookahead)
                          ((:open-paren-less-equal)
                            :positive-lookbehind)
                          ((:open-paren-less-exclamation)
                            :negative-lookbehind))
                        reg-expr)))))
          (t
            ;; this is the <legal-token> production; <legal-token> is
            ;; any token which passes START-OF-SUBEXPR-P (otherwise
            ;; parsing had already stopped in the SEQ method)
            open-token))))

(defun greedy-quant (lexer)
  (declare (optimize speed
                     (safety 0)
                     (space 0)
                     (debug 0)
                     (compilation-speed 0)
                     #+:lispworks (hcl:fixnum-safety 0)))
  "Parses and consumes a <greedy-quant>.
The productions are: <greedy-quant> -> <group> | <group><quantifier>
where <quantifier> is parsed by the lexer function GET-QUANTIFIER.
Will return <parse-tree> or (:GREEDY-REPETITION <min> <max> <parse-tree>)."
  (let* ((group (group lexer))
         (token (get-quantifier lexer)))
    (if token
      ;; if GET-QUANTIFIER returned a non-NIL value it's the
      ;; two-element list (<min> <max>)
      (list :greedy-repetition (first token) (second token) group)
      group)))

(defun quant (lexer)
  (declare (optimize speed
                     (safety 0)
                     (space 0)
                     (debug 0)
                     (compilation-speed 0)
                     #+:lispworks (hcl:fixnum-safety 0)))
  "Parses and consumes a <quant>.
The productions are: <quant> -> <greedy-quant> | <greedy-quant>\"?\".
Will return the <parse-tree> returned by GREEDY-QUANT and optionally
change :GREEDY-REPETITION to :NON-GREEDY-REPETITION."
  (let* ((greedy-quant (greedy-quant lexer))
         (pos (lexer-pos lexer))
         (next-char (next-char lexer)))
    (when next-char
      (if (char= next-char #\?)
        (setf (car greedy-quant) :non-greedy-repetition)
        (setf (lexer-pos lexer) pos)))
    greedy-quant))

(defun seq (lexer)
  (declare (optimize speed
                     (safety 0)
                     (space 0)
                     (debug 0)
                     (compilation-speed 0)
                     #+:lispworks (hcl:fixnum-safety 0)))
  "Parses and consumes a <seq>.
The productions are: <seq> -> <quant> | <quant><seq>.
Will return <parse-tree> or (:SEQUENCE <parse-tree> <parse-tree>)."
  (flet ((make-array-from-two-chars (char1 char2)
           (let ((string (make-array 2
                                     :element-type 'character
                                     :fill-pointer t
                                     :adjustable t)))
             (setf (aref string 0) char1)
             (setf (aref string 1) char2)
             string)))
    ;; Note that we're calling START-OF-SUBEXPR-P before we actually try
    ;; to parse a <seq> or <quant> in order to catch empty regular
    ;; expressions
    (if (start-of-subexpr-p lexer)
      (let ((quant (quant lexer)))
        (if (start-of-subexpr-p lexer)
          (let* ((seq (seq lexer))
                 (quant-is-char-p (characterp quant))
                 (seq-is-sequence-p (and (consp seq)
                                         (eq (first seq) :sequence))))
            (cond ((and quant-is-char-p
                        (characterp seq))
                    (make-array-from-two-chars seq quant))
                  ((and quant-is-char-p
                        (stringp seq))
                    (vector-push-extend quant seq)
                    seq)
                  ((and quant-is-char-p
                        seq-is-sequence-p
                        (characterp (second seq)))
                    (cond ((cddr seq)
                            (setf (cdr seq)
                                    (cons
                                     (make-array-from-two-chars (second seq)
                                                                quant)
                                     (cddr seq)))
                            seq)
                          (t (make-array-from-two-chars (second seq) quant))))
                  ((and quant-is-char-p
                        seq-is-sequence-p
                        (stringp (second seq)))
                    (cond ((cddr seq)
                            (setf (cdr seq)
                                    (cons
                                     (progn
                                       (vector-push-extend quant (second seq))
                                       (second seq))
                                     (cddr seq)))
                            seq)
                          (t 
                            (vector-push-extend quant (second seq))
                            (second seq))))
                  (seq-is-sequence-p
                    ;; if <seq> is also a :SEQUENCE parse tree we merge
                    ;; both lists into one to avoid unnecessary consing
                    (setf (cdr seq)
                            (cons quant (cdr seq)))
                    seq)
                  (t (list :sequence quant seq))))
          quant))
      :void)))
  
(defun reg-expr (lexer)
  (declare (optimize speed
                     (safety 0)
                     (space 0)
                     (debug 0)
                     (compilation-speed 0)
                     #+:lispworks (hcl:fixnum-safety 0)))
  "Parses and consumes a <regex>, a complete regular expression.
The productions are: <regex> -> <seq> | <seq>\"|\"<regex>.
Will return <parse-tree> or (:ALTERNATION <parse-tree> <parse-tree>)."
  (let ((pos (lexer-pos lexer)))
    (case (next-char lexer)
      ((nil)
        ;; if we didn't get any token we return :VOID which stands for
        ;; "empty regular expression"
        :void)
      ((#\|)
        ;; now check whether the expression started with a vertical
        ;; bar, i.e. <seq> - the left alternation - is empty
        (list :alternation :void (reg-expr lexer)))
      (otherwise
        ;; otherwise un-read the character we just saw and parse a
        ;; <seq> plus the character following it
        (setf (lexer-pos lexer) pos)
        (let* ((seq (seq lexer))
               (pos (lexer-pos lexer)))
          (case (next-char lexer)
            ((nil)
              ;; no further character, just a <seq>
              seq)
            ((#\|)
              ;; if the character was a vertical bar, this is an
              ;; alternation and we have the second production
              (let ((reg-expr (reg-expr lexer)))
                (cond ((and (consp reg-expr)
                            (eq (first reg-expr) :alternation))
                        ;; again we try to merge as above in SEQ
                        (setf (cdr reg-expr)
                                (cons seq (cdr reg-expr)))
                        reg-expr)
                      (t (list :alternation seq reg-expr)))))
            (otherwise
              ;; a character which is not a vertical bar - this is
              ;; either a syntax error or we're inside of a group and
              ;; the next character is a closing parenthesis; so we
              ;; just un-read the character and let another function
              ;; take care of it
              (setf (lexer-pos lexer) pos)
              seq)))))))

(defun reverse-strings (parse-tree)
  (declare (optimize speed
                     (safety 0)
                     (space 0)
                     (debug 0)
                     (compilation-speed 0)
                     #+:lispworks (hcl:fixnum-safety 0)))
  (cond ((stringp parse-tree)
          (nreverse parse-tree))
        ((consp parse-tree)
          (loop for parse-tree-rest on parse-tree
                while parse-tree-rest
                do (setf (car parse-tree-rest)
                           (reverse-strings (car parse-tree-rest))))
          parse-tree)
        (t parse-tree)))

(defun parse-string (string)
  (declare (optimize speed
                     (safety 0)
                     (space 0)
                     (debug 0)
                     (compilation-speed 0)
                     #+:lispworks (hcl:fixnum-safety 0)))
  "Translate the regex string STRING into a parse tree."
  (let* ((lexer (make-lexer string))
         (parse-tree (reverse-strings (reg-expr lexer))))
    ;; check whether we've consumed the whole regex string
    (if (end-of-string-p lexer)
      parse-tree
      (signal-ppcre-syntax-error*
       (lexer-pos lexer)
       "Expected end of string"))))
#+END_SRC

** [[/Users/Can/Develop/Lisp/document/pcl/code/libraries/cl-ppcre-1.2.3/packages.lisp][packages]]
#+BEGIN_SRC lisp 
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
;;; $Header: /usr/local/cvsrep/cl-ppcre/packages.lisp,v 1.17 2004/09/30 09:58:42 edi Exp $

;;; Copyright (c) 2002-2004, Dr. Edmund Weitz. All rights reserved.

;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:

;;;   * Redistributions of source code must retain the above copyright
;;;     notice, this list of conditions and the following disclaimer.

;;;   * Redistributions in binary form must reproduce the above
;;;     copyright notice, this list of conditions and the following
;;;     disclaimer in the documentation and/or other materials
;;;     provided with the distribution.

;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

(in-package :cl-user)

#-:cormanlisp
(defpackage #:cl-ppcre
  (:nicknames #:ppcre)
  #+genera (:shadowing-import-from #:common-lisp #:lambda #:simple-string #:string)
  (:use #-genera #:cl #+genera #:future-common-lisp)
  (:export #:create-scanner
           #:parse-tree-synonym
           #:define-parse-tree-synonym
           #:scan
           #:scan-to-strings
           #:do-scans
           #:do-matches
           #:do-matches-as-strings
           #:all-matches
           #:all-matches-as-strings
           #:split
           #:regex-replace
           #:regex-replace-all
           #:regex-apropos
           #:regex-apropos-list
           #:quote-meta-chars
           #:*regex-char-code-limit*
           #:*use-bmh-matchers*
           #:*allow-quoting*
           #:ppcre-error
           #:ppcre-invocation-error
           #:ppcre-syntax-error
           #:ppcre-syntax-error-string
           #:ppcre-syntax-error-pos
           #:register-groups-bind
           #:do-register-groups))

#+:cormanlisp
(defpackage "CL-PPCRE"
  (:nicknames "PPCRE")
  (:use "CL")
  (:export "CREATE-SCANNER"
           "PARSE-TREE-SYNONYM"
           "DEFINE-PARSE-TREE-SYNONYM"
           "SCAN"
           "SCAN-TO-STRINGS"
           "DO-SCANS"
           "DO-MATCHES"
           "DO-MATCHES-AS-STRINGS"
           "ALL-MATCHES"
           "ALL-MATCHES-AS-STRINGS"
           "SPLIT"
           "REGEX-REPLACE"
           "REGEX-REPLACE-ALL"
           "REGEX-APROPOS"
           "REGEX-APROPOS-LIST"
           "QUOTE-META-CHARS"
           "*REGEX-CHAR-CODE-LIMIT*"
           "*USE-BMH-MATCHERS*"
           "*ALLOW-QUOTING*"
           "PPCRE-ERROR"
           "PPCRE-INVOCATION-ERROR"
           "PPCRE-SYNTAX-ERROR"
           "PPCRE-SYNTAX-ERROR-STRING"
           "PPCRE-SYNTAX-ERROR-POS"
           "REGISTER-GROUPS-BIND"
           "DO-REGISTER-GROUPS"))

#-:cormanlisp
(defpackage #:cl-ppcre-test
  #+genera (:shadowing-import-from #:common-lisp #:lambda)
  (:use #-genera #:cl #+genera #:future-common-lisp #:cl-ppcre)
  (:export #:test))

#+:cormanlisp
(defpackage "CL-PPCRE-TEST"
  (:use "CL" "CL-PPCRE")
  (:export "TEST"))

#+END_SRC

** [[/Users/Can/Develop/Lisp/document/pcl/code/libraries/cl-ppcre-1.2.3/optimize.lisp][optimize]]
#+BEGIN_SRC lisp 
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-PPCRE; Base: 10 -*-
;;; $Header: /usr/local/cvsrep/cl-ppcre/optimize.lisp,v 1.22 2005/01/24 14:06:38 edi Exp $

;;; This file contains optimizations which can be applied to converted
;;; parse trees.

;;; Copyright (c) 2002-2004, Dr. Edmund Weitz. All rights reserved.

;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:

;;;   * Redistributions of source code must retain the above copyright
;;;     notice, this list of conditions and the following disclaimer.

;;;   * Redistributions in binary form must reproduce the above
;;;     copyright notice, this list of conditions and the following
;;;     disclaimer in the documentation and/or other materials
;;;     provided with the distribution.

;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

(in-package #:cl-ppcre)

(defgeneric flatten (regex)
  (declare (optimize speed
                     (safety 0)
                     (space 0)
                     (debug 0)
                     (compilation-speed 0)
                     #+:lispworks (hcl:fixnum-safety 0)))
  (:documentation "Merges adjacent sequences and alternations, i.e. it
transforms #<SEQ #<STR \"a\"> #<SEQ #<STR \"b\"> #<STR \"c\">>> to
#<SEQ #<STR \"a\"> #<STR \"b\"> #<STR \"c\">>. This is a destructive
operation on REGEX."))

(defmethod flatten ((seq seq))
  ;; this looks more complicated than it is because we modify SEQ in
  ;; place to avoid unnecessary consing
  (let ((elements-rest (elements seq)))
    (loop
      (unless elements-rest
        (return))
      (let ((flattened-element (flatten (car elements-rest)))
            (next-elements-rest (cdr elements-rest)))
        (cond ((typep flattened-element 'seq)
                ;; FLATTENED-ELEMENT is a SEQ object, so we "splice"
                ;; it into out list of elements
                (let ((flattened-element-elements
                        (elements flattened-element)))
                  (setf (car elements-rest)
                          (car flattened-element-elements)
                        (cdr elements-rest)
                          (nconc (cdr flattened-element-elements)
                                 (cdr elements-rest)))))
              (t
                ;; otherwise we just replace the current element with
                ;; its flattened counterpart
                (setf (car elements-rest) flattened-element)))
        (setq elements-rest next-elements-rest))))
  (let ((elements (elements seq)))
    (cond ((cadr elements)
            seq)
          ((cdr elements)
            (first elements))
          (t (make-instance 'void)))))

(defmethod flatten ((alternation alternation))
  ;; same algorithm as above
  (let ((choices-rest (choices alternation)))
    (loop
      (unless choices-rest
        (return))
      (let ((flattened-choice (flatten (car choices-rest)))
            (next-choices-rest (cdr choices-rest)))
        (cond ((typep flattened-choice 'alternation)
                (let ((flattened-choice-choices
                        (choices flattened-choice)))
                  (setf (car choices-rest)
                          (car flattened-choice-choices)
                        (cdr choices-rest)
                          (nconc (cdr flattened-choice-choices)
                                 (cdr choices-rest)))))
              (t
                (setf (car choices-rest) flattened-choice)))
        (setq choices-rest next-choices-rest))))
  (let ((choices (choices alternation)))
    (cond ((cadr choices)
            alternation)
          ((cdr choices)
            (first choices))
          (t (signal-ppcre-syntax-error
              "Encountered alternation without choices.")))))

(defmethod flatten ((branch branch))
  (with-slots ((test test)
               (then-regex then-regex)
               (else-regex else-regex))
      branch
    (setq test
            (if (numberp test)
              test
              (flatten test))
          then-regex (flatten then-regex)
          else-regex (flatten else-regex))
    branch))

(defmethod flatten ((regex regex))
  (typecase regex
    ((or repetition register lookahead lookbehind standalone)
      ;; if REGEX contains exactly one inner REGEX object flatten it
      (setf (regex regex)
              (flatten (regex regex)))
      regex)
    (t
      ;; otherwise (ANCHOR, BACK-REFERENCE, CHAR-CLASS, EVERYTHING,
      ;; LOOKAHEAD, LOOKBEHIND, STR, VOID, FILTER, and WORD-BOUNDARY)
      ;; do nothing
      regex)))

(defgeneric gather-strings (regex)
    (declare (optimize speed
                     (safety 0)
                     (space 0)
                     (debug 0)
                     (compilation-speed 0)
                     #+:lispworks (hcl:fixnum-safety 0)))
  (:documentation "Collects adjacent strings or characters into one
string provided they have the same case mode. This is a destructive
operation on REGEX."))

(defmethod gather-strings ((seq seq))
  ;; note that GATHER-STRINGS is to be applied after FLATTEN, i.e. it
  ;; expects SEQ to be flattened already; in particular, SEQ cannot be
  ;; empty and cannot contain embedded SEQ objects
  (let* ((start-point (cons nil (elements seq)))
         (curr-point start-point)
         old-case-mode
         collector
         collector-start
         (collector-length 0)
         skip)
    (declare (type fixnum collector-length))
    (loop
      (let ((elements-rest (cdr curr-point)))
        (unless elements-rest
          (return))
        (let* ((element (car elements-rest))
               (case-mode (case-mode element old-case-mode)))
          (cond ((and case-mode
                      (eq case-mode old-case-mode))
                  ;; if ELEMENT is a STR and we have collected a STR of
                  ;; the same case mode in the last iteration we
                  ;; concatenate ELEMENT onto COLLECTOR and remember the
                  ;; value of its SKIP slot
                  (let ((old-collector-length collector-length))
                    (unless (and (adjustable-array-p collector)
                                 (array-has-fill-pointer-p collector))
                      (setq collector
                              (make-array collector-length
                                          :initial-contents collector
                                          :element-type 'character
                                          :fill-pointer t
                                          :adjustable t)
                            collector-start nil))
                    (adjust-array collector
                                  (incf collector-length (len element))
                                  :fill-pointer t)
                    (setf (subseq collector
                                  old-collector-length)
                            (str element)
                          ;; it suffices to remember the last SKIP slot
                          ;; because due to the way MAYBE-ACCUMULATE
                          ;; works adjacent STR objects have the same
                          ;; SKIP value
                          skip (skip element)))
                  (setf (cdr curr-point) (cdr elements-rest)))
                (t
                  (let ((collected-string
                          (cond (collector-start
                                  collector-start)
                                (collector
                                  ;; if we have collected something already
                                  ;; we convert it into a STR
                                  (make-instance 'str
                                                 :skip skip
                                                 :str collector
                                                 :case-insensitive-p
                                                 (eq old-case-mode
                                                     :case-insensitive)))
                                (t nil))))
                    (cond (case-mode
                            ;; if ELEMENT is a string with a different case
                            ;; mode than the last one we have either just
                            ;; converted COLLECTOR into a STR or COLLECTOR
                            ;; is still empty; in both cases we can now
                            ;; begin to fill it anew
                            (setq collector (str element)
                                  collector-start element
                                  ;; and we remember the SKIP value as above
                                  skip (skip element)
                                  collector-length (len element))
                            (cond (collected-string
                                    (setf (car elements-rest)
                                            collected-string
                                          curr-point
                                            (cdr curr-point)))
                                  (t
                                    (setf (cdr curr-point)
                                            (cdr elements-rest)))))
                          (t
                            ;; otherwise this is not a STR so we apply
                            ;; GATHER-STRINGS to it and collect it directly
                            ;; into RESULT
                            (cond (collected-string
                                    (setf (car elements-rest)
                                            collected-string
                                          curr-point
                                            (cdr curr-point)
                                          (cdr curr-point)
                                            (cons (gather-strings element)
                                                  (cdr curr-point))
                                          curr-point
                                            (cdr curr-point)))
                                  (t
                                    (setf (car elements-rest)
                                            (gather-strings element)
                                          curr-point
                                            (cdr curr-point))))
                            ;; we also have to empty COLLECTOR here in case
                            ;; it was still filled from the last iteration
                            (setq collector nil
                                  collector-start nil))))))
          (setq old-case-mode case-mode))))
    (when collector
      (setf (cdr curr-point)
              (cons
               (make-instance 'str
                              :skip skip
                              :str collector
                              :case-insensitive-p
                              (eq old-case-mode
                                  :case-insensitive))
               nil)))
    (setf (elements seq) (cdr start-point))
    seq))

(defmethod gather-strings ((alternation alternation))
  ;; loop ON the choices of ALTERNATION so we can modify them directly
  (loop for choices-rest on (choices alternation)
        while choices-rest
        do (setf (car choices-rest)
                   (gather-strings (car choices-rest))))
  alternation)

(defmethod gather-strings ((branch branch))
  (with-slots ((test test)
               (then-regex then-regex)
               (else-regex else-regex))
      branch
    (setq test
            (if (numberp test)
              test
              (gather-strings test))
          then-regex (gather-strings then-regex)
          else-regex (gather-strings else-regex))
    branch))

(defmethod gather-strings ((regex regex))
  (typecase regex
    ((or repetition register lookahead lookbehind standalone)
      ;; if REGEX contains exactly one inner REGEX object apply
      ;; GATHER-STRINGS to it
      (setf (regex regex)
              (gather-strings (regex regex)))
      regex)
    (t
      ;; otherwise (ANCHOR, BACK-REFERENCE, CHAR-CLASS, EVERYTHING,
      ;; LOOKAHEAD, LOOKBEHIND, STR, VOID, FILTER, and WORD-BOUNDARY)
      ;; do nothing
      regex)))

;; Note that START-ANCHORED-P will be called after FLATTEN and GATHER-STRINGS.

(defgeneric start-anchored-p (regex &optional in-seq-p)
    (declare (optimize speed
                     (safety 0)
                     (space 0)
                     (debug 0)
                     (compilation-speed 0)
                     #+:lispworks (hcl:fixnum-safety 0)))
  (:documentation "Returns T if REGEX starts with a \"real\" start
anchor, i.e. one that's not in multi-line mode, NIL otherwise. If
IN-SEQ-P is true the function will return :ZERO-LENGTH if REGEX is a
zero-length assertion."))

(defmethod start-anchored-p ((seq seq) &optional in-seq-p)
  (declare (ignore in-seq-p))
  ;; note that START-ANCHORED-P is to be applied after FLATTEN and
  ;; GATHER-STRINGS, i.e. SEQ cannot be empty and cannot contain
  ;; embedded SEQ objects
  (loop for element in (elements seq)
        for anchored-p = (start-anchored-p element t)
        ;; skip zero-length elements because they won't affect the
        ;; "anchoredness" of the sequence
        while (eq anchored-p :zero-length)
        finally (return (and anchored-p (not (eq anchored-p :zero-length))))))

(defmethod start-anchored-p ((alternation alternation) &optional in-seq-p)
  (declare (ignore in-seq-p))
  ;; clearly an alternation can only be start-anchored if all of its
  ;; choices are start-anchored
  (loop for choice in (choices alternation)
        always (start-anchored-p choice)))

(defmethod start-anchored-p ((branch branch) &optional in-seq-p)
  (declare (ignore in-seq-p))
  (and (start-anchored-p (then-regex branch))
       (start-anchored-p (else-regex branch))))

(defmethod start-anchored-p ((repetition repetition) &optional in-seq-p)
  (declare (ignore in-seq-p))
  ;; well, this wouldn't make much sense, but anyway...
  (and (plusp (minimum repetition))
       (start-anchored-p (regex repetition))))

(defmethod start-anchored-p ((register register) &optional in-seq-p)
  (declare (ignore in-seq-p))
  (start-anchored-p (regex register)))

(defmethod start-anchored-p ((standalone standalone) &optional in-seq-p)
  (declare (ignore in-seq-p))
  (start-anchored-p (regex standalone)))

(defmethod start-anchored-p ((anchor anchor) &optional in-seq-p)
  (declare (ignore in-seq-p))
  (and (startp anchor)
       (not (multi-line-p anchor))))

(defmethod start-anchored-p ((regex regex) &optional in-seq-p)
  (typecase regex
    ((or lookahead lookbehind word-boundary void)
      ;; zero-length assertions
      (if in-seq-p
        :zero-length
        nil))
    (filter
      (if (and in-seq-p
               (len regex)
               (zerop (len regex)))
        :zero-length
        nil))
    (t
      ;; BACK-REFERENCE, CHAR-CLASS, EVERYTHING, and STR
      nil)))

;; Note that END-STRING-AUX will be called after FLATTEN and GATHER-STRINGS.

(defgeneric end-string-aux (regex &optional old-case-insensitive-p)
    (declare (optimize speed
                     (safety 0)
                     (space 0)
                     (debug 0)
                     (compilation-speed 0)
                     #+:lispworks (hcl:fixnum-safety 0)))
  (:documentation "Returns the constant string (if it exists) REGEX
ends with wrapped into a STR object, otherwise NIL.
OLD-CASE-INSENSITIVE-P is the CASE-INSENSITIVE-P slot of the last STR
collected or :VOID if no STR has been collected yet. (This is a helper
function called by END-STRIN.)"))

(defmethod end-string-aux ((str str)
                           &optional (old-case-insensitive-p :void))
  (declare (special last-str))
  (cond ((and (not (skip str))          ; avoid constituents of STARTS-WITH
              ;; only use STR if nothing has been collected yet or if
              ;; the collected string has the same value for
              ;; CASE-INSENSITIVE-P
              (or (eq old-case-insensitive-p :void)
                  (eq (case-insensitive-p str) old-case-insensitive-p)))
          (setf last-str str
                ;; set the SKIP property of this STR
                (skip str) t)
          str)
        (t nil)))

(defmethod end-string-aux ((seq seq)
                           &optional (old-case-insensitive-p :void))
  (declare (special continuep))
  (let (case-insensitive-p
        concatenated-string
        concatenated-start
        (concatenated-length 0))
    (declare (type fixnum concatenated-length))
    (loop for element in (reverse (elements seq))
          ;; remember the case-(in)sensitivity of the last relevant
          ;; STR object
          for loop-old-case-insensitive-p = old-case-insensitive-p
            then (if skip
                   loop-old-case-insensitive-p
                   (case-insensitive-p element-end))
          ;; the end-string of the current element
          for element-end = (end-string-aux element
                                            loop-old-case-insensitive-p)
          ;; whether we encountered a zero-length element
          for skip = (if element-end
                       (zerop (len element-end))
                       nil)
          ;; set CONTINUEP to NIL if we have to stop collecting to
          ;; alert END-STRING-AUX methods on enclosing SEQ objects
          unless element-end
            do (setq continuep nil)
          ;; end loop if we neither got a STR nor a zero-length
          ;; element
          while element-end
          ;; only collect if not zero-length
          unless skip
            do (cond (concatenated-string
                       (when concatenated-start
                         (setf concatenated-string
                                 (make-array concatenated-length
                                             :initial-contents (reverse (str concatenated-start))
                                             :element-type 'character
                                             :fill-pointer t
                                             :adjustable t)
                               concatenated-start nil))
                       (let ((len (len element-end))
                             (str (str element-end)))
                         (declare (type fixnum len))
                         (incf concatenated-length len)
                         (loop for i of-type fixnum downfrom (1- len) to 0
                               do (vector-push-extend (char str i)
                                                      concatenated-string))))
                     (t
                       (setf concatenated-string
                               t
                             concatenated-start
                               element-end
                             concatenated-length
                               (len element-end)
                             case-insensitive-p
                               (case-insensitive-p element-end))))
          ;; stop collecting if END-STRING-AUX on inner SEQ has said so
          while continuep)
    (cond ((zerop concatenated-length)
            ;; don't bother to return zero-length strings
            nil)
          (concatenated-start
            concatenated-start)
          (t
            (make-instance 'str
                           :str (nreverse concatenated-string)
                           :case-insensitive-p case-insensitive-p)))))

(defmethod end-string-aux ((register register)
                           &optional (old-case-insensitive-p :void))
  (end-string-aux (regex register) old-case-insensitive-p))
    
(defmethod end-string-aux ((standalone standalone)
                           &optional (old-case-insensitive-p :void))
  (end-string-aux (regex standalone) old-case-insensitive-p))
    
(defmethod end-string-aux ((regex regex)
                           &optional (old-case-insensitive-p :void))
  (declare (special last-str end-anchored-p continuep))
  (typecase regex
    ((or anchor lookahead lookbehind word-boundary void)
      ;; a zero-length REGEX object - for the sake of END-STRING-AUX
      ;; this is a zero-length string
      (when (and (typep regex 'anchor)
                 (not (startp regex))
                 (or (no-newline-p regex)
                     (not (multi-line-p regex)))
                 (eq old-case-insensitive-p :void))
        ;; if this is a "real" end-anchor and we haven't collected
        ;; anything so far we can set END-ANCHORED-P (where 1 or 0
        ;; indicate whether we accept a #\Newline at the end or not)
        (setq end-anchored-p (if (no-newline-p regex) 0 1)))
      (make-instance 'str
                     :str ""
                     :case-insensitive-p :void))
    (t
      ;; (ALTERNATION, BACK-REFERENCE, BRANCH, CHAR-CLASS, EVERYTHING,
      ;; REPETITION, FILTER)
      nil)))

(defmethod end-string ((regex regex))
  (declare (special end-string-offset))
    (declare (optimize speed
                     (safety 0)
                     (space 0)
                     (debug 0)
                     (compilation-speed 0)
                     #+:lispworks (hcl:fixnum-safety 0)))
  "Returns the constant string (if it exists) REGEX ends with wrapped
into a STR object, otherwise NIL."
  ;; LAST-STR points to the last STR object (seen from the end) that's
  ;; part of END-STRING; CONTINUEP is set to T if we stop collecting
  ;; in the middle of a SEQ
  (let ((continuep t)
        last-str)
    (declare (special continuep last-str))
    (prog1
      (end-string-aux regex)
      (when last-str
        ;; if we've found something set the START-OF-END-STRING-P of
        ;; the leftmost STR collected accordingly and remember the
        ;; OFFSET of this STR (in a special variable provided by the
        ;; caller of this function)
        (setf (start-of-end-string-p last-str) t
              end-string-offset (offset last-str))))))

(defgeneric compute-min-rest (regex current-min-rest)
    (declare (optimize speed
                     (safety 0)
                     (space 0)
                     (debug 0)
                     (compilation-speed 0)
                     #+:lispworks (hcl:fixnum-safety 0)))
  (:documentation "Returns the minimal length of REGEX plus
CURRENT-MIN-REST. This is similar to REGEX-MIN-LENGTH except that it
recurses down into REGEX and sets the MIN-REST slots of REPETITION
objects."))

(defmethod compute-min-rest ((seq seq) current-min-rest)
  (loop for element in (reverse (elements seq))
        for last-min-rest = current-min-rest then this-min-rest
        for this-min-rest = (compute-min-rest element last-min-rest)
        finally (return this-min-rest)))
    
(defmethod compute-min-rest ((alternation alternation) current-min-rest)
  (loop for choice in (choices alternation)
        minimize (compute-min-rest choice current-min-rest)))

(defmethod compute-min-rest ((branch branch) current-min-rest)
  (min (compute-min-rest (then-regex branch) current-min-rest)
       (compute-min-rest (else-regex branch) current-min-rest)))

(defmethod compute-min-rest ((str str) current-min-rest)
  (+ current-min-rest (len str)))
    
(defmethod compute-min-rest ((filter filter) current-min-rest)
  (+ current-min-rest (or (len filter) 0)))
    
(defmethod compute-min-rest ((repetition repetition) current-min-rest)
  (setf (min-rest repetition) current-min-rest)
  (compute-min-rest (regex repetition) current-min-rest)
  (+ current-min-rest (* (minimum repetition) (min-len repetition))))

(defmethod compute-min-rest ((register register) current-min-rest)
  (compute-min-rest (regex register) current-min-rest))
    
(defmethod compute-min-rest ((standalone standalone) current-min-rest)
  (declare (ignore current-min-rest))
  (compute-min-rest (regex standalone) 0))
    
(defmethod compute-min-rest ((lookahead lookahead) current-min-rest)
  (compute-min-rest (regex lookahead) 0)
  current-min-rest)
    
(defmethod compute-min-rest ((lookbehind lookbehind) current-min-rest)
  (compute-min-rest (regex lookbehind) (+ current-min-rest (len lookbehind)))
  current-min-rest)
    
(defmethod compute-min-rest ((regex regex) current-min-rest)
  (typecase regex
    ((or char-class everything)
      (1+ current-min-rest))
    (t
      ;; zero min-len and no embedded regexes (ANCHOR,
      ;; BACK-REFERENCE, VOID, and WORD-BOUNDARY)
      current-min-rest)))

#+END_SRC

** [[/Users/Can/Develop/Lisp/document/pcl/code/libraries/cl-ppcre-1.2.3/load.lisp][load]]
#+BEGIN_SRC lisp 
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
;;; $Header: /usr/local/cvsrep/cl-ppcre/load.lisp,v 1.12 2005/02/02 18:34:30 edi Exp $

;;; Copyright (c) 2002-2004, Dr. Edmund Weitz.  All rights reserved.

;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:

;;;   * Redistributions of source code must retain the above copyright
;;;     notice, this list of conditions and the following disclaimer.

;;;   * Redistributions in binary form must reproduce the above
;;;     copyright notice, this list of conditions and the following
;;;     disclaimer in the documentation and/or other materials
;;;     provided with the distribution.

;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

(in-package :cl-user)

(let ((cl-ppcre-base-directory
        (make-pathname :name nil :type nil :version nil
                       :defaults (parse-namestring *load-truename*)))
      must-compile)
  (with-compilation-unit ()
    (dolist (file '("packages"
                    "specials"
                    "util"
                    "errors"
                    #-:use-acl-regexp2-engine "lexer"
                    #-:use-acl-regexp2-engine "parser"
                    #-:use-acl-regexp2-engine "regex-class"
                    #-:use-acl-regexp2-engine "convert"
                    #-:use-acl-regexp2-engine "optimize"
                    #-:use-acl-regexp2-engine "closures"
                    #-:use-acl-regexp2-engine "repetition-closures"
                    #-:use-acl-regexp2-engine "scanner"
                    "api"
                    "ppcre-tests"))
      (let ((pathname (make-pathname :name file :type "lisp" :version nil
                                     :defaults cl-ppcre-base-directory)))
        ;; don't use COMPILE-FILE in Corman Lisp, it's broken - LOAD
        ;; will yield compiled functions anyway
        #-:cormanlisp
        (let ((compiled-pathname (compile-file-pathname pathname)))
          (unless (and (not must-compile)
                       (probe-file compiled-pathname)
                       (< (file-write-date pathname)
                          (file-write-date compiled-pathname)))
            (setq must-compile t)
            (compile-file pathname))
          (setq pathname compiled-pathname))
        (load pathname)))))




#+END_SRC

** [[/Users/Can/Develop/Lisp/document/pcl/code/libraries/cl-ppcre-1.2.3/lexer.lisp][lexer]]
#+BEGIN_SRC lisp 
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-PPCRE; Base: 10 -*-
;;; $Header: /usr/local/cvsrep/cl-ppcre/lexer.lisp,v 1.21 2004/09/30 09:58:42 edi Exp $

;;; The lexer's responsibility is to convert the regex string into a
;;; sequence of tokens which are in turn consumed by the parser.
;;;
;;; The lexer is aware of Perl's 'extended mode' and it also 'knows'
;;; (with a little help from the parser) how many register groups it
;;; has opened so far. (The latter is necessary for interpreting
;;; strings like "\\10" correctly.)

;;; Copyright (c) 2002-2004, Dr. Edmund Weitz. All rights reserved.

;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:

;;;   * Redistributions of source code must retain the above copyright
;;;     notice, this list of conditions and the following disclaimer.

;;;   * Redistributions in binary form must reproduce the above
;;;     copyright notice, this list of conditions and the following
;;;     disclaimer in the documentation and/or other materials
;;;     provided with the distribution.

;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

(in-package #:cl-ppcre)

(declaim (inline map-char-to-special-class))
(defun map-char-to-special-char-class (chr)
  (declare (optimize speed
                     (safety 0)
                     (space 0)
                     (debug 0)
                     (compilation-speed 0)
                     #+:lispworks (hcl:fixnum-safety 0)))
  "Maps escaped characters like \"\\d\" to the tokens which represent
their associated character classes."
  (case chr
    ((#\d)
      :digit-class)
    ((#\D)
      :non-digit-class)
    ((#\w)
      :word-char-class)
    ((#\W)
      :non-word-char-class)
    ((#\s)
      :whitespace-char-class)
    ((#\S)
      :non-whitespace-char-class)))

(locally
  (declare (optimize speed
                     (safety 0)
                     (space 0)
                     (debug 0)
                     (compilation-speed 0)
                     #+:lispworks (hcl:fixnum-safety 0)))
  (defstruct (lexer (:constructor make-lexer-internal))
    "LEXER structures are used to hold the regex string which is
currently lexed and to keep track of the lexer's state."
    (str ""
         :type string
         :read-only t)
    (len 0
         :type fixnum
         :read-only t)
    (reg 0
         :type fixnum)
    (pos 0
         :type fixnum)
    (last-pos nil
              :type list)))

(defun make-lexer (string)
  (declare (inline make-lexer-internal)
           #-genera (type string string))
  (make-lexer-internal :str (maybe-coerce-to-simple-string string)
                       :len (length string)))

(declaim (inline end-of-string-p))
(defun end-of-string-p (lexer)
  (declare (optimize speed
                     (safety 0)
                     (space 0)
                     (debug 0)
                     (compilation-speed 0)
                     #+:lispworks (hcl:fixnum-safety 0)))
  "Tests whether we're at the end of the regex string."
  (<= (lexer-len lexer)
      (lexer-pos lexer)))

(declaim (inline looking-at-p))
(defun looking-at-p (lexer chr)
  (declare (optimize speed
                     (safety 0)
                     (space 0)
                     (debug 0)
                     (compilation-speed 0)
                     #+:lispworks (hcl:fixnum-safety 0)))
  "Tests whether the next character the lexer would see is CHR.
Does not respect extended mode."
  (and (not (end-of-string-p lexer))
       (char= (schar (lexer-str lexer) (lexer-pos lexer))
              chr)))

(declaim (inline next-char-non-extended))
(defun next-char-non-extended (lexer)
  (declare (optimize speed
                     (safety 0)
                     (space 0)
                     (debug 0)
                     (compilation-speed 0)
                     #+:lispworks (hcl:fixnum-safety 0)))
  "Returns the next character which is to be examined and updates the
POS slot. Does not respect extended mode."
  (cond ((end-of-string-p lexer)
          nil)
        (t
          (prog1
            (schar (lexer-str lexer) (lexer-pos lexer))
            (incf (lexer-pos lexer))))))

(defun next-char (lexer)
  (declare (optimize speed
                     (safety 0)
                     (space 0)
                     (debug 0)
                     (compilation-speed 0)
                     #+:lispworks (hcl:fixnum-safety 0)))
  "Returns the next character which is to be examined and updates the
POS slot. Respects extended mode, i.e.  whitespace, comments, and also
nested comments are skipped if applicable."
  (let ((next-char (next-char-non-extended lexer))
        last-loop-pos)
    (loop
      ;; remember where we started
      (setq last-loop-pos (lexer-pos lexer))
      ;; first we look for nested comments like (?#foo)
      (when (and next-char
                 (char= next-char #\()
                 (looking-at-p lexer #\?))
        (incf (lexer-pos lexer))
        (cond ((looking-at-p lexer #\#)
                ;; must be a nested comment - so we have to search for
                ;; the closing parenthesis
                (let ((error-pos (- (lexer-pos lexer) 2)))
                  (unless
                      ;; loop 'til ')' or end of regex string and
                      ;; return NIL if ')' wasn't encountered
                      (loop for skip-char = next-char
                            then (next-char-non-extended lexer)
                            while (and skip-char
                                       (char/= skip-char #\)))
                            finally (return skip-char))
                    (signal-ppcre-syntax-error*
                     error-pos
                     "Comment group not closed")))
                (setq next-char (next-char-non-extended lexer)))
              (t
                ;; undo effect of previous INCF if we didn't see a #
                (decf (lexer-pos lexer)))))
      (when *extended-mode-p*
        ;; now - if we're in extended mode - we skip whitespace and
        ;; comments; repeat the following loop while we look at
        ;; whitespace or #\#
        (loop while (and next-char
                         (or (char= next-char #\#)
                             (whitespacep next-char)))
              do (setq next-char
                         (if (char= next-char #\#)
                           ;; if we saw a comment marker skip until
                           ;; we're behind #\Newline...
                           (loop for skip-char = next-char
                                 then (next-char-non-extended lexer)
                                 while (and skip-char
                                            (char/= skip-char #\Newline))
                                 finally (return (next-char-non-extended lexer)))
                           ;; ...otherwise (whitespace) skip until we
                           ;; see the next non-whitespace character
                           (loop for skip-char = next-char
                                 then (next-char-non-extended lexer)
                                 while (and skip-char
                                            (whitespacep skip-char))
                                 finally (return skip-char))))))
      ;; if the position has moved we have to repeat our tests
      ;; because of cases like /^a (?#xxx) (?#yyy) {3}c/x which
      ;; would be equivalent to /^a{3}c/ in Perl
      (unless (> (lexer-pos lexer) last-loop-pos)
        (return next-char)))))

(declaim (inline fail))
(defun fail (lexer)
  (declare (optimize speed
                     (safety 0)
                     (space 0)
                     (debug 0)
                     (compilation-speed 0)
                     #+:lispworks (hcl:fixnum-safety 0)))
  "Moves (LEXER-POS LEXER) back to the last position stored in
\(LEXER-LAST-POS LEXER) and pops the LAST-POS stack."
  (unless (lexer-last-pos lexer)
    (signal-ppcre-syntax-error "LAST-POS stack of LEXER ~A is empty" lexer))
  (setf (lexer-pos lexer) (pop (lexer-last-pos lexer)))
  nil)

(defun get-number (lexer &key (radix 10) max-length no-whitespace-p)
  (declare (optimize speed
                     (safety 0)
                     (space 0)
                     (debug 0)
                     (compilation-speed 0)
                     #+:lispworks (hcl:fixnum-safety 0)))
  "Read and consume the number the lexer is currently looking at and
return it. Returns NIL if no number could be identified.
RADIX is used as in PARSE-INTEGER. If MAX-LENGTH is not NIL we'll read
at most the next MAX-LENGTH characters. If NO-WHITESPACE-P is not NIL
we don't tolerate whitespace in front of the number."
  (when (or (end-of-string-p lexer)
            (and no-whitespace-p
                 (whitespacep (schar (lexer-str lexer) (lexer-pos lexer)))))
    (return-from get-number nil))
  (multiple-value-bind (integer new-pos)
      (parse-integer (lexer-str lexer)
                     :start (lexer-pos lexer)
                     :end (if max-length
                            (let ((end-pos (+ (lexer-pos lexer)
                                              (the fixnum max-length)))
                                  (lexer-len (lexer-len lexer)))
                              (if (< end-pos lexer-len)
                                end-pos
                                lexer-len))
                            (lexer-len lexer))
                     :radix radix
                     :junk-allowed t)
    (cond ((and integer (>= (the fixnum integer) 0))
            (setf (lexer-pos lexer) new-pos)
            integer)
          (t nil))))

(declaim (inline try-number))
(defun try-number (lexer &key (radix 10) max-length no-whitespace-p)
  (declare (optimize speed
                     (safety 0)
                     (space 0)
                     (debug 0)
                     (compilation-speed 0)
                     #+:lispworks (hcl:fixnum-safety 0)))
  "Like GET-NUMBER but won't consume anything if no number is seen."
  ;; remember current position
  (push (lexer-pos lexer) (lexer-last-pos lexer))
  (let ((number (get-number lexer
                            :radix radix
                            :max-length max-length
                            :no-whitespace-p no-whitespace-p)))
    (or number (fail lexer))))

(declaim (inline make-char-from-code))
(defun make-char-from-code (number error-pos)
  (declare (optimize speed
                     (safety 0)
                     (space 0)
                     (debug 0)
                     (compilation-speed 0)
                     #+:lispworks (hcl:fixnum-safety 0)))
  "Create character from char-code NUMBER. NUMBER can be NIL
which is interpreted as 0. ERROR-POS is the position where
the corresponding number started within the regex string."
  ;; Only look at rightmost eight bits in compliance with Perl
  (let ((code (logand #o377 (the fixnum (or number 0)))))
    (or (and (< code char-code-limit)
             (code-char code))
        (signal-ppcre-syntax-error*
         error-pos
         "No character for hex-code ~X"
         number))))

(defun unescape-char (lexer)
  (declare (optimize speed
                     (safety 0)
                     (space 0)
                     (debug 0)
                     (compilation-speed 0)
                     #+:lispworks (hcl:fixnum-safety 0)))
  "Convert the characters(s) following a backslash into a token
which is returned. This function is to be called when the backslash
has already been consumed. Special character classes like \\W are
handled elsewhere."
  (when (end-of-string-p lexer)
    (signal-ppcre-syntax-error "String ends with backslash"))
  (let ((chr (next-char-non-extended lexer)))
    (case chr
      ((#\E)
        ;; if \Q quoting is on this is ignored, otherwise it's just an
        ;; #\E
        (if *allow-quoting*
          :void
          #\E))
      ((#\c)
        ;; \cx means control-x in Perl
        (let ((next-char (next-char-non-extended lexer)))
          (unless next-char
            (signal-ppcre-syntax-error*
             (lexer-pos lexer)
             "Character missing after '\\c' at position ~A"))
          (code-char (logxor #x40 (char-code (char-upcase next-char))))))
      ((#\x)
        ;; \x should be followed by a hexadecimal char code,
        ;; two digits or less
        (let* ((error-pos (lexer-pos lexer))
               (number (get-number lexer :radix 16 :max-length 2 :no-whitespace-p t)))
          ;; note that it is OK if \x is followed by zero digits
          (make-char-from-code number error-pos)))
      ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
        ;; \x should be followed by an octal char code,
        ;; three digits or less
        (let* ((error-pos (decf (lexer-pos lexer)))
               (number (get-number lexer :radix 8 :max-length 3)))
          (make-char-from-code number error-pos)))
      ;; the following five character names are 'semi-standard'
      ;; according to the CLHS but I'm not aware of any implementation
      ;; that doesn't implement them
      ((#\t)
        #\Tab)
      ((#\n)
        #\Newline)
      ((#\r)
        #\Return)
      ((#\f)
        #\Page)
      ((#\b)
        #\Backspace)
      ((#\a)
        (code-char 7))                  ; ASCII bell
      ((#\e)
        (code-char 27))                 ; ASCII escape
      (otherwise
        ;; all other characters aren't affected by a backslash
        chr))))

(defun collect-char-class (lexer)
  (declare (optimize speed
                     (safety 0)
                     (space 0)
                     (debug 0)
                     (compilation-speed 0)
                     #+:lispworks (hcl:fixnum-safety 0)))
  "Reads and consumes characters from regex string until a right
bracket is seen. Assembles them into a list \(which is returned) of
characters, character ranges, like \(:RANGE #\\A #\\E) for a-e, and
tokens representing special character classes."
  (let ((start-pos (lexer-pos lexer))         ; remember start for error message
        hyphen-seen
        last-char
        list)
    (flet ((handle-char (c)
             "Do the right thing with character C depending on whether
we're inside a range or not."
             (cond ((and hyphen-seen last-char)
                     (setf (car list) (list :range last-char c)
                           last-char nil))
                   (t
                     (push c list)
                     (setq last-char c)))
             (setq hyphen-seen nil)))
      (loop for first = t then nil
            for c = (next-char-non-extended lexer)
            ;; leave loop if at end of string
            while c
            do (cond
                 ((char= c #\\)
                   ;; we've seen a backslash
                   (let ((next-char (next-char-non-extended lexer)))
                     (case next-char
                       ((#\d #\D #\w #\W #\s #\S)
                         ;; a special character class
                         (push (map-char-to-special-char-class next-char) list)
                         ;; if the last character was a hyphen
                         ;; just collect it literally
                         (when hyphen-seen
                           (push #\- list))
                         ;; if the next character is a hyphen do the same
                         (when (looking-at-p lexer #\-)
                           (push #\- list)
                           (incf (lexer-pos lexer)))
                         (setq hyphen-seen nil))
                       ((#\E)
                         ;; if \Q quoting is on we ignore \E,
                         ;; otherwise it's just a plain #\E
                         (unless *allow-quoting*
                           (handle-char #\E)))
                       (otherwise
                         ;; otherwise unescape the following character(s)
                         (decf (lexer-pos lexer))
                         (handle-char (unescape-char lexer))))))
                 (first
                   ;; the first character must not be a right bracket
                   ;; and isn't treated specially if it's a hyphen
                   (handle-char c))
                 ((char= c #\])
                   ;; end of character class
                   ;; make sure we collect a pending hyphen
                   (when hyphen-seen
                     (setq hyphen-seen nil)
                     (handle-char #\-))
                   ;; reverse the list to preserve the order intended
                   ;; by the author of the regex string
                   (return-from collect-char-class (nreverse list)))
                 ((and (char= c #\-)
                       last-char
                       (not hyphen-seen))
                   ;; if the last character was 'just a character'
                   ;; we expect to be in the middle of a range
                   (setq hyphen-seen t))
                 ((char= c #\-)
                   ;; otherwise this is just an ordinary hyphen
                   (handle-char #\-))
                 (t
                   ;; default case - just collect the character
                   (handle-char c))))
      ;; we can only exit the loop normally if we've reached the end
      ;; of the regex string without seeing a right bracket
      (signal-ppcre-syntax-error*
       start-pos
       "Missing right bracket to close character class"))))

(defun maybe-parse-flags (lexer)
  (declare (optimize speed
                     (safety 0)
                     (space 0)
                     (debug 0)
                     (compilation-speed 0)
                     #+:lispworks (hcl:fixnum-safety 0)))
  "Reads a sequence of modifiers \(including #\\- to reverse their
meaning) and returns a corresponding list of \"flag\" tokens.  The
\"x\" modifier is treated specially in that it dynamically modifies
the behaviour of the lexer itself via the special variable
*EXTENDED-MODE-P*."
  (prog1
    (loop with set = t
          for chr = (next-char-non-extended lexer)
          unless chr
            do (signal-ppcre-syntax-error "Unexpected end of string")
          while (find chr "-imsx" :test #'char=)
          ;; the first #\- will invert the meaning of all modifiers
          ;; following it
          if (char= chr #\-)
            do (setq set nil)
          else if (char= chr #\x)
            do (setq *extended-mode-p* set)
          else collect (if set
                         (case chr
                           ((#\i)
                             :case-insensitive-p)
                           ((#\m)
                             :multi-line-mode-p)
                           ((#\s)
                             :single-line-mode-p))
                         (case chr
                           ((#\i)
                             :case-sensitive-p)
                           ((#\m)
                             :not-multi-line-mode-p)
                           ((#\s)
                             :not-single-line-mode-p))))
    (decf (lexer-pos lexer))))

(defun get-quantifier (lexer)
  (declare (optimize speed
                     (safety 0)
                     (space 0)
                     (debug 0)
                     (compilation-speed 0)
                     #+:lispworks (hcl:fixnum-safety 0)))
  "Returns a list of two values (min max) if what the lexer is looking
at can be interpreted as a quantifier. Otherwise returns NIL and
resets the lexer to its old position."
  ;; remember starting position for FAIL and UNGET-TOKEN functions
  (push (lexer-pos lexer) (lexer-last-pos lexer))
  (let ((next-char (next-char lexer)))
    (case next-char
      ((#\*)
        ;; * (Kleene star): match 0 or more times
        '(0 nil))
      ((#\+)
        ;; +: match 1 or more times
        '(1 nil))
      ((#\?)
        ;; ?: match 0 or 1 times
        '(0 1))
      ((#\{)
        ;; one of
        ;;   {n}:   match exactly n times
        ;;   {n,}:  match at least n times
        ;;   {n,m}: match at least n but not more than m times
        ;; note that anything not matching one of these patterns will
        ;; be interpreted literally - even whitespace isn't allowed
        (let ((num1 (get-number lexer :no-whitespace-p t)))
          (if num1
            (let ((next-char (next-char-non-extended lexer)))
              (case next-char
                ((#\,)
                  (let* ((num2 (get-number lexer :no-whitespace-p t))
                         (next-char (next-char-non-extended lexer)))
                    (case next-char
                      ((#\})
                        ;; this is the case {n,} (NUM2 is NIL) or {n,m}
                        (list num1 num2))
                      (otherwise
                        (fail lexer)))))
                ((#\})
                  ;; this is the case {n}
                  (list num1 num1))
                (otherwise
                  (fail lexer))))
            ;; no number following left curly brace, so we treat it
            ;; like a normal character
            (fail lexer))))
      ;; cannot be a quantifier
      (otherwise
        (fail lexer)))))

(defun get-token (lexer)
  (declare (optimize speed
                     (safety 0)
                     (space 0)
                     (debug 0)
                     (compilation-speed 0)
                     #+:lispworks (hcl:fixnum-safety 0)))
  "Returns and consumes the next token from the regex string (or NIL)."
  ;; remember starting position for UNGET-TOKEN function
  (push (lexer-pos lexer)
        (lexer-last-pos lexer))
  (let ((next-char (next-char lexer)))
    (cond (next-char
            (case next-char
              ;; the easy cases first - the following six characters
              ;; always have a special meaning and get translated
              ;; into tokens immediately
              ((#\))
                :close-paren)
              ((#\|)
                :vertical-bar)
              ((#\?)
                :question-mark)
              ((#\.)
                :everything)
              ((#\^)
                :start-anchor)
              ((#\$)
                :end-anchor)
              ((#\+ #\*)
                ;; quantifiers will always be consumend by
                ;; GET-QUANTIFIER, they must not appear here
                (signal-ppcre-syntax-error*
                 (1- (lexer-pos lexer))
                 "Quantifier '~A' not allowed"
                 next-char))
              ((#\{)
                ;; left brace isn't a special character in it's own
                ;; right but we must check if what follows might
                ;; look like a quantifier
                (let ((this-pos (lexer-pos lexer))
                      (this-last-pos (lexer-last-pos lexer)))
                  (unget-token lexer)
                  (when (get-quantifier lexer)
                    (signal-ppcre-syntax-error*
                     (car this-last-pos)
                     "Quantifier '~A' not allowed"
                     (subseq (lexer-str lexer)
                             (car this-last-pos)
                             (lexer-pos lexer))))
                  (setf (lexer-pos lexer) this-pos
                        (lexer-last-pos lexer) this-last-pos)
                  next-char))
              ((#\[)
                ;; left bracket always starts a character class
                (cons  (cond ((looking-at-p lexer #\^)
                               (incf (lexer-pos lexer))
                               :inverted-char-class)
                             (t
                               :char-class))
                       (collect-char-class lexer)))
              ((#\\)
                ;; backslash might mean different things so we have
                ;; to peek one char ahead:
                (let ((next-char (next-char-non-extended lexer)))
                  (case next-char
                    ((#\A)
                      :modeless-start-anchor)
                    ((#\Z)
                      :modeless-end-anchor)
                    ((#\z)
                      :modeless-end-anchor-no-newline)
                    ((#\b)
                      :word-boundary)
                    ((#\B)
                      :non-word-boundary)
                    ((#\d #\D #\w #\W #\s #\S)
                      ;; these will be treated like character classes
                      (map-char-to-special-char-class next-char))
                    ((#\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
                      ;; uh, a digit...
                      (let* ((old-pos (decf (lexer-pos lexer)))
                             ;; ...so let's get the whole number first
                             (backref-number (get-number lexer)))
                        (declare (type fixnum backref-number))
                        (cond ((and (> backref-number (lexer-reg lexer))
                                    (<= 10 backref-number))
                                ;; \10 and higher are treated as octal
                                ;; character codes if we haven't
                                ;; opened that much register groups
                                ;; yet
                                (setf (lexer-pos lexer) old-pos)
                                ;; re-read the number from the old
                                ;; position and convert it to its
                                ;; corresponding character
                                (make-char-from-code (get-number lexer :radix 8 :max-length 3)
                                                     old-pos))
                              (t
                                ;; otherwise this must refer to a
                                ;; backreference
                                (list :back-reference backref-number)))))
                    ((#\0)
                      ;; this always means an octal character code
                      ;; (at most three digits)
                      (let ((old-pos (decf (lexer-pos lexer))))
                        (make-char-from-code (get-number lexer :radix 8 :max-length 3)
                                             old-pos)))
                    (otherwise
                      ;; in all other cases just unescape the
                      ;; character
                      (decf (lexer-pos lexer))
                      (unescape-char lexer)))))
              ((#\()
                ;; an open parenthesis might mean different things
                ;; depending on what follows...
                (cond ((looking-at-p lexer #\?)
                        ;; this is the case '(?' (and probably more behind)
                        (incf (lexer-pos lexer))
                        ;; we have to check for modifiers first
                        ;; because a colon might follow
                        (let* ((flags (maybe-parse-flags lexer))
                               (next-char (next-char-non-extended lexer)))
                          ;; modifiers are only allowed if a colon
                          ;; or a closing parenthesis are following
                          (when (and flags
                                     (not (find next-char ":)" :test #'char=)))
                            (signal-ppcre-syntax-error*
                             (car (lexer-last-pos lexer))
                             "Sequence '~A' not recognized"
                             (subseq (lexer-str lexer)
                                     (car (lexer-last-pos lexer))
                                     (lexer-pos lexer))))
                          (case next-char
                            ((nil)
                              ;; syntax error
                              (signal-ppcre-syntax-error
                               "End of string following '(?'"))
                            ((#\))
                              ;; an empty group except for the flags
                              ;; (if there are any)
                              (or (and flags
                                       (cons :flags flags))
                                  :void))
                            ((#\()
                              ;; branch
                              :open-paren-paren)
                            ((#\>)
                              ;; standalone
                              :open-paren-greater)
                            ((#\=)
                              ;; positive look-ahead
                              :open-paren-equal)
                            ((#\!)
                              ;; negative look-ahead
                              :open-paren-exclamation)
                            ((#\:)
                              ;; non-capturing group - return flags as
                              ;; second value
                              (values :open-paren-colon flags))
                            ((#\<)
                              ;; might be a look-behind assertion, so
                              ;; check next character
                              (let ((next-char (next-char-non-extended lexer)))
                                (case next-char
                                  ((#\=)
                                    ;; positive look-behind
                                    :open-paren-less-equal)
                                  ((#\!)
                                    ;; negative look-behind
                                    :open-paren-less-exclamation)
                                  ((#\))
                                    ;; Perl allows "(?<)" and treats
                                    ;; it like a null string
                                    :void)
                                  ((nil)
                                    ;; syntax error
                                    (signal-ppcre-syntax-error
                                     "End of string following '(?<'"))
                                  (t
                                    ;; also syntax error
                                    (signal-ppcre-syntax-error*
                                     (1- (lexer-pos lexer))
                                     "Character '~A' may not follow '(?<'"
                                     next-char )))))
                            (otherwise
                              (signal-ppcre-syntax-error*
                               (1- (lexer-pos lexer))
                               "Character '~A' may not follow '(?'"
                               next-char)))))
                      (t
                        ;; if next-char was not #\? (this is within
                        ;; the first COND), we've just seen an opening
                        ;; parenthesis and leave it like that
                        :open-paren)))
              (otherwise
                ;; all other characters are their own tokens
                next-char)))
          ;; we didn't get a character (this if the "else" branch from
          ;; the first IF), so we don't return a token but NIL
          (t
            (pop (lexer-last-pos lexer))
            nil))))

(declaim (inline unget-token))
(defun unget-token (lexer)
  (declare (optimize speed
                     (safety 0)
                     (space 0)
                     (debug 0)
                     (compilation-speed 0)
                     #+:lispworks (hcl:fixnum-safety 0)))
  "Moves the lexer back to the last position stored in the LAST-POS stack."
  (if (lexer-last-pos lexer)
    (setf (lexer-pos lexer)
            (pop (lexer-last-pos lexer)))
    (error "No token to unget \(this should not happen)")))

(declaim (inline start-of-subexpr-p))
(defun start-of-subexpr-p (lexer)
  (declare (optimize speed
                     (safety 0)
                     (space 0)
                     (debug 0)
                     (compilation-speed 0)
                     #+:lispworks (hcl:fixnum-safety 0)))
  "Tests whether the next token can start a valid sub-expression, i.e.
a stand-alone regex."
  (let* ((pos (lexer-pos lexer))
         (next-char (next-char lexer)))
    (not (or (null next-char)
             (prog1
               (member (the character next-char)
                       '(#\) #\|)
                       :test #'char=)
               (setf (lexer-pos lexer) pos))))))

#+END_SRC

** [[/Users/Can/Develop/Lisp/document/pcl/code/libraries/cl-ppcre-1.2.3/errors.lisp][errors]]
#+BEGIN_SRC lisp 
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-PPCRE; Base: 10 -*-
;;; $Header: /usr/local/cvsrep/cl-ppcre/errors.lisp,v 1.13 2004/09/30 09:58:42 edi Exp $

;;; Copyright (c) 2002-2004, Dr. Edmund Weitz. All rights reserved.

;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:

;;;   * Redistributions of source code must retain the above copyright
;;;     notice, this list of conditions and the following disclaimer.

;;;   * Redistributions in binary form must reproduce the above
;;;     copyright notice, this list of conditions and the following
;;;     disclaimer in the documentation and/or other materials
;;;     provided with the distribution.

;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

(in-package #:cl-ppcre)

(defvar *syntax-error-string* nil
  "The string which caused the syntax error.")

(define-condition ppcre-error (simple-error)
  ()
  (:documentation "All errors signaled by CL-PPCRE are of
this type."))

(define-condition ppcre-syntax-error (ppcre-error)
  ((string :initarg :string
           :reader ppcre-syntax-error-string)
   (pos :initarg :pos
        :reader ppcre-syntax-error-pos))
  (:default-initargs
      :pos nil
      :string *syntax-error-string*)
  (:report (lambda (condition stream)
             (format stream "~?~@[ at position ~A~]~@[ in string ~S~]"
                     (simple-condition-format-control condition)
                     (simple-condition-format-arguments condition)
                     (ppcre-syntax-error-pos condition)
                     (ppcre-syntax-error-string condition))))
  (:documentation "Signaled if CL-PPCRE's parser encounters an error
when trying to parse a regex string or to convert a parse tree into
its internal representation."))

(setf (documentation 'ppcre-syntax-error-string 'function)
      "Returns the string the parser was parsing when the error was
encountered \(or NIL if the error happened while trying to convert a
parse tree).")

(setf (documentation 'ppcre-syntax-error-pos 'function)
      "Returns the position within the string where the error occured
\(or NIL if the error happened while trying to convert a parse tree")

(define-condition ppcre-invocation-error (ppcre-error)
  ()
  (:documentation "Signaled when CL-PPCRE functions are
invoked with wrong arguments."))

(defmacro signal-ppcre-syntax-error* (pos format-control &rest format-arguments)
  `(error 'ppcre-syntax-error
          :pos ,pos
          :format-control ,format-control
          :format-arguments (list ,@format-arguments)))

(defmacro signal-ppcre-syntax-error (format-control &rest format-arguments)
  `(signal-ppcre-syntax-error* nil ,format-control ,@format-arguments))

(defmacro signal-ppcre-invocation-error (format-control &rest format-arguments)
  `(error 'ppcre-invocation-error
          :format-control ,format-control
          :format-arguments (list ,@format-arguments)))

#+END_SRC

** [[/Users/Can/Develop/Lisp/document/pcl/code/libraries/cl-ppcre-1.2.3/convert.lisp][convert]]
#+BEGIN_SRC lisp 
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-PPCRE; Base: 10 -*-
;;; $Header: /usr/local/cvsrep/cl-ppcre/convert.lisp,v 1.19 2004/10/14 12:40:39 edi Exp $

;;; Here the parse tree is converted into its internal representation
;;; using REGEX objects.  At the same time some optimizations are
;;; already applied.

;;; Copyright (c) 2002-2004, Dr. Edmund Weitz. All rights reserved.

;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:

;;;   * Redistributions of source code must retain the above copyright
;;;     notice, this list of conditions and the following disclaimer.

;;;   * Redistributions in binary form must reproduce the above
;;;     copyright notice, this list of conditions and the following
;;;     disclaimer in the documentation and/or other materials
;;;     provided with the distribution.

;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

(in-package #:cl-ppcre)

;;; The flags that represent the "ism" modifiers are always kept
;;; together in a three-element list. We use the following macros to
;;; access individual elements.

(defmacro case-insensitive-mode-p (flags)
  "Accessor macro to extract the first flag out of a three-element flag list."
  `(first ,flags))

(defmacro multi-line-mode-p (flags)
  "Accessor macro to extract the second flag out of a three-element flag list."
  `(second ,flags))

(defmacro single-line-mode-p (flags)
  "Accessor macro to extract the third flag out of a three-element flag list."
  `(third ,flags))

(defun set-flag (token)
  (declare (optimize speed
                     (safety 0)
                     (space 0)
                     (debug 0)
                     (compilation-speed 0)
                     #+:lispworks (hcl:fixnum-safety 0)))
  (declare (special flags))
  "Reads a flag token and sets or unsets the corresponding entry in
the special FLAGS list."
  (case token
    ((:case-insensitive-p)
      (setf (case-insensitive-mode-p flags) t))
    ((:case-sensitive-p)
      (setf (case-insensitive-mode-p flags) nil))
    ((:multi-line-mode-p)
      (setf (multi-line-mode-p flags) t))
    ((:not-multi-line-mode-p)
      (setf (multi-line-mode-p flags) nil))
    ((:single-line-mode-p)
      (setf (single-line-mode-p flags) t))
    ((:not-single-line-mode-p)
      (setf (single-line-mode-p flags) nil))
    (otherwise
      (signal-ppcre-syntax-error "Unknown flag token ~A" token))))

(defun add-range-to-hash (hash from to)
  (declare (optimize speed
                     (safety 0)
                     (space 0)
                     (debug 0)
                     (compilation-speed 0)
                     #+:lispworks (hcl:fixnum-safety 0)))
  (declare (special flags))
  "Adds all characters from character FROM to character TO (inclusive)
to the char class hash HASH. Does the right thing with respect to
case-(in)sensitivity as specified by the special variable FLAGS."
  (let ((from-code (char-code from))
        (to-code (char-code to)))
    (when (> from-code to-code)
      (signal-ppcre-syntax-error "Invalid range from ~A to ~A in char-class"
                                 from to))
    (cond ((case-insensitive-mode-p flags)
            (loop for code from from-code to to-code
                  for chr = (code-char code)
                  do (setf (gethash (char-upcase chr) hash) t
                           (gethash (char-downcase chr) hash) t)))
          (t
            (loop for code from from-code to to-code
                  do (setf (gethash (code-char code) hash) t))))
    hash))

(defun convert-char-class-to-hash (list)
  (declare (optimize speed
                     (safety 0)
                     (space 0)
                     (debug 0)
                     (compilation-speed 0)
                     #+:lispworks (hcl:fixnum-safety 0)))
  "Combines all items in LIST into one char class hash and returns it.
Items can be single characters, character ranges like \(:RANGE #\\A
#\\E), or special character classes like :DIGIT-CLASS. Does the right
thing with respect to case-\(in)sensitivity as specified by the
special variable FLAGS."
  (loop with hash = (make-hash-table :size (ceiling (expt *regex-char-code-limit* (/ 1 4)))
                                     :rehash-size (float (expt *regex-char-code-limit* (/ 1 4)))
                                     :rehash-threshold #-genera 1.0 #+genera 0.99)
        for item in list
        if (characterp item)
          ;; treat a single character C like a range (:RANGE C C)
          do (add-range-to-hash hash item item)
        else if (symbolp item)
          ;; special character classes
          do (setq hash
                     (case item
                       ((:digit-class)
                         (merge-hash hash +digit-hash+))
                       ((:non-digit-class)
                         (merge-inverted-hash hash +digit-hash+))
                       ((:whitespace-char-class)
                         (merge-hash hash +whitespace-char-hash+))
                       ((:non-whitespace-char-class)
                         (merge-inverted-hash hash +whitespace-char-hash+))
                       ((:word-char-class)
                         (merge-hash hash +word-char-hash+))
                       ((:non-word-char-class)
                         (merge-inverted-hash hash +word-char-hash+))
                       (otherwise
                         (signal-ppcre-syntax-error
                          "Unknown symbol ~A in character class"
                          item))))
        else if (and (consp item)
                     (eq (car item) :range))
          ;; proper ranges
          do (add-range-to-hash hash
                                (second item)
                                (third item))
        else do (signal-ppcre-syntax-error "Unknown item ~A in char-class list"
                                           item)
        finally (return hash)))

(defun maybe-split-repetition (regex
                               greedyp
                               minimum
                               maximum
                               min-len
                               length
                               reg-seen)
  (declare (optimize speed
                     (safety 0)
                     (space 0)
                     (debug 0)
                     (compilation-speed 0)
                     #+:lispworks (hcl:fixnum-safety 0)))
  (declare (type fixnum minimum)
           (type (or fixnum null) maximum))
  "Splits a REPETITION object into a constant and a varying part if
applicable, i.e. something like
  a{3,} -> a{3}a*
The arguments to this function correspond to the REPETITION slots of
the same name."
  ;; note the usage of COPY-REGEX here; we can't use the same REGEX
  ;; object in both REPETITIONS because they will have different
  ;; offsets
  (when maximum
    (when (zerop maximum)
      ;; trivial case: don't repeat at all
      (return-from maybe-split-repetition
        (make-instance 'void)))
    (when (= 1 minimum maximum)
      ;; another trivial case: "repeat" exactly once
      (return-from maybe-split-repetition
        regex)))
  ;; first set up the constant part of the repetition
  ;; maybe that's all we need
  (let ((constant-repetition (if (plusp minimum)
                               (make-instance 'repetition
                                              :regex (copy-regex regex)
                                              :greedyp greedyp
                                              :minimum minimum
                                              :maximum minimum
                                              :min-len min-len
                                              :len length
                                              :contains-register-p reg-seen)
                               ;; don't create garbage if minimum is 0
                               nil)))
    (when (and maximum
               (= maximum minimum))
      (return-from maybe-split-repetition
        ;; no varying part needed because min = max
        constant-repetition))
    ;; now construct the varying part
    (let ((varying-repetition
            (make-instance 'repetition
                           :regex regex
                           :greedyp greedyp
                           :minimum 0
                           :maximum (if maximum (- maximum minimum) nil)
                           :min-len min-len
                           :len length
                           :contains-register-p reg-seen)))
      (cond ((zerop minimum)
              ;; min = 0, no constant part needed
              varying-repetition)
            ((= 1 minimum)
              ;; min = 1, constant part needs no REPETITION wrapped around
              (make-instance 'seq
                             :elements (list (copy-regex regex)
                                             varying-repetition)))
            (t
              ;; general case
              (make-instance 'seq
                             :elements (list constant-repetition
                                             varying-repetition)))))))

;; During the conversion of the parse tree we keep track of the start
;; of the parse tree in the special variable STARTS-WITH which'll
;; either hold a STR object or an EVERYTHING object. The latter is the
;; case if the regex starts with ".*" which implicitely anchors the
;; regex at the start (perhaps modulo #\Newline).

(defun maybe-accumulate (str)
  (declare (optimize speed
                     (safety 0)
                     (space 0)
                     (debug 0)
                     (compilation-speed 0)
                     #+:lispworks (hcl:fixnum-safety 0)))
  (declare (special accumulate-start-p starts-with))
  (declare (ftype (function (t) fixnum) len))
  "Accumulate STR into the special variable STARTS-WITH if
ACCUMULATE-START-P (also special) is true and STARTS-WITH is either
NIL or a STR object of the same case mode. Always returns NIL."
  (when accumulate-start-p
    (etypecase starts-with
      (str
        ;; STARTS-WITH already holds a STR, so we check if we can
        ;; concatenate
        (cond ((eq (case-insensitive-p starts-with)
                   (case-insensitive-p str))
                ;; we modify STARTS-WITH in place
                (setf (len starts-with)
                        (+ (len starts-with) (len str)))
                ;; note that we use SLOT-VALUE because the accessor
                ;; STR has a declared FTYPE which doesn't fit here
                (adjust-array (slot-value starts-with 'str)
                              (len starts-with)
                              :fill-pointer t)
                (setf (subseq (slot-value starts-with 'str)
                              (- (len starts-with) (len str)))
                        (str str)
                      ;; STR objects that are parts of STARTS-WITH
                      ;; always have their SKIP slot set to true
                      ;; because the SCAN function will take care of
                      ;; them, i.e. the matcher can ignore them
                      (skip str) t))
              (t (setq accumulate-start-p nil))))
      (null
        ;; STARTS-WITH is still empty, so we create a new STR object
        (setf starts-with
                (make-instance 'str
                               :str ""
                               :case-insensitive-p (case-insensitive-p str))
              ;; INITIALIZE-INSTANCE will coerce the STR to a simple
              ;; string, so we have to fill it afterwards
              (slot-value starts-with 'str)
                (make-array (len str)
                            :initial-contents (str str)
                            :element-type 'character
                            :fill-pointer t
                            :adjustable t)
              (len starts-with)
                (len str)
              ;; see remark about SKIP above
              (skip str) t))
      (everything
        ;; STARTS-WITH already holds an EVERYTHING object - we can't
        ;; concatenate
        (setq accumulate-start-p nil))))
  nil)

(defun convert-aux (parse-tree)
  (declare (optimize speed
                     (safety 0)
                     (space 0)
                     (debug 0)
                     (compilation-speed 0)
                     #+:lispworks (hcl:fixnum-safety 0)))
  (declare (special flags reg-num accumulate-start-p starts-with max-back-ref))
  "Converts the parse tree PARSE-TREE into a REGEX object and returns it.

Will also
  - split and optimize repetitions,
  - accumulate strings or EVERYTHING objects into the special variable
    STARTS-WITH,
  - keep track of all registers seen in the special variable REG-NUM,
  - keep track of the highest backreference seen in the special
    variable MAX-BACK-REF,
  - maintain and adher to the currently applicable modifiers in the special
    variable FLAGS, and
  - maybe even wash your car..."
  (cond ((consp parse-tree)
          (case (first parse-tree)
            ;; (:SEQUENCE {<regex>}*)
            ((:sequence)
              (cond ((cddr parse-tree)
                      ;; this is essentially like
                      ;; (MAPCAR 'CONVERT-AUX (REST PARSE-TREE))
                      ;; but we don't cons a new list
                      (loop for parse-tree-rest on (rest parse-tree)
                            while parse-tree-rest
                            do (setf (car parse-tree-rest)
                                       (convert-aux (car parse-tree-rest))))
                      (make-instance 'seq
                                     :elements (rest parse-tree)))
                    (t (convert-aux (second parse-tree)))))
            ;; (:GROUP {<regex>}*)
            ;; this is a syntactical construct equivalent to :SEQUENCE
            ;; intended to keep the effect of modifiers local
            ((:group)
              ;; make a local copy of FLAGS and shadow the global
              ;; value while we descend into the enclosed regexes
              (let ((flags (copy-list flags)))
                (declare (special flags))
                (cond ((cddr parse-tree)
                        (loop for parse-tree-rest on (rest parse-tree)
                              while parse-tree-rest
                              do (setf (car parse-tree-rest)
                                         (convert-aux (car parse-tree-rest))))
                        (make-instance 'seq
                                       :elements (rest parse-tree)))
                      (t (convert-aux (second parse-tree))))))
            ;; (:ALTERNATION {<regex>}*)
            ((:alternation)
              ;; we must stop accumulating objects into STARTS-WITH
              ;; once we reach an alternation
              (setq accumulate-start-p nil)
              (loop for parse-tree-rest on (rest parse-tree)
                    while parse-tree-rest
                    do (setf (car parse-tree-rest)
                               (convert-aux (car parse-tree-rest))))
              (make-instance 'alternation
                             :choices (rest parse-tree)))
            ;; (:BRANCH <test> <regex>)
            ;; <test> must be look-ahead, look-behind or number;
            ;; if <regex> is an alternation it must have one or two
            ;; choices
            ((:branch)
              (setq accumulate-start-p nil)
              (let* ((test-candidate (second parse-tree))
                     (test (cond ((numberp test-candidate)
                                   (when (zerop (the fixnum test-candidate))
                                     (signal-ppcre-syntax-error
                                      "Register 0 doesn't exist: ~S"
                                      parse-tree))
                                   (1- (the fixnum test-candidate)))
                                 (t (convert-aux test-candidate))))
                     (alternations (convert-aux (third parse-tree))))
                (when (and (not (numberp test))
                           (not (typep test 'lookahead))
                           (not (typep test 'lookbehind)))
                  (signal-ppcre-syntax-error
                   "Branch test must be look-ahead, look-behind or number: ~S"
                   parse-tree))
                (typecase alternations
                  (alternation
                    (case (length (choices alternations))
                      ((0)
                        (signal-ppcre-syntax-error "No choices in branch: ~S"
                                                   parse-tree))
                      ((1)
                        (make-instance 'branch
                                       :test test
                                       :then-regex (first
                                                    (choices alternations))))
                      ((2)
                        (make-instance 'branch
                                       :test test
                                       :then-regex (first
                                                    (choices alternations))
                                       :else-regex (second
                                                    (choices alternations))))
                      (otherwise
                        (signal-ppcre-syntax-error
                         "Too much choices in branch: ~S"
                         parse-tree))))
                  (t
                    (make-instance 'branch
                                   :test test
                                   :then-regex alternations)))))
            ;; (:POSITIVE-LOOKAHEAD|:NEGATIVE-LOOKAHEAD <regex>)
            ((:positive-lookahead :negative-lookahead)
              ;; keep the effect of modifiers local to the enclosed
              ;; regex and stop accumulating into STARTS-WITH
              (setq accumulate-start-p nil)
              (let ((flags (copy-list flags)))
                (declare (special flags))
                (make-instance 'lookahead
                               :regex (convert-aux (second parse-tree))
                               :positivep (eq (first parse-tree)
                                              :positive-lookahead))))
            ;; (:POSITIVE-LOOKBEHIND|:NEGATIVE-LOOKBEHIND <regex>)
            ((:positive-lookbehind :negative-lookbehind)
              ;; keep the effect of modifiers local to the enclosed
              ;; regex and stop accumulating into STARTS-WITH
              (setq accumulate-start-p nil)
              (let* ((flags (copy-list flags))
                     (regex (convert-aux (second parse-tree)))
                     (len (regex-length regex)))
                (declare (special flags))
                ;; lookbehind assertions must be of fixed length
                (unless len
                  (signal-ppcre-syntax-error
                   "Variable length look-behind not implemented (yet): ~S"
                   parse-tree))
                (make-instance 'lookbehind
                               :regex regex
                               :positivep (eq (first parse-tree)
                                              :positive-lookbehind)
                               :len len)))
            ;; (:GREEDY-REPETITION|:NON-GREEDY-REPETITION <min> <max> <regex>)
            ((:greedy-repetition :non-greedy-repetition)
              ;; remember the value of ACCUMULATE-START-P upon entering
              (let ((local-accumulate-start-p accumulate-start-p))
                (let ((minimum (second parse-tree))
                      (maximum (third parse-tree)))
                  (declare (type fixnum minimum))
                  (declare (type (or null fixnum) maximum))
                  (unless (and maximum
                               (= 1 minimum maximum))
                    ;; set ACCUMULATE-START-P to NIL for the rest of
                    ;; the conversion because we can't continue to
                    ;; accumulate inside as well as after a proper
                    ;; repetition
                    (setq accumulate-start-p nil))
                  (let* (reg-seen
                         (regex (convert-aux (fourth parse-tree)))
                         (min-len (regex-min-length regex))
                         (greedyp (eq (first parse-tree) :greedy-repetition))
                         (length (regex-length regex)))
                    ;; note that this declaration already applies to
                    ;; the call to CONVERT-AUX above
                    (declare (special reg-seen))
                    (when (and local-accumulate-start-p
                               (not starts-with)
                               (zerop minimum)
                               (not maximum))
                      ;; if this repetition is (equivalent to) ".*"
                      ;; and if we're at the start of the regex we
                      ;; remember it for ADVANCE-FN (see the SCAN
                      ;; function)
                      (setq starts-with (everythingp regex)))
                    (if (or (not reg-seen)
                            (not greedyp)
                            (not length)
                            (zerop length)
                            (and maximum (= minimum maximum)))
                      ;; the repetition doesn't enclose a register, or
                      ;; it's not greedy, or we can't determine it's
                      ;; (inner) length, or the length is zero, or the
                      ;; number of repetitions is fixed; in all of
                      ;; these cases we don't bother to optimize
                      (maybe-split-repetition regex
                                              greedyp
                                              minimum
                                              maximum
                                              min-len
                                              length
                                              reg-seen)
                      ;; otherwise we make a transformation that looks
                      ;; roughly like one of
                      ;;   <regex>* -> (?:<regex'>*<regex>)?
                      ;;   <regex>+ -> <regex'>*<regex>
                      ;; where the trick is that as much as possible
                      ;; registers from <regex> are removed in
                      ;; <regex'>
                      (let* (reg-seen   ; new instance for REMOVE-REGISTERS
                             (remove-registers-p t)
                             (inner-regex (remove-registers regex))
                             (inner-repetition
                               ;; this is the "<regex'>" part
                               (maybe-split-repetition inner-regex
                                                       ;; always greedy
                                                       t
                                                       ;; reduce minimum by 1
                                                       ;; unless it's already 0
                                                       (if (zerop minimum)
                                                         0
                                                         (1- minimum))
                                                       ;; reduce maximum by 1
                                                       ;; unless it's NIL
                                                       (and maximum
                                                            (1- maximum))
                                                       min-len
                                                       length
                                                       reg-seen))
                             (inner-seq
                               ;; this is the "<regex'>*<regex>" part
                               (make-instance 'seq
                                              :elements (list inner-repetition
                                                              regex))))
                        ;; note that this declaration already applies
                        ;; to the call to REMOVE-REGISTERS above
                        (declare (special remove-registers-p reg-seen))
                        ;; wrap INNER-SEQ with a greedy
                        ;; {0,1}-repetition (i.e. "?") if necessary
                        (if (plusp minimum)
                          inner-seq
                          (maybe-split-repetition inner-seq
                                                  t
                                                  0
                                                  1
                                                  min-len
                                                  nil
                                                  t))))))))
            ;; (:REGISTER <regex>)
            ((:register)
              ;; keep the effect of modifiers local to the enclosed
              ;; regex; also, assign the current value of REG-NUM to
              ;; the corresponding slot of the REGISTER object and
              ;; increase this counter afterwards
              (let ((flags (copy-list flags))
                    (stored-reg-num reg-num))
                (declare (special flags reg-seen))
                (setq reg-seen t)
                (incf (the fixnum reg-num))
                (make-instance 'register
                               :regex (convert-aux (second parse-tree))
                               :num stored-reg-num)))
            ;; (:FILTER <function> &optional <length>)
            ((:filter)
              ;; stop accumulating into STARTS-WITH
              (setq accumulate-start-p nil)
              (make-instance 'filter
                             :fn (second parse-tree)
                             :len (third parse-tree)))
            ;; (:STANDALONE <regex>)
            ((:standalone)
              ;; stop accumulating into STARTS-WITH
              (setq accumulate-start-p nil)
              ;; keep the effect of modifiers local to the enclosed
              ;; regex
              (let ((flags (copy-list flags)))
                (declare (special flags))
                (make-instance 'standalone
                               :regex (convert-aux (second parse-tree)))))
            ;; (:BACK-REFERENCE <number>)
            ((:back-reference)
              (let ((backref-number (second parse-tree)))
                (declare (type fixnum backref-number))
                (when (or (not (typep backref-number 'fixnum))
                          (<= backref-number 0))
                  (signal-ppcre-syntax-error
                   "Illegal back-reference: ~S"
                   parse-tree))
                ;; stop accumulating into STARTS-WITH and increase
                ;; MAX-BACK-REF if necessary
                (setq accumulate-start-p nil
                      max-back-ref (max (the fixnum max-back-ref)
                                        backref-number))
                (make-instance 'back-reference
                               ;; we start counting from 0 internally
                               :num (1- backref-number)
                               :case-insensitive-p (case-insensitive-mode-p
                                                    flags))))
            ;; (:CHAR-CLASS|:INVERTED-CHAR-CLASS {<item>}*)
            ;; where item is one of
            ;;   - a character
            ;;   - a character range: (:RANGE <char1> <char2>)
            ;;   - a special char class symbol like :DIGIT-CHAR-CLASS
            ((:char-class :inverted-char-class)
              ;; first create the hash-table and some auxiliary values
              (let* (hash
                     hash-keys
                     (count most-positive-fixnum)
                     (item-list (rest parse-tree))
                     (invertedp (eq (first parse-tree) :inverted-char-class))
                     word-char-class-p)
                (cond ((every (lambda (item) (eq item :word-char-class))
                              item-list)
                        ;; treat "[\\w]" like "\\w"
                        (setq word-char-class-p t))
                      ((every (lambda (item) (eq item :non-word-char-class))
                              item-list)
                        ;; treat "[\\W]" like "\\W"
                        (setq word-char-class-p t)
                        (setq invertedp (not invertedp)))
                      (t
                        (setq hash (convert-char-class-to-hash item-list)
                              count (hash-table-count hash))
                        (when (<= count 2)
                          ;; collect the hash-table keys into a list if
                          ;; COUNT is smaller than 3
                          (setq hash-keys
                                  (loop for chr being the hash-keys of hash
                                        collect chr)))))
                (cond ((and (not invertedp)
                            (= count 1))
                        ;; convert one-element hash table into a STR
                        ;; object and try to accumulate into
                        ;; STARTS-WITH
                        (let ((str (make-instance 'str
                                                  :str (string
                                                        (first hash-keys))
                                                  :case-insensitive-p nil)))
                          (maybe-accumulate str)
                          str))
                      ((and (not invertedp)
                            (= count 2)
                            (char-equal (first hash-keys) (second hash-keys)))
                        ;; convert two-element hash table into a
                        ;; case-insensitive STR object and try to
                        ;; accumulate into STARTS-WITH if the two
                        ;; characters are CHAR-EQUAL
                        (let ((str (make-instance 'str
                                                  :str (string
                                                        (first hash-keys))
                                                  :case-insensitive-p t)))
                          (maybe-accumulate str)
                          str))
                      (t
                        ;; the general case; stop accumulating into STARTS-WITH
                        (setq accumulate-start-p nil)
                        (make-instance 'char-class
                                       :hash hash
                                       :case-insensitive-p
                                         (case-insensitive-mode-p flags)
                                       :invertedp invertedp
                                       :word-char-class-p word-char-class-p)))))
            ;; (:FLAGS {<flag>}*)
            ;; where flag is a modifier symbol like :CASE-INSENSITIVE-P
            ((:flags)
              ;; set/unset the flags corresponding to the symbols
              ;; following :FLAGS
              (mapc #'set-flag (rest parse-tree))
              ;; we're only interested in the side effect of
              ;; setting/unsetting the flags and turn this syntactical
              ;; construct into a VOID object which'll be optimized
              ;; away when creating the matcher
              (make-instance 'void))
            (otherwise
              (signal-ppcre-syntax-error
               "Unknown token ~A in parse-tree"
               (first parse-tree)))))
        ((or (characterp parse-tree) (stringp parse-tree))
          ;; turn characters or strings into STR objects and try to
          ;; accumulate into STARTS-WITH
          (let ((str (make-instance 'str
                                    :str (string parse-tree)
                                    :case-insensitive-p
                                      (case-insensitive-mode-p flags))))
            (maybe-accumulate str)
            str))
        (t
          ;; and now for the tokens which are symbols
          (case parse-tree
            ((:void)
              (make-instance 'void))
            ((:word-boundary)
              (make-instance 'word-boundary :negatedp nil))             
            ((:non-word-boundary)
              (make-instance 'word-boundary :negatedp t))             
            ;; the special character classes
            ((:digit-class
              :non-digit-class
              :word-char-class
              :non-word-char-class
              :whitespace-char-class
              :non-whitespace-char-class)
              ;; stop accumulating into STARTS-WITH
              (setq accumulate-start-p nil)
              (make-instance 'char-class
                             ;; use the constants defined in util.lisp
                             :hash (case parse-tree
                                     ((:digit-class
                                       :non-digit-class)
                                       +digit-hash+)
                                     ((:word-char-class
                                       :non-word-char-class)
                                       nil)
                                     ((:whitespace-char-class
                                       :non-whitespace-char-class)
                                       +whitespace-char-hash+))
                             ;; this value doesn't really matter but
                             ;; NIL should result in slightly faster
                             ;; matchers
                             :case-insensitive-p nil
                             :invertedp (member parse-tree
                                                '(:non-digit-class
                                                  :non-word-char-class
                                                  :non-whitespace-char-class)
                                                :test #'eq)
                             :word-char-class-p (member parse-tree
                                                        '(:word-char-class
                                                          :non-word-char-class)
                                                        :test #'eq)))
            ((:start-anchor             ; Perl's "^"
              :end-anchor               ; Perl's "$"
              :modeless-end-anchor-no-newline
                                        ; Perl's "\z"
              :modeless-start-anchor    ; Perl's "\A"
              :modeless-end-anchor)     ; Perl's "\Z"
              (make-instance 'anchor
                             :startp (member parse-tree
                                             '(:start-anchor
                                               :modeless-start-anchor)
                                             :test #'eq)
                             ;; set this value according to the
                             ;; current settings of FLAGS (unless it's
                             ;; a modeless anchor)
                             :multi-line-p
                               (and (multi-line-mode-p flags)
                                    (not (member parse-tree
                                                 '(:modeless-start-anchor
                                                   :modeless-end-anchor
                                                   :modeless-end-anchor-no-newline)
                                                 :test #'eq)))
                             :no-newline-p
                               (eq parse-tree
                                   :modeless-end-anchor-no-newline)))
            ((:everything)
              ;; stop accumulating into STARTS-WITHS
              (setq accumulate-start-p nil)
              (make-instance 'everything
                             :single-line-p (single-line-mode-p flags)))
            ;; special tokens corresponding to Perl's "ism" modifiers
            ((:case-insensitive-p
              :case-sensitive-p
              :multi-line-mode-p
              :not-multi-line-mode-p
              :single-line-mode-p
              :not-single-line-mode-p)
              ;; we're only interested in the side effect of
              ;; setting/unsetting the flags and turn these tokens
              ;; into VOID objects which'll be optimized away when
              ;; creating the matcher
              (set-flag parse-tree)
              (make-instance 'void))
            (otherwise
             (let ((translation (and (symbolp parse-tree)
                                     (parse-tree-synonym parse-tree))))
               (if translation
                 (convert-aux (copy-tree translation))
                 (signal-ppcre-syntax-error "Unknown token ~A in parse-tree"
                                            parse-tree))))))))

(defun convert (parse-tree)
  (declare (optimize speed
                     (safety 0)
                     (space 0)
                     (debug 0)
                     (compilation-speed 0)
                     #+:lispworks (hcl:fixnum-safety 0)))
  "Converts the parse tree PARSE-TREE into an equivalent REGEX object
and returns three values: the REGEX object, the number of registers
seen and an object the regex starts with which is either a STR object
or an EVERYTHING object (if the regex starts with something like
\".*\") or NIL."
  ;; this function basically just initializes the special variables
  ;; and then calls CONVERT-AUX to do all the work
  (let* ((flags (list nil nil nil))
         (reg-num 0)
         (accumulate-start-p t)
         starts-with
         (max-back-ref 0)
         (converted-parse-tree (convert-aux parse-tree)))
    (declare (special flags reg-num accumulate-start-p starts-with max-back-ref))
    ;; make sure we don't reference registers which aren't there
    (when (> (the fixnum max-back-ref)
             (the fixnum reg-num))
      (signal-ppcre-syntax-error
       "Backreference to register ~A which has not been defined"
       max-back-ref))
    (when (typep starts-with 'str)
      (setf (slot-value starts-with 'str)
              (coerce (slot-value starts-with 'str) 'simple-string)))
    (values converted-parse-tree reg-num starts-with)))

#+END_SRC

** [[/Users/Can/Develop/Lisp/document/pcl/code/libraries/cl-ppcre-1.2.3/closures.lisp][closures]]
#+BEGIN_SRC lisp 
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-PPCRE; Base: 10 -*-
;;; $Header: /usr/local/cvsrep/cl-ppcre/closures.lisp,v 1.25 2004/10/14 12:40:39 edi Exp $

;;; Here we create the closures which together build the final
;;; scanner.

;;; Copyright (c) 2002-2004, Dr. Edmund Weitz. All rights reserved.

;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:

;;;   * Redistributions of source code must retain the above copyright
;;;     notice, this list of conditions and the following disclaimer.

;;;   * Redistributions in binary form must reproduce the above
;;;     copyright notice, this list of conditions and the following
;;;     disclaimer in the documentation and/or other materials
;;;     provided with the distribution.

;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

(in-package #:cl-ppcre)

(declaim (inline *string*= *string*-equal))

(defun *string*= (string2 start1 end1 start2 end2)
  "Like STRING=, i.e. compares the special string *STRING* from START1
to END1 with STRING2 from START2 to END2. Note that there's no
boundary check - this has to be implemented by the caller."
  (declare (optimize speed
                     (safety 0)
                     (space 0)
                     (debug 0)
                     (compilation-speed 0)
                     #+:lispworks (hcl:fixnum-safety 0)))
  (declare (type fixnum start1 end1 start2 end2))
  (loop for string1-idx of-type fixnum from start1 below end1
        for string2-idx of-type fixnum from start2 below end2
        always (char= (schar *string* string1-idx)
                      (schar string2 string2-idx))))

(defun *string*-equal (string2 start1 end1 start2 end2)
  "Like STRING-EQUAL, i.e. compares the special string *STRING* from
START1 to END1 with STRING2 from START2 to END2. Note that there's no
boundary check - this has to be implemented by the caller."
  (declare (optimize speed
                     (safety 0)
                     (space 0)
                     (debug 0)
                     (compilation-speed 0)
                     #+:lispworks (hcl:fixnum-safety 0)))
  (declare (type fixnum start1 end1 start2 end2))
  (loop for string1-idx of-type fixnum from start1 below end1
        for string2-idx of-type fixnum from start2 below end2
        always (char-equal (schar *string* string1-idx)
                           (schar string2 string2-idx))))

(defgeneric create-matcher-aux (regex next-fn)
  (declare (optimize speed
                     (safety 0)
                     (space 0)
                     (debug 0)
                     (compilation-speed 0)
                     #+:lispworks (hcl:fixnum-safety 0)))
  (:documentation "Creates a closure which takes one parameter,
START-POS, and tests whether REGEX can match *STRING* at START-POS
such that the call to NEXT-FN after the match would succeed."))
                
(defmethod create-matcher-aux ((seq seq) next-fn)
  ;; the closure for a SEQ is a chain of closures for the elements of
  ;; this sequence which call each other in turn; the last closure
  ;; calls NEXT-FN
  (loop for element in (reverse (elements seq))
        for curr-matcher = next-fn then next-matcher
        for next-matcher = (create-matcher-aux element curr-matcher)
        finally (return next-matcher)))

(defmethod create-matcher-aux ((alternation alternation) next-fn)
  ;; first create closures for all alternations of ALTERNATION
  (let ((all-matchers (mapcar #'(lambda (choice)
                                  (create-matcher-aux choice next-fn))
                              (choices alternation))))
    ;; now create a closure which checks if one of the closures
    ;; created above can succeed
    (lambda (start-pos)
      (declare (type fixnum start-pos))
      (loop for matcher in all-matchers
            thereis (funcall (the function matcher) start-pos)))))

(defmethod create-matcher-aux ((register register) next-fn)
  ;; the position of this REGISTER within the whole regex; we start to
  ;; count at 0
  (let ((num (num register)))
    (declare (type fixnum num))
    ;; STORE-END-OF-REG is a thin wrapper around NEXT-FN which will
    ;; update the corresponding values of *REGS-START* and *REGS-END*
    ;; after the inner matcher has succeeded
    (flet ((store-end-of-reg (start-pos)
               (declare (type fixnum start-pos)
                        (type function next-fn))
               (setf (svref *reg-starts* num) (svref *regs-maybe-start* num)
                     (svref *reg-ends* num) start-pos)
           (funcall next-fn start-pos)))
      ;; the inner matcher is a closure corresponding to the regex
      ;; wrapped by this REGISTER
      (let ((inner-matcher (create-matcher-aux (regex register)
                                               #'store-end-of-reg)))
        (declare (type function inner-matcher))
        ;; here comes the actual closure for REGISTER
        (lambda (start-pos)
          (declare (type fixnum start-pos))
          ;; remember the old values of *REGS-START* and friends in
          ;; case we cannot match
          (let ((old-*reg-starts* (svref *reg-starts* num))
                (old-*regs-maybe-start* (svref *regs-maybe-start* num))
                (old-*reg-ends* (svref *reg-ends* num)))
            ;; we cannot use *REGS-START* here because Perl allows
            ;; regular expressions like /(a|\1x)*/
            (setf (svref *regs-maybe-start* num) start-pos)
            (let ((next-pos (funcall inner-matcher start-pos)))
              (unless next-pos
                ;; restore old values on failure
                (setf (svref *reg-starts* num) old-*reg-starts*
                      (svref *regs-maybe-start* num) old-*regs-maybe-start*
                      (svref *reg-ends* num) old-*reg-ends*))
              next-pos)))))))

(defmethod create-matcher-aux ((lookahead lookahead) next-fn)
  ;; create a closure which just checks for the inner regex and
  ;; doesn't care about NEXT-FN
  (let ((test-matcher (create-matcher-aux (regex lookahead) #'identity)))
    (declare (type function next-fn test-matcher))
    (if (positivep lookahead)
      ;; positive look-ahead: check success of inner regex, then call
      ;; NEXT-FN
      (lambda (start-pos)
        (and (funcall test-matcher start-pos)
             (funcall next-fn start-pos)))
      ;; negative look-ahead: check failure of inner regex, then call
      ;; NEXT-FN
      (lambda (start-pos)
        (and (not (funcall test-matcher start-pos))
             (funcall next-fn start-pos))))))

(defmethod create-matcher-aux ((lookbehind lookbehind) next-fn)
  (let ((len (len lookbehind))
        ;; create a closure which just checks for the inner regex and
        ;; doesn't care about NEXT-FN
        (test-matcher (create-matcher-aux (regex lookbehind) #'identity)))
    (declare (type function next-fn test-matcher)
             (type fixnum len))
    (if (positivep lookbehind)
      ;; positive look-behind: check success of inner regex (if we're
      ;; far enough from the start of *STRING*), then call NEXT-FN
      (lambda (start-pos)
        (declare (type fixnum start-pos))
        (and (>= (- start-pos *start-pos*) len)
             (funcall test-matcher (- start-pos len))
             (funcall next-fn start-pos)))
      ;; negative look-behind: check failure of inner regex (if we're
      ;; far enough from the start of *STRING*), then call NEXT-FN
      (lambda (start-pos)
        (declare (type fixnum start-pos))
        (and (or (< start-pos len)
                 (not (funcall test-matcher (- start-pos len))))
             (funcall next-fn start-pos))))))

(defmacro insert-char-class-tester ((char-class chr-expr) &body body)
  "Utility macro to replace each occurence of '(CHAR-CLASS-TEST)
within BODY with the correct test (corresponding to CHAR-CLASS)
against CHR-EXPR."
  (with-unique-names (%char-class)
    ;; the actual substitution is done here: replace
    ;; '(CHAR-CLASS-TEST) with NEW
    (flet ((substitute-char-class-tester (new)
               (subst new '(char-class-test) body
                      :test #'equalp)))
      `(let* ((,%char-class ,char-class)
              (hash (hash ,%char-class))
              (count (if hash
                       (hash-table-count hash)
                       most-positive-fixnum))
              ;; collect a list of "all" characters in the hash if
              ;; there aren't more than two
              (key-list (if (<= count 2)
                          (loop for chr being the hash-keys of hash
                                collect chr)
                          nil))
              downcasedp)
        (declare (type fixnum count))
        ;; check if we can partition the hash into three ranges (or
        ;; less)
        (multiple-value-bind (min1 max1 min2 max2 min3 max3)
            (create-ranges-from-hash hash)
          ;; if that didn't work and CHAR-CLASS is case-insensitive we
          ;; try it again with every character downcased
          (when (and (not min1)
                     (case-insensitive-p ,%char-class))
            (multiple-value-setq (min1 max1 min2 max2 min3 max3)
              (create-ranges-from-hash hash :downcasep t))
            (setq downcasedp t))
          (cond ((= count 1)
                  ;; hash contains exactly one character so we just
                  ;; check for this single character; (note that this
                  ;; actually can't happen because this case is
                  ;; optimized away in CONVERT already...)
                  (let ((chr1 (first key-list)))
                    ,@(substitute-char-class-tester
                       `(char= ,chr-expr chr1))))
                ((= count 2)
                  ;; hash contains exactly two characters
                  (let ((chr1 (first key-list))
                        (chr2 (second key-list)))
                    ,@(substitute-char-class-tester
                       `(let ((chr ,chr-expr))
                         (or (char= chr chr1)
                             (char= chr chr2))))))
                ((word-char-class-p ,%char-class)
                  ;; special-case: hash is \w, \W, [\w], [\W] or
                  ;; something equivalent
                  ,@(substitute-char-class-tester
                     `(word-char-p ,chr-expr)))
                ((= count *regex-char-code-limit*)
                  ;; according to the ANSI standard we might have all
                  ;; possible characters in the hash even if it
                  ;; doesn't contain CHAR-CODE-LIMIT characters but
                  ;; this doesn't seem to be the case for current
                  ;; implementations (also note that this optimization
                  ;; implies that you must not have characters with
                  ;; character codes beyond *REGEX-CHAR-CODE-LIMIT* in
                  ;; your regexes if you've changed this limit); we
                  ;; expect the compiler to optimize this T "test"
                  ;; away
                  ,@(substitute-char-class-tester t))
                ((and downcasedp min1 min2 min3)
                  ;; three different ranges, downcased
                  ,@(substitute-char-class-tester
                     `(let ((chr ,chr-expr))
                       (or (char-not-greaterp min1 chr max1)
                           (char-not-greaterp min2 chr max2)
                           (char-not-greaterp min3 chr max3)))))
                ((and downcasedp min1 min2)
                  ;; two ranges, downcased
                  ,@(substitute-char-class-tester
                     `(let ((chr ,chr-expr))
                       (or (char-not-greaterp min1 chr max1)
                           (char-not-greaterp min2 chr max2)))))
                ((and downcasedp min1)
                  ;; one downcased range
                  ,@(substitute-char-class-tester
                     `(char-not-greaterp min1 ,chr-expr max1)))
                ((and min1 min2 min3)
                  ;; three ranges
                  ,@(substitute-char-class-tester
                     `(let ((chr ,chr-expr))
                       (or (char<= min1 chr max1)
                           (char<= min2 chr max2)
                           (char<= min3 chr max3)))))
                ((and min1 min2)
                  ;; two ranges
                  ,@(substitute-char-class-tester
                     `(let ((chr ,chr-expr))
                       (or (char<= min1 chr max1)
                           (char<= min2 chr max2)))))
                (min1
                  ;; one range
                  ,@(substitute-char-class-tester
                     `(char<= min1 ,chr-expr max1)))
                (t
                  ;; the general case; note that most of the above
                  ;; "optimizations" are based on experiences and
                  ;; benchmarks with CMUCL - if you're really
                  ;; concerned with speed you might find out that the
                  ;; general case is almost always the best one for
                  ;; other implementations (because the speed of their
                  ;; hash-table access in relation to other operations
                  ;; might be better than in CMUCL)
                  ,@(substitute-char-class-tester
                     `(gethash ,chr-expr hash)))))))))

(defmethod create-matcher-aux ((char-class char-class) next-fn)
  (declare (type function next-fn))
  ;; insert a test against the current character within *STRING*
  (insert-char-class-tester (char-class (schar *string* start-pos))
    (if (invertedp char-class)
      (lambda (start-pos)
        (declare (type fixnum start-pos))
        (and (< start-pos *end-pos*)
             (not (char-class-test))
             (funcall next-fn (1+ start-pos))))
      (lambda (start-pos)
        (declare (type fixnum start-pos))
        (and (< start-pos *end-pos*)
             (char-class-test)
             (funcall next-fn (1+ start-pos)))))))

(defmethod create-matcher-aux ((str str) next-fn)
  (declare (type fixnum *end-string-pos*)
           (type function next-fn)
           ;; this special value is set by CREATE-SCANNER when the
           ;; closures are built
           (special end-string))
  (let* ((len (len str))
         (case-insensitive-p (case-insensitive-p str))
         (start-of-end-string-p (start-of-end-string-p str))
         (skip (skip str))
         (str (str str))
         (chr (schar str 0))
         (end-string (and end-string (str end-string)))
         (end-string-len (if end-string
                           (length end-string)
                           nil)))
    (declare (type fixnum len))
    (cond ((and start-of-end-string-p case-insensitive-p)
            ;; closure for the first STR which belongs to the constant
            ;; string at the end of the regular expression;
            ;; case-insensitive version
            (lambda (start-pos)
              (declare (type fixnum start-pos end-string-len))
              (let ((test-end-pos (+ start-pos end-string-len)))
                (declare (type fixnum test-end-pos))
                ;; either we're at *END-STRING-POS* (which means that
                ;; it has already been confirmed that end-string
                ;; starts here) or we really have to test
                (and (or (= start-pos *end-string-pos*)
                         (and (<= test-end-pos *end-pos*)
                              (*string*-equal end-string start-pos test-end-pos
                                              0 end-string-len)))
                     (funcall next-fn (+ start-pos len))))))
          (start-of-end-string-p
            ;; closure for the first STR which belongs to the constant
            ;; string at the end of the regular expression;
            ;; case-sensitive version
            (lambda (start-pos)
              (declare (type fixnum start-pos end-string-len))
              (let ((test-end-pos (+ start-pos end-string-len)))
                (declare (type fixnum test-end-pos))
                ;; either we're at *END-STRING-POS* (which means that
                ;; it has already been confirmed that end-string
                ;; starts here) or we really have to test
                (and (or (= start-pos *end-string-pos*)
                         (and (<= test-end-pos *end-pos*)
                              (*string*= end-string start-pos test-end-pos
                                         0 end-string-len)))
                     (funcall next-fn (+ start-pos len))))))
          (skip
            ;; a STR which can be skipped because some other function
            ;; has already confirmed that it matches
            (lambda (start-pos)
              (declare (type fixnum start-pos))
              (funcall next-fn (+ start-pos len))))
          ((and (= len 1) case-insensitive-p)
            ;; STR represent exactly one character; case-insensitive
            ;; version
            (lambda (start-pos)
              (declare (type fixnum start-pos))
              (and (< start-pos *end-pos*)
                   (char-equal (schar *string* start-pos) chr)
                   (funcall next-fn (1+ start-pos)))))
          ((= len 1)
            ;; STR represent exactly one character; case-sensitive
            ;; version
            (lambda (start-pos)
              (declare (type fixnum start-pos))
              (and (< start-pos *end-pos*)
                   (char= (schar *string* start-pos) chr)
                   (funcall next-fn (1+ start-pos)))))
          (case-insensitive-p
            ;; general case, case-insensitive version
            (lambda (start-pos)
              (declare (type fixnum start-pos))
              (let ((next-pos (+ start-pos len)))
                (declare (type fixnum next-pos))
                (and (<= next-pos *end-pos*)
                     (*string*-equal str start-pos next-pos 0 len)
                     (funcall next-fn next-pos)))))
          (t
            ;; general case, case-sensitive version
            (lambda (start-pos)
              (declare (type fixnum start-pos))
              (let ((next-pos (+ start-pos len)))
                (declare (type fixnum next-pos))
                (and (<= next-pos *end-pos*)
                     (*string*= str start-pos next-pos 0 len)
                     (funcall next-fn next-pos))))))))

(declaim (inline word-boundary-p))

(defun word-boundary-p (start-pos)
  "Check whether START-POS is a word-boundary within *STRING*."
  (declare (optimize speed
                     (safety 0)
                     (space 0)
                     (debug 0)
                     (compilation-speed 0)
                     #+:lispworks (hcl:fixnum-safety 0)))
  (declare (type fixnum start-pos))
  (let ((1-start-pos (1- start-pos)))
    ;; either the character before START-POS is a word-constituent and
    ;; the character at START-POS isn't...
    (or (and (or (= start-pos *end-pos*)
                 (and (< start-pos *end-pos*)
                      (not (word-char-p (schar *string* start-pos)))))
             (and (< 1-start-pos *end-pos*)
                  (<= *start-pos* 1-start-pos)
                  (word-char-p (schar *string* 1-start-pos))))
        ;; ...or vice versa
        (and (or (= start-pos *start-pos*)
                 (and (< 1-start-pos *end-pos*)
                      (<= *start-pos* 1-start-pos)
                      (not (word-char-p (schar *string* 1-start-pos)))))
             (and (< start-pos *end-pos*)
                  (word-char-p (schar *string* start-pos)))))))

(defmethod create-matcher-aux ((word-boundary word-boundary) next-fn)
  (declare (type function next-fn))
  (if (negatedp word-boundary)
    (lambda (start-pos)
      (and (not (word-boundary-p start-pos))
           (funcall next-fn start-pos)))
    (lambda (start-pos)
      (and (word-boundary-p start-pos)
           (funcall next-fn start-pos)))))

(defmethod create-matcher-aux ((everything everything) next-fn)
  (declare (type function next-fn))
  (if (single-line-p everything)
    ;; closure for single-line-mode: we really match everything, so we
    ;; just advance the index into *STRING* by one and carry on
    (lambda (start-pos)
      (declare (type fixnum start-pos))
      (and (< start-pos *end-pos*)
           (funcall next-fn (1+ start-pos))))
    ;; not single-line-mode, so we have to make sure we don't match
    ;; #\Newline
    (lambda (start-pos)
      (declare (type fixnum start-pos))
      (and (< start-pos *end-pos*)
           (char/= (schar *string* start-pos) #\Newline)
           (funcall next-fn (1+ start-pos))))))

(defmethod create-matcher-aux ((anchor anchor) next-fn)
  (declare (type function next-fn))
  (let ((startp (startp anchor))
        (multi-line-p (multi-line-p anchor)))
    (cond ((no-newline-p anchor)
            ;; this must be and end-anchor and it must be modeless, so
            ;; we just have to check whether START-POS equals
            ;; *END-POS*
            (lambda (start-pos)
              (declare (type fixnum start-pos))
              (and (= start-pos *end-pos*)
                   (funcall next-fn start-pos))))
          ((and startp multi-line-p)
            ;; a start-anchor in multi-line-mode: check if we're at
            ;; *START-POS* or if the last character was #\Newline
            (lambda (start-pos)
              (declare (type fixnum start-pos))
              (let ((*start-pos* (or *real-start-pos* *start-pos*)))
                (and (or (= start-pos *start-pos*)
                         (and (<= start-pos *end-pos*)
                              (> start-pos *start-pos*)
                              (char= #\Newline
                                     (schar *string* (1- start-pos)))))
                     (funcall next-fn start-pos)))))
          (startp
            ;; a start-anchor which is not in multi-line-mode, so just
            ;; check whether we're at *START-POS*
            (lambda (start-pos)
              (declare (type fixnum start-pos))
              (and (= start-pos (or *real-start-pos* *start-pos*))
                   (funcall next-fn start-pos))))
          (multi-line-p
            ;; an end-anchor in multi-line-mode: check if we're at
            ;; *END-POS* or if the character we're looking at is
            ;; #\Newline
            (lambda (start-pos)
              (declare (type fixnum start-pos))
              (and (or (= start-pos *end-pos*)
                       (and (< start-pos *end-pos*)
                            (char= #\Newline
                                   (schar *string* start-pos))))
                   (funcall next-fn start-pos))))
          (t
            ;; an end-anchor which is not in multi-line-mode, so just
            ;; check if we're at *END-POS* or if we're looking at
            ;; #\Newline and there's nothing behind it
            (lambda (start-pos)
              (declare (type fixnum start-pos))
              (and (or (= start-pos *end-pos*)
                       (and (= start-pos (1- *end-pos*))
                            (char= #\Newline
                                   (schar *string* start-pos))))
                   (funcall next-fn start-pos)))))))

(defmethod create-matcher-aux ((back-reference back-reference) next-fn)
  (declare (type function next-fn))
  ;; the position of the corresponding REGISTER within the whole
  ;; regex; we start to count at 0
  (let ((num (num back-reference)))
    (if (case-insensitive-p back-reference)
      ;; the case-insensitive version
      (lambda (start-pos)
        (declare (type fixnum start-pos))
        (let ((reg-start (svref *reg-starts* num))
              (reg-end (svref *reg-ends* num)))
          ;; only bother to check if the corresponding REGISTER as
          ;; matched successfully already
          (and reg-start
               (let ((next-pos (+ start-pos (- (the fixnum reg-end)
                                               (the fixnum reg-start)))))
                 (declare (type fixnum next-pos))
                 (and
                   (<= next-pos *end-pos*)
                   (*string*-equal *string* start-pos next-pos
                                   reg-start reg-end)
                   (funcall next-fn next-pos))))))
      ;; the case-sensitive version
      (lambda (start-pos)
        (declare (type fixnum start-pos))
        (let ((reg-start (svref *reg-starts* num))
              (reg-end (svref *reg-ends* num)))
          ;; only bother to check if the corresponding REGISTER as
          ;; matched successfully already
          (and reg-start
               (let ((next-pos (+ start-pos (- (the fixnum reg-end)
                                               (the fixnum reg-start)))))
                 (declare (type fixnum next-pos))
                 (and
                   (<= next-pos *end-pos*)
                   (*string*= *string* start-pos next-pos
                              reg-start reg-end)
                   (funcall next-fn next-pos)))))))))

(defmethod create-matcher-aux ((branch branch) next-fn)
  (let* ((test (test branch))
         (then-matcher (create-matcher-aux (then-regex branch) next-fn))
         (else-matcher (create-matcher-aux (else-regex branch) next-fn)))
    (declare (type function then-matcher else-matcher))
    (cond ((numberp test)
            (lambda (start-pos)
              (declare (type fixnum test))
              (if (and (< test (length *reg-starts*))
                       (svref *reg-starts* test))
                (funcall then-matcher start-pos)
                (funcall else-matcher start-pos))))
          (t
            (let ((test-matcher (create-matcher-aux test #'identity)))
              (declare (type function test-matcher))
              (lambda (start-pos)
                (if (funcall test-matcher start-pos)
                  (funcall then-matcher start-pos)
                  (funcall else-matcher start-pos))))))))

(defmethod create-matcher-aux ((standalone standalone) next-fn)
  (let ((inner-matcher (create-matcher-aux (regex standalone) #'identity)))
    (declare (type function next-fn inner-matcher))
    (lambda (start-pos)
      (let ((next-pos (funcall inner-matcher start-pos)))
        (and next-pos
             (funcall next-fn next-pos))))))

(defmethod create-matcher-aux ((filter filter) next-fn)
  (let ((fn (fn filter)))
    (lambda (start-pos)
      (let ((next-pos (funcall fn start-pos)))
        (and next-pos
             (funcall next-fn next-pos))))))

(defmethod create-matcher-aux ((void void) next-fn)
  ;; optimize away VOIDs: don't create a closure, just return NEXT-FN
  next-fn)

#+END_SRC

** [[/Users/Can/Develop/Lisp/document/pcl/code/libraries/cl-ppcre-1.2.3/api.lisp][api]]
#+BEGIN_SRC lisp 
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-PPCRE; Base: 10 -*-
;;; $Header: /usr/local/cvsrep/cl-ppcre/api.lisp,v 1.53 2005/01/25 01:04:06 edi Exp $

;;; The external API for creating and using scanners.

;;; Copyright (c) 2002-2004, Dr. Edmund Weitz. All rights reserved.

;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:

;;;   * Redistributions of source code must retain the above copyright
;;;     notice, this list of conditions and the following disclaimer.

;;;   * Redistributions in binary form must reproduce the above
;;;     copyright notice, this list of conditions and the following
;;;     disclaimer in the documentation and/or other materials
;;;     provided with the distribution.

;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

(in-package #:cl-ppcre)

(defgeneric create-scanner (regex &key case-insensitive-mode
                                       multi-line-mode
                                       single-line-mode
                                       extended-mode
                                       destructive)
  (:documentation "Accepts a regular expression - either as a
parse-tree or as a string - and returns a scan closure which will scan
strings for this regular expression. The \"mode\" keyboard arguments
are equivalent to the imsx modifiers in Perl. If DESTRUCTIVE is not
NIL the function is allowed to destructively modify its first argument
\(but only if it's a parse tree)."))

#-:use-acl-regexp2-engine
(defmethod create-scanner ((regex-string string) &key case-insensitive-mode
                                                      multi-line-mode
                                                      single-line-mode
                                                      extended-mode
                                                      destructive)
  (declare (optimize speed
                     (safety 0)
                     (space 0)
                     (debug 0)
                     (compilation-speed 0)
                     #+:lispworks (hcl:fixnum-safety 0)))
  (declare (ignore destructive))
  ;; parse the string into a parse-tree and then call CREATE-SCANNER
  ;; again
  (let* ((*extended-mode-p* extended-mode)
         (quoted-regex-string (if *allow-quoting*
                                (quote-sections (clean-comments regex-string extended-mode))
                                regex-string))
         (*syntax-error-string* (copy-seq quoted-regex-string)))
    ;; wrap the result with :GROUP to avoid infinite loops for
    ;; constant strings
    (create-scanner (cons :group (list (parse-string quoted-regex-string)))
                    :case-insensitive-mode case-insensitive-mode
                    :multi-line-mode multi-line-mode
                    :single-line-mode single-line-mode
                    :destructive t)))

#-:use-acl-regexp2-engine
(defmethod create-scanner ((scanner function) &key case-insensitive-mode
                                                   multi-line-mode
                                                   single-line-mode
                                                   extended-mode
                                                   destructive)
  (declare (optimize speed
                     (safety 0)
                     (space 0)
                     (debug 0)
                     (compilation-speed 0)
                     #+:lispworks (hcl:fixnum-safety 0)))
  (declare (ignore destructive))
  (when (or case-insensitive-mode multi-line-mode single-line-mode extended-mode)
    (signal-ppcre-invocation-error
     "You can't use the keyword arguments to modify an existing scanner."))
  scanner)

#-:use-acl-regexp2-engine
(defmethod create-scanner ((parse-tree t) &key case-insensitive-mode
                                               multi-line-mode
                                               single-line-mode
                                               extended-mode
                                               destructive)
  (declare (optimize speed
                     (safety 0)
                     (space 0)
                     (debug 0)
                     (compilation-speed 0)
                     #+:lispworks (hcl:fixnum-safety 0)))
  (when extended-mode
    (signal-ppcre-invocation-error
     "Extended mode doesn't make sense in parse trees."))
  ;; convert parse-tree into internal representation REGEX and at the
  ;; same time compute the number of registers and the constant string
  ;; (or anchor) the regex starts with (if any)
  (unless destructive
    (setq parse-tree (copy-tree parse-tree)))
  (let (flags)
    (if single-line-mode
      (push :single-line-mode-p flags))
    (if multi-line-mode
      (push :multi-line-mode-p flags))
    (if case-insensitive-mode
      (push :case-insensitive-p flags))
    (when flags
      (setq parse-tree (list :group (cons :flags flags) parse-tree))))
  (let ((*syntax-error-string* nil))
    (multiple-value-bind (regex reg-num starts-with)
        (convert parse-tree)
      ;; simplify REGEX by flattening nested SEQ and ALTERNATION
      ;; constructs and gathering STR objects
      (let ((regex (gather-strings (flatten regex))))
        ;; set the MIN-REST slots of the REPETITION objects
        (compute-min-rest regex 0)
        ;; set the OFFSET slots of the STR objects
        (compute-offsets regex 0)
        (let* (end-string-offset
               end-anchored-p
               ;; compute the constant string the regex ends with (if
               ;; any) and at the same time set the special variables
               ;; END-STRING-OFFSET and END-ANCHORED-P
               (end-string (end-string regex))
               ;; if we found a non-zero-length end-string we create an
               ;; efficient search function for it
               (end-string-test (and end-string
                                     (plusp (len end-string))
                                     (if (= 1 (len end-string))
                                       (create-char-searcher
                                        (schar (str end-string) 0)
                                        (case-insensitive-p end-string))
                                       (create-bmh-matcher
                                        (str end-string)
                                        (case-insensitive-p end-string)))))
               ;; initialize the counters for CREATE-MATCHER-AUX
               (*rep-num* 0)
               (*zero-length-num* 0)
               ;; create the actual matcher function (which does all the
               ;; work of matching the regular expression) corresponding
               ;; to REGEX and at the same time set the special
               ;; variables *REP-NUM* and *ZERO-LENGTH-NUM*
               (match-fn (create-matcher-aux regex #'identity))
               ;; if the regex starts with a string we create an
               ;; efficient search function for it
               (start-string-test (and (typep starts-with 'str)
                                       (plusp (len starts-with))
                                       (if (= 1 (len starts-with))
                                         (create-char-searcher
                                          (schar (str starts-with) 0)
                                          (case-insensitive-p starts-with))
                                         (create-bmh-matcher
                                          (str starts-with)
                                          (case-insensitive-p starts-with))))))
          (declare (special end-string-offset end-anchored-p end-string))
          ;; now create the scanner and return it
          (create-scanner-aux match-fn
                              (regex-min-length regex)
                              (or (start-anchored-p regex)
                                  ;; a dot in single-line-mode also
                                  ;; implicitely anchors the regex at
                                  ;; the start, i.e. if we can't match
                                  ;; from the first position we won't
                                  ;; match at all
                                  (and (typep starts-with 'everything)
                                       (single-line-p starts-with)))
                              starts-with
                              start-string-test
                              ;; only mark regex as end-anchored if we
                              ;; found a non-zero-length string before
                              ;; the anchor
                              (and end-string-test end-anchored-p)
                              end-string-test
                              (if end-string-test
                                (len end-string)
                                nil)
                              end-string-offset
                              *rep-num*
                              *zero-length-num*
                              reg-num))))))

#+:use-acl-regexp2-engine
(declaim (inline create-scanner))

#+:use-acl-regexp2-engine
(defmethod create-scanner ((scanner regexp::regular-expression) &key case-insensitive-mode
                                                                     multi-line-mode
                                                                     single-line-mode
                                                                     extended-mode
                                                                     destructive)
  (declare (ignore destructive))
  (when (or case-insensitive-mode multi-line-mode single-line-mode extended-mode)
    (signal-ppcre-invocation-error
     "You can't use the keyword arguments to modify an existing scanner."))
  scanner)

#+:use-acl-regexp2-engine
(defmethod create-scanner ((parse-tree t) &key case-insensitive-mode
                                               multi-line-mode
                                               single-line-mode
                                               extended-mode
                                               destructive)
  (declare (ignore destructive))
  (excl:compile-re parse-tree
                   :case-fold case-insensitive-mode
                   :ignore-whitespace extended-mode
                   :multiple-lines multi-line-mode
                   :single-line single-line-mode
                   :return :index))

(defgeneric scan (regex target-string &key start end)
  (:documentation "Searches TARGET-STRING from START to END and tries
to match REGEX. On success returns four values - the start of the
match, the end of the match, and two arrays denoting the beginnings
and ends of register matches. On failure returns NIL. REGEX can be a
string which will be parsed according to Perl syntax, a parse tree, or
a pre-compiled scanner created by CREATE-SCANNER. TARGET-STRING will
be coerced to a simple string if it isn't one already."))

#-:use-acl-regexp2-engine
(defmethod scan ((regex-string string) target-string
                                       &key (start 0)
                                            (end (length target-string)))
  (declare (optimize speed
                     (safety 0)
                     (space 0)
                     (debug 0)
                     (compilation-speed 0)
                     #+:lispworks (hcl:fixnum-safety 0)))
  ;; note that the scanners are optimized for simple strings so we
  ;; have to coerce TARGET-STRING into one if it isn't already
  (funcall (create-scanner regex-string)
           (maybe-coerce-to-simple-string target-string)
           start end))

#-:use-acl-regexp2-engine
(defmethod scan ((scanner function) target-string
                                    &key (start 0)
                                         (end (length target-string)))
  (declare (optimize speed
                     (safety 0)
                     (space 0)
                     (debug 0)
                     (compilation-speed 0)
                     #+:lispworks (hcl:fixnum-safety 0)))
  (funcall scanner
           (maybe-coerce-to-simple-string target-string)
           start end))

#-:use-acl-regexp2-engine
(defmethod scan ((parse-tree t) target-string
                                &key (start 0)
                                     (end (length target-string)))
  (declare (optimize speed
                     (safety 0)
                     (space 0)
                     (debug 0)
                     (compilation-speed 0)
                     #+:lispworks (hcl:fixnum-safety 0)))
  (funcall (create-scanner parse-tree)
           (maybe-coerce-to-simple-string target-string)
           start end))

#+:use-acl-regexp2-engine
(declaim (inline scan))

#+:use-acl-regexp2-engine
(defmethod scan ((parse-tree t) target-string
                                &key (start 0)
                                     (end (length target-string)))
  (when (< end start)
    (return-from scan nil))
  (let ((results (multiple-value-list (excl:match-re parse-tree target-string
                                                     :start start
                                                     :end end
                                                     :return :index))))
    (declare (dynamic-extent results))
    (cond ((null (first results)) nil)
          (t (let* ((no-of-regs (- (length results) 2))
                    (reg-starts (make-array no-of-regs
                                            :element-type '(or null fixnum)))
                    (reg-ends (make-array no-of-regs
                                          :element-type '(or null fixnum)))
                    (match (second results)))
               (loop for (start . end) in (cddr results)
                     for i from 0
                     do (setf (aref reg-starts i) start
                              (aref reg-ends i) end))
               (values (car match) (cdr match) reg-starts reg-ends))))))

(define-compiler-macro scan (&whole form &environment env regex target-string &rest rest)
  "Make sure that constant forms are compiled into scanners at compile time."
  (cond ((constantp regex env)
          `(scan (load-time-value
                   (create-scanner ,regex))
                   ,target-string ,@rest))
        (t form)))

(defun scan-to-strings (regex target-string &key (start 0)
                                                 (end (length target-string))
                                                 sharedp)
  (declare (optimize speed
                     (safety 0)
                     (space 0)
                     (debug 0)
                     (compilation-speed 0)
                     #+:lispworks (hcl:fixnum-safety 0)))
  "Like SCAN but returns substrings of TARGET-STRING instead of
positions, i.e. this function returns two values on success: the whole
match as a string plus an array of substrings (or NILs) corresponding
to the matched registers. If SHAREDP is true, the substrings may share
structure with TARGET-STRING."
  (multiple-value-bind (match-start match-end reg-starts reg-ends)
      (scan regex target-string :start start :end end)
    (unless match-start
      (return-from scan-to-strings nil))
    (let ((substr-fn (if sharedp #'nsubseq #'subseq)))
      (values (funcall substr-fn
                       target-string match-start match-end)
              (map 'vector
                   (lambda (reg-start reg-end)
                     (if reg-start
                       (funcall substr-fn
                                target-string reg-start reg-end)
                       nil))
                   reg-starts
                   reg-ends)))))

(define-compiler-macro scan-to-strings
    (&whole form &environment env regex target-string &rest rest)
  "Make sure that constant forms are compiled into scanners at compile time."
  (cond ((constantp regex env)
          `(scan-to-strings (load-time-value
                              (create-scanner ,regex))
                            ,target-string ,@rest))
        (t form)))

(defmacro register-groups-bind (var-list (regex target-string
                                                &key start end sharedp)
                                &body body)
  "Executes BODY with the variables in VAR-LIST bound to the
corresponding register groups after TARGET-STRING has been matched
against REGEX, i.e. each variable is either bound to a string or to
NIL. If there is no match, BODY is _not_ executed. For each element of
VAR-LIST which is NIL there's no binding to the corresponding register
group. The number of variables in VAR-LIST must not be greater than
the number of register groups. If SHAREDP is true, the substrings may
share structure with TARGET-STRING."
  (with-rebinding (target-string)
    (with-unique-names (match-start match-end reg-starts reg-ends
                                    start-index substr-fn)
      `(multiple-value-bind (,match-start ,match-end ,reg-starts ,reg-ends)
            (scan ,regex ,target-string :start (or ,start 0)
                                        :end (or ,end (length ,target-string)))
          (declare (ignore ,match-end))
          (when ,match-start            
            (let* ,(cons
                    `(,substr-fn (if ,sharedp
                                   #'nsubseq
                                   #'subseq))
                    (loop for (function var) in (normalize-var-list var-list)
                          for counter from 0
                          when var
                            collect `(,var (let ((,start-index
                                                   (aref ,reg-starts ,counter)))
                                             (if ,start-index
                                               (funcall ,function
                                                        (funcall ,substr-fn
                                                                 ,target-string
                                                                 ,start-index
                                                                 (aref ,reg-ends ,counter)))
                                               nil)))))
              ,@body))))))

(defmacro do-scans ((match-start match-end reg-starts reg-ends regex
                                 target-string
                                 &optional result-form
                                 &key start end)
                    &body body
                    &environment env)
  "Iterates over TARGET-STRING and tries to match REGEX as often as
possible evaluating BODY with MATCH-START, MATCH-END, REG-STARTS, and
REG-ENDS bound to the four return values of each match in turn. After
the last match, returns RESULT-FORM if provided or NIL otherwise. An
implicit block named NIL surrounds DO-SCANS; RETURN may be used to
terminate the loop immediately. If REGEX matches an empty string the
scan is continued one position behind this match. BODY may start with
declarations."
  (with-rebinding (target-string)
    (with-unique-names (%start %end %regex scanner loop-tag block-name)
      (declare (ignorable %regex scanner))
      ;; the NIL BLOCK to enable exits via (RETURN ...)
      `(block nil
        (let* ((,%start (or ,start 0))
               (*real-start-pos* ,%start)
               (,%end (or ,end (length ,target-string)))
               ,@(unless (constantp regex env)
                   ;; leave constant regular expressions as they are -
                   ;; SCAN's compiler macro will take care of them;
                   ;; otherwise create a scanner unless the regex is
                   ;; already a function (otherwise SCAN will do this
                   ;; on each iteration)
                   `((,%regex ,regex)
                     (,scanner (typecase ,%regex
                                 (function ,%regex)
                                 (t (create-scanner ,%regex)))))))
          ;; coerce TARGET-STRING to a simple string unless it is one
          ;; already (otherwise SCAN will do this on each iteration)
          (setq ,target-string
                  (maybe-coerce-to-simple-string ,target-string))
          ;; a named BLOCK so we can exit the TAGBODY
          (block ,block-name
            (tagbody
              ,loop-tag
              ;; invoke SCAN and bind the returned values to the
              ;; provided variables
              (multiple-value-bind
                    (,match-start ,match-end ,reg-starts ,reg-ends)
                  (scan ,(cond ((constantp regex env) regex)
                               (t scanner))
                        ,target-string :start ,%start :end ,%end)
                ;; declare the variables to be IGNORABLE to prevent the
                ;; compiler from issuing warnings
                (declare
                  (ignorable ,match-start ,match-end ,reg-starts ,reg-ends))
                (unless ,match-start
                  ;; stop iteration on first failure
                  (return-from ,block-name ,result-form))
                ;; execute BODY (wrapped in LOCALLY so it can start with
                ;; declarations)
                (locally
                  ,@body)
                ;; advance by one position if we had a zero-length match
                (setq ,%start (if (= ,match-start ,match-end)
                                (1+ ,match-end)
                                ,match-end)))
              (go ,loop-tag))))))))

(defmacro do-matches ((match-start match-end regex
                                   target-string
                                   &optional result-form
                                   &key start end)
                      &body body)
  "Iterates over TARGET-STRING and tries to match REGEX as often as
possible evaluating BODY with MATCH-START and MATCH-END bound to the
start/end positions of each match in turn. After the last match,
returns RESULT-FORM if provided or NIL otherwise. An implicit block
named NIL surrounds DO-MATCHES; RETURN may be used to terminate the
loop immediately. If REGEX matches an empty string the scan is
continued one position behind this match. BODY may start with
declarations."
  ;; this is a simplified form of DO-SCANS - we just provide two dummy
  ;; vars and ignore them
  (with-unique-names (reg-starts reg-ends)
    `(do-scans (,match-start ,match-end
                ,reg-starts ,reg-ends
                ,regex ,target-string
                ,result-form
                :start ,start :end ,end)
      ,@body)))

(defmacro do-matches-as-strings ((match-var regex
                                            target-string
                                            &optional result-form
                                            &key start end sharedp)
                                 &body body)
  "Iterates over TARGET-STRING and tries to match REGEX as often as
possible evaluating BODY with MATCH-VAR bound to the substring of
TARGET-STRING corresponding to each match in turn. After the last
match, returns RESULT-FORM if provided or NIL otherwise. An implicit
block named NIL surrounds DO-MATCHES-AS-STRINGS; RETURN may be used to
terminate the loop immediately. If REGEX matches an empty string the
scan is continued one position behind this match. If SHAREDP is true,
the substrings may share structure with TARGET-STRING. BODY may start
with declarations."
  (with-rebinding (target-string)
    (with-unique-names (match-start match-end substr-fn)
      `(let ((,substr-fn (if ,sharedp #'nsubseq #'subseq)))
        ;; simple use DO-MATCHES to extract the substrings
        (do-matches (,match-start ,match-end ,regex ,target-string
                     ,result-form :start ,start :end ,end)
          (let ((,match-var
                  (funcall ,substr-fn
                           ,target-string ,match-start ,match-end)))
            ,@body))))))

(defmacro do-register-groups (var-list (regex target-string
                                              &optional result-form
                                              &key start end sharedp)
                                       &body body)
  "Iterates over TARGET-STRING and tries to match REGEX as often as
possible evaluating BODY with the variables in VAR-LIST bound to the
corresponding register groups for each match in turn, i.e. each
variable is either bound to a string or to NIL. For each element of
VAR-LIST which is NIL there's no binding to the corresponding register
group. The number of variables in VAR-LIST must not be greater than
the number of register groups. After the last match, returns
RESULT-FORM if provided or NIL otherwise. An implicit block named NIL
surrounds DO-REGISTER-GROUPS; RETURN may be used to terminate the loop
immediately. If REGEX matches an empty string the scan is continued
one position behind this match. If SHAREDP is true, the substrings may
share structure with TARGET-STRING. BODY may start with declarations."
  (with-rebinding (target-string)
    (with-unique-names (substr-fn match-start match-end
                                  reg-starts reg-ends start-index)
      `(let ((,substr-fn (if ,sharedp
                          #'nsubseq
                          #'subseq)))
        (do-scans (,match-start ,match-end ,reg-starts ,reg-ends
                                ,regex ,target-string
                                ,result-form :start ,start :end ,end)
          (let ,(loop for (function var) in (normalize-var-list var-list)
                      for counter from 0
                      when var
                        collect `(,var (let ((,start-index
                                               (aref ,reg-starts ,counter)))
                                         (if ,start-index
                                           (funcall ,function
                                                    (funcall ,substr-fn
                                                             ,target-string
                                                             ,start-index
                                                             (aref ,reg-ends ,counter)))
                                           nil))))
            ,@body))))))

(defun all-matches (regex target-string
                          &key (start 0)
                               (end (length target-string)))
  (declare (optimize speed
                     (safety 0)
                     (space 0)
                     (debug 0)
                     (compilation-speed 0)
                     #+:lispworks (hcl:fixnum-safety 0)))
  "Returns a list containing the start and end positions of all
matches of REGEX against TARGET-STRING, i.e. if there are N matches
the list contains (* 2 N) elements. If REGEX matches an empty string
the scan is continued one position behind this match."
  (let (result-list)
    (do-matches (match-start match-end
                 regex target-string
                 (nreverse result-list)
                 :start start :end end)
      (push match-start result-list)
      (push match-end result-list))))

(define-compiler-macro all-matches (&whole form &environment env regex &rest rest)
   "Make sure that constant forms are compiled into scanners at
compile time."
   (cond ((constantp regex env)
           `(all-matches (load-time-value
                           (create-scanner ,regex))
			 ,@rest))
         (t form)))

(defun all-matches-as-strings (regex target-string
                                     &key (start 0)
                                          (end (length target-string))
                                          sharedp)
  (declare (optimize speed
                     (safety 0)
                     (space 0)
                     (debug 0)
                     (compilation-speed 0)
                     #+:lispworks (hcl:fixnum-safety 0)))
  "Returns a list containing all substrings of TARGET-STRING which
match REGEX. If REGEX matches an empty string the scan is continued
one position behind this match. If SHAREDP is true, the substrings may
share structure with TARGET-STRING."
  (let (result-list)
    (do-matches-as-strings (match regex target-string (nreverse result-list)
                                  :start start :end end :sharedp sharedp)
      (push match result-list))))

(define-compiler-macro all-matches-as-strings (&whole form &environment env regex &rest rest)
   "Make sure that constant forms are compiled into scanners at
compile time."
   (cond ((constantp regex env)
           `(all-matches-as-strings
	    (load-time-value
              (create-scanner ,regex))
	    ,@rest))
         (t form)))

(defun split (regex target-string
                    &key (start 0)
                         (end (length target-string))
                         limit
                         with-registers-p
                         omit-unmatched-p
                         sharedp)
  (declare (optimize speed
                     (safety 0)
                     (space 0)
                     (debug 0)
                     (compilation-speed 0)
                     #+:lispworks (hcl:fixnum-safety 0)))
  "Matches REGEX against TARGET-STRING as often as possible and
returns a list of the substrings between the matches. If
WITH-REGISTERS-P is true, substrings corresponding to matched
registers are inserted into the list as well. If OMIT-UNMATCHED-P is
true, unmatched registers will simply be left out, otherwise they will
show up as NIL. LIMIT limits the number of elements returned -
registers aren't counted. If LIMIT is NIL (or 0 which is equivalent),
trailing empty strings are removed from the result list.  If REGEX
matches an empty string the scan is continued one position behind this
match. If SHAREDP is true, the substrings may share structure with
TARGET-STRING."
  ;; initialize list of positions POS-LIST to extract substrings with
  ;; START so that the start of the next match will mark the end of
  ;; the first substring
  (let ((pos-list (list start))
        (counter 0))
    ;; how would Larry Wall do it?
    (when (eql limit 0)
      (setq limit nil))
    (do-scans (match-start match-end
               reg-starts reg-ends
               regex target-string nil
               :start start :end end)
      (unless (and (= match-start match-end)
                   (= match-start (car pos-list)))
        ;; push start of match on list unless this would be an empty
        ;; string adjacent to the last element pushed onto the list
        (when (and limit
                   (>= (incf counter) limit))
          (return))
        (push match-start pos-list)
        (when with-registers-p
          ;; optionally insert matched registers
          (loop for reg-start across reg-starts
                for reg-end across reg-ends
                if reg-start
                  ;; but only if they've matched
                  do (push reg-start pos-list)
                     (push reg-end pos-list)
                else unless omit-unmatched-p
                  ;; or if we're allowed to insert NIL instead
                  do (push nil pos-list)
                     (push nil pos-list)))
        ;; now end of match
        (push match-end pos-list)))
    ;; end of whole string
    (push end pos-list)
    ;; now collect substrings
    (nreverse
     (loop with substr-fn = (if sharedp #'nsubseq #'subseq)
           with string-seen = nil
           for (this-end this-start) on pos-list by #'cddr
           ;; skip empty strings from end of list
           if (or limit
                  (setq string-seen
                          (or string-seen
                              (and this-start
                                   (> this-end this-start)))))
           collect (if this-start
                     (funcall substr-fn
                              target-string this-start this-end)
                     nil)))))

(define-compiler-macro split (&whole form &environment env regex target-string &rest rest)
  "Make sure that constant forms are compiled into scanners at compile time."
  (cond ((constantp regex env)
          `(split (load-time-value
                    (create-scanner ,regex))
                  ,target-string ,@rest))
        (t form)))

(defun string-case-modifier (str from to start end)
  (declare (optimize speed
                     (safety 0)
                     (space 0)
                     (debug 0)
                     (compilation-speed 0)
                     #+:lispworks (hcl:fixnum-safety 0)))
  (declare (type fixnum from to start end))
  "Checks whether all words in STR between FROM and TO are upcased,
downcased or capitalized and returns a function which applies a
corresponding case modification to strings. Returns #'IDENTITY
otherwise, especially if words in the target area extend beyond FROM
or TO. STR is supposed to be bounded by START and END. It is assumed
that (<= START FROM TO END)."
  (case
      (if (or (<= to from)
              (and (< start from)
                   (alphanumericp (char str (1- from)))
                   (alphanumericp (char str from)))
              (and (< to end)
                   (alphanumericp (char str to))
                   (alphanumericp (char str (1- to)))))
        ;; if it's a zero-length string or if words extend beyond FROM
        ;; or TO we return NIL, i.e. #'IDENTITY
        nil
        ;; otherwise we loop through STR from FROM to TO
        (loop with last-char-both-case
              with current-result
              for index of-type fixnum from from below to
              for chr = (char str index)
              do (cond ((not #-:cormanlisp (both-case-p chr)
                             #+:cormanlisp (or (upper-case-p chr)
                                               (lower-case-p chr)))
                         ;; this character doesn't have a case so we
                         ;; consider it as a word boundary (note that
                         ;; this differs from how \b works in Perl)
                         (setq last-char-both-case nil))
                       ((upper-case-p chr)
                         ;; an uppercase character
                         (setq current-result
                                 (if last-char-both-case
                                   ;; not the first character in a 
                                   (case current-result
                                     ((:undecided) :upcase)
                                     ((:downcase :capitalize) (return nil))
                                     ((:upcase) current-result))
                                   (case current-result
                                     ((nil) :undecided)
                                     ((:downcase) (return nil))
                                     ((:capitalize :upcase) current-result)))
                               last-char-both-case t))
                       (t
                         ;; a lowercase character
                         (setq current-result
                                 (case current-result
                                   ((nil) :downcase)
                                   ((:undecided) :capitalize)
                                   ((:downcase) current-result)
                                   ((:capitalize) (if last-char-both-case
                                                    current-result
                                                    (return nil)))
                                   ((:upcase) (return nil)))
                               last-char-both-case t)))
              finally (return current-result)))
    ((nil) #'identity)
    ((:undecided :upcase) #'string-upcase)
    ((:downcase) #'string-downcase)
    ((:capitalize) #'string-capitalize)))

;; first create a scanner to identify the special parts of the
;; replacement string (eat your own dog food...)
#-:cormanlisp
(let* ((*use-bmh-matchers* nil)
       (reg-scanner (create-scanner "\\\\(?:\\\\|\\{\\d+\\}|\\d+|&|`|')")))
  (defmethod build-replacement-template ((replacement-string string))
    (declare (optimize speed
                       (safety 0)
                       (space 0)
                       (debug 0)
                       (compilation-speed 0)
                       #+:lispworks (hcl:fixnum-safety 0)))
    "Converts a replacement string for REGEX-REPLACE or
REGEX-REPLACE-ALL into a replacement template which is an
S-expression."
    (let ((from 0)
          ;; COLLECTOR will hold the (reversed) template
          (collector '()))
      ;; scan through all special parts of the replacement string
      (do-matches (match-start match-end reg-scanner replacement-string)
        (when (< from match-start)
          ;; strings between matches are copied verbatim
          (push (subseq replacement-string from match-start) collector))
        ;; PARSE-START is true if the pattern matched a number which
        ;; refers to a register
        (let* ((parse-start (position-if #'digit-char-p
                                         replacement-string
                                         :start match-start
                                         :end match-end))
               (token (if parse-start
                        (1- (parse-integer replacement-string
                                           :start parse-start
                                           :junk-allowed t))
                        ;; if we didn't match a number we convert the
                        ;; character to a symbol
                        (case (char replacement-string (1+ match-start))
                          ((#\&) :match)
                          ((#\`) :before-match)
                          ((#\') :after-match)
                          ((#\\) :backslash)))))
          (when (and (numberp token) (< token 0))
            ;; make sure we don't accept something like "\\0"
            (signal-ppcre-invocation-error
             "Illegal substring ~S in replacement string"
             (subseq replacement-string match-start match-end)))
          (push token collector))
        ;; remember where the match ended
        (setq from match-end))
      (when (< from (length replacement-string))
        ;; push the rest of the replacement string onto the list
        (push (subseq replacement-string from) collector))
      (nreverse collector))))

#-:cormanlisp
(defmethod build-replacement-template ((replacement-function function))
  (list replacement-function))

#-:cormanlisp
(defmethod build-replacement-template ((replacement-function-symbol symbol))
  (list replacement-function-symbol))
        
#-:cormanlisp
(defmethod build-replacement-template ((replacement-list list))
  replacement-list)

;;; Corman Lisp's methods can't be closures... :(
#+:cormanlisp
(let* ((*use-bmh-matchers* nil)
       (reg-scanner (create-scanner "\\\\(?:\\\\|\\{\\d+\\}|\\d+|&|`|')")))
  (defun build-replacement-template (replacement)
    (declare (optimize speed
                       (safety 0)
                       (space 0)
                       (debug 0)
                       (compilation-speed 0)
                       #+:lispworks (hcl:fixnum-safety 0)))
    (typecase replacement
      (string
        (let ((from 0)
              ;; COLLECTOR will hold the (reversed) template
              (collector '()))
          ;; scan through all special parts of the replacement string
          (do-matches (match-start match-end reg-scanner replacement)
            (when (< from match-start)
              ;; strings between matches are copied verbatim
              (push (subseq replacement from match-start) collector))
            ;; PARSE-START is true if the pattern matched a number which
            ;; refers to a register
            (let* ((parse-start (position-if #'digit-char-p
                                             replacement
                                             :start match-start
                                             :end match-end))
                   (token (if parse-start
                            (1- (parse-integer replacement
                                               :start parse-start
                                               :junk-allowed t))
                            ;; if we didn't match a number we convert the
                            ;; character to a symbol
                            (case (char replacement (1+ match-start))
                              ((#\&) :match)
                              ((#\`) :before-match)
                              ((#\') :after-match)
                              ((#\\) :backslash)))))
              (when (and (numberp token) (< token 0))
                ;; make sure we don't accept something like "\\0"
                (signal-ppcre-invocation-error
                 "Illegal substring ~S in replacement string"
                 (subseq replacement match-start match-end)))
              (push token collector))
            ;; remember where the match ended
            (setq from match-end))
          (when (< from (length replacement))
            ;; push the rest of the replacement string onto the list
            (push (nsubseq replacement from) collector))
          (nreverse collector)))
      (list
        replacement)
      (t
        (list replacement)))))
        
(defun build-replacement (replacement-template
                          target-string
                          start end
                          match-start match-end
                          reg-starts reg-ends
                          simple-calls)
  (declare (optimize speed
                     (safety 0)
                     (space 0)
                     (debug 0)
                     (compilation-speed 0)
                     #+:lispworks (hcl:fixnum-safety 0)))
  "Accepts a replacement template and the current values from the
matching process in REGEX-REPLACE or REGEX-REPLACE-ALL and returns the
corresponding template."
  ;; the upper exclusive bound of the register numbers in the regular
  ;; expression
  (let ((reg-bound (if reg-starts
                     (array-dimension reg-starts 0)
                     0)))
    (with-output-to-string (s)
      (loop for token in replacement-template
            do (typecase token
                 (string
                   ;; transfer string parts verbatim
                   (write-string token s))
                 (integer
                   ;; replace numbers with the corresponding registers
                   (when (>= token reg-bound)
                     ;; but only if the register was referenced in the
                     ;; regular expression
                     (signal-ppcre-invocation-error
                      "Reference to non-existent register ~A in replacement string"
                      (1+ token)))
                   (when (svref reg-starts token)
                     ;; and only if it matched, i.e. no match results
                     ;; in an empty string
                     (write-string target-string s
                                   :start (svref reg-starts token)
                                   :end (svref reg-ends token))))
                 (function
                   (write-string 
                    (cond (simple-calls
                           (apply token
                                  (nsubseq target-string match-start match-end)
                                  (map 'list
                                       (lambda (reg-start reg-end)
                                         (and reg-start
                                              (nsubseq target-string reg-start reg-end)))
                                       reg-starts reg-ends)))
                          (t
                           (funcall token
                                    target-string
                                    start end
                                    match-start match-end
                                    reg-starts reg-ends)))
                    s))
                 (symbol
                   (case token
                     ((:backslash)
                       ;; just a backslash
                       (write-char #\\ s))
                     ((:match)
                       ;; the whole match
                       (write-string target-string s
                                     :start match-start
                                     :end match-end))
                     ((:before-match)
                       ;; the part of the target string before the match
                       (write-string target-string s
                                     :start start
                                     :end match-start))
                     ((:after-match)
                       ;; the part of the target string after the match
                       (write-string target-string s
                                     :start match-end
                                     :end end))
                     (otherwise
                      (write-string
                       (cond (simple-calls
                              (apply token
                                     (nsubseq target-string match-start match-end)
                                     (map 'list
                                          (lambda (reg-start reg-end)
                                            (and reg-start
                                                 (nsubseq target-string reg-start reg-end)))
                                          reg-starts reg-ends)))
                             (t
                              (funcall token
                                       target-string
                                       start end
                                       match-start match-end
                                       reg-starts reg-ends)))
                       s)))))))))

(defun replace-aux (target-string replacement pos-list reg-list
                                  start end preserve-case simple-calls)
  (declare (optimize speed
                     (safety 0)
                     (space 0)
                     (debug 0)
                     (compilation-speed 0)
                     #+:lispworks (hcl:fixnum-safety 0)))
  "Auxiliary function used by REGEX-REPLACE and
REGEX-REPLACE-ALL. POS-LIST contains a list with the start and end
positions of all matches while REG-LIST contains a list of arrays
representing the corresponding register start and end positions."
  ;; build the template once before we start the loop
  (let ((replacement-template (build-replacement-template replacement)))
    (with-output-to-string (s)
      ;; loop through all matches and take the start and end of the
      ;; whole string into account
      (loop for (from to) on (append (list start) pos-list (list end))
            ;; alternate between replacement and no replacement
            for replace = nil then (and (not replace) to)
            for reg-starts = (if replace (pop reg-list) nil)
            for reg-ends = (if replace (pop reg-list) nil)
            for curr-replacement = (if replace
                                     ;; build the replacement string
                                     (build-replacement replacement-template
                                                        target-string
                                                        start end
                                                        from to
                                                        reg-starts reg-ends
                                                        simple-calls)
                                     nil)
            while to
            if replace
              do (write-string (if preserve-case
                                 ;; modify the case of the replacement
                                 ;; string if necessary
                                 (funcall (string-case-modifier target-string
                                                                from to
                                                                start end)
                                          curr-replacement)
                                 curr-replacement)
                               s)
            else
              ;; no replacement
              do (write-string target-string s :start from :end to)))))

(defun regex-replace (regex target-string replacement
                            &key (start 0)
                            (end (length target-string))
                            preserve-case
                            simple-calls)
  (declare (optimize speed
                     (safety 0)
                     (space 0)
                     (debug 0)
                     (compilation-speed 0)
                     #+:lispworks (hcl:fixnum-safety 0)))
  "Try to match TARGET-STRING between START and END against REGEX and
replace the first match with REPLACEMENT.

  REPLACEMENT can be a string which may contain the special substrings
\"\\&\" for the whole match, \"\\`\" for the part of TARGET-STRING
before the match, \"\\'\" for the part of TARGET-STRING after the
match, \"\\N\" or \"\\{N}\" for the Nth register where N is a positive
integer.

  REPLACEMENT can also be a function designator in which case the
match will be replaced with the result of calling the function
designated by REPLACEMENT with the arguments TARGET-STRING, START,
END, MATCH-START, MATCH-END, REG-STARTS, and REG-ENDS. (REG-STARTS and
REG-ENDS are arrays holding the start and end positions of matched
registers or NIL - the meaning of the other arguments should be
obvious.)

  Finally, REPLACEMENT can be a list where each element is a string,
one of the symbols :MATCH, :BEFORE-MATCH, or :AFTER-MATCH -
corresponding to \"\\&\", \"\\`\", and \"\\'\" above -, an integer N -
representing register (1+ N) -, or a function designator.

  If PRESERVE-CASE is true, the replacement will try to preserve the
case (all upper case, all lower case, or capitalized) of the
match. The result will always be a fresh string, even if REGEX doesn't
match."
  (multiple-value-bind (match-start match-end reg-starts reg-ends)
      (scan regex target-string :start start :end end)
    (if match-start
      (replace-aux target-string replacement
                   (list match-start match-end)
                   (list reg-starts reg-ends)
                   start end preserve-case simple-calls)
      (subseq target-string start end))))

(define-compiler-macro regex-replace
    (&whole form &environment env regex target-string replacement &rest rest)
  "Make sure that constant forms are compiled into scanners at compile time."
  (cond ((constantp regex env)
          `(regex-replace (load-time-value
                            (create-scanner ,regex))
                          ,target-string ,replacement ,@rest))
        (t form)))

(defun regex-replace-all (regex target-string replacement
                                &key (start 0)
                                     (end (length target-string))
                                     preserve-case
                                     simple-calls)
  (declare (optimize speed
                     (safety 0)
                     (space 0)
                     (debug 0)
                     (compilation-speed 0)
                     #+:lispworks (hcl:fixnum-safety 0)))
  "Try to match TARGET-STRING between START and END against REGEX and
replace all matches with REPLACEMENT.

  REPLACEMENT can be a string which may contain the special substrings
\"\\&\" for the whole match, \"\\`\" for the part of TARGET-STRING
before the match, \"\\'\" for the part of TARGET-STRING after the
match, \"\\N\" or \"\\{N}\" for the Nth register where N is a positive
integer.

  REPLACEMENT can also be a function designator in which case the
match will be replaced with the result of calling the function
designated by REPLACEMENT with the arguments TARGET-STRING, START,
END, MATCH-START, MATCH-END, REG-STARTS, and REG-ENDS. (REG-STARTS and
REG-ENDS are arrays holding the start and end positions of matched
registers or NIL - the meaning of the other arguments should be
obvious.)

  Finally, REPLACEMENT can be a list where each element is a string,
one of the symbols :MATCH, :BEFORE-MATCH, or :AFTER-MATCH -
corresponding to \"\\&\", \"\\`\", and \"\\'\" above -, an integer N -
representing register (1+ N) -, or a function designator.

  If PRESERVE-CASE is true, the replacement will try to preserve the
case (all upper case, all lower case, or capitalized) of the
match. The result will always be a fresh string, even if REGEX doesn't
match."
  (let ((pos-list '())
        (reg-list '()))
    (do-scans (match-start match-end reg-starts reg-ends regex target-string
               nil
               :start start :end end)
      (push match-start pos-list)
      (push match-end pos-list)
      (push reg-starts reg-list)
      (push reg-ends reg-list))
    (if pos-list
      (replace-aux target-string replacement
                   (nreverse pos-list)
                   (nreverse reg-list)
                   start end preserve-case simple-calls)
      (subseq target-string start end))))

(define-compiler-macro regex-replace-all
    (&whole form &environment env regex target-string replacement &rest rest)
  "Make sure that constant forms are compiled into scanners at compile time."
  (cond ((constantp regex env)
          `(regex-replace-all (load-time-value
                                (create-scanner ,regex))
                              ,target-string ,replacement ,@rest))
        (t form)))

#-:cormanlisp
(defmacro regex-apropos-aux ((regex packages case-insensitive &optional return-form)
                             &body body)
  "Auxiliary macro used by REGEX-APROPOS and REGEX-APROPOS-LIST. Loops
through PACKAGES and executes BODY with SYMBOL bound to each symbol
which matches REGEX. Optionally evaluates and returns RETURN-FORM at
the end. If CASE-INSENSITIVE is true and REGEX isn't already a
scanner, a case-insensitive scanner is used."
  (with-rebinding (regex)
    (with-unique-names (scanner %packages next morep)
      `(let* ((,scanner (create-scanner ,regex
                                        :case-insensitive-mode
                                        (and ,case-insensitive
                                             (not (functionp ,regex)))))
              (,%packages (or ,packages
                              (list-all-packages))))
        (with-package-iterator (,next ,%packages :external :internal)
          (loop
            (multiple-value-bind (,morep symbol)
                (,next)
              (unless ,morep
                (return ,return-form))
              (when (scan ,scanner (symbol-name symbol))
                ,@body))))))))

;;; The following two functions were provided by Karsten Poeck

#+:cormanlisp
(defmacro do-with-all-symbols ((variable package-packagelist) &body body)
  (with-unique-names (pack-var iter-sym)
    `(if (listp ,package-packagelist)
      (dolist (,pack-var ,package-packagelist)
        (do-symbols (,iter-sym ,pack-var)
          ,@body))
      (do-symbols (,iter-sym ,package-packagelist)
        ,@body))))

#+:cormanlisp
(defmacro regex-apropos-aux ((regex packages case-insensitive &optional return-form)
                             &body body)
  "Auxiliary macro used by REGEX-APROPOS and REGEX-APROPOS-LIST. Loops
through PACKAGES and executes BODY with SYMBOL bound to each symbol
which matches REGEX. Optionally evaluates and returns RETURN-FORM at
the end. If CASE-INSENSITIVE is true and REGEX isn't already a
scanner, a case-insensitive scanner is used."
  (with-rebinding (regex)
    (with-unique-names (scanner %packages)
      `(let* ((,scanner (create-scanner ,regex
                         :case-insensitive-mode
                         (and ,case-insensitive
                              (not (functionp ,regex)))))
              (,%packages (or ,packages
                             (list-all-packages))))
        (do-with-all-symbols (symbol ,%packages)
          (when (scan ,scanner (symbol-name symbol))
            ,@body))
        ,return-form))))

(defun regex-apropos-list (regex &optional packages &key (case-insensitive t))
  (declare (optimize speed
                     (safety 0)
                     (space 0)
                     (debug 0)
                     (compilation-speed 0)
                     #+:lispworks (hcl:fixnum-safety 0)))
  "Similar to the standard function APROPOS-LIST but returns a list of
all symbols which match the regular expression REGEX. If
CASE-INSENSITIVE is true and REGEX isn't already a scanner, a
case-insensitive scanner is used."
  (let ((collector '()))
    (regex-apropos-aux (regex packages case-insensitive collector)
      (push symbol collector))))

(defun print-symbol-info (symbol)
  "Auxiliary function used by REGEX-APROPOS. Tries to print some
meaningful information about a symbol."
  (declare (optimize speed
                     (safety 0)
                     (space 0)
                     (debug 0)
                     (compilation-speed 0)
                     #+:lispworks (hcl:fixnum-safety 0)))
  (handler-case
    (let ((output-list '()))
      (cond ((special-operator-p symbol)
              (push "[special operator]" output-list))
            ((macro-function symbol)
              (push "[macro]" output-list))
            ((fboundp symbol)
              (let* ((function (symbol-function symbol))
                     (compiledp (compiled-function-p function)))
                (multiple-value-bind (lambda-expr closurep)
                    (function-lambda-expression function)
                  (push
                    (format nil
                            "[~:[~;compiled ~]~:[function~;closure~]]~:[~; ~A~]"
                            compiledp closurep lambda-expr (cadr lambda-expr))
                    output-list)))))
      (let ((class (find-class symbol nil)))
        (when class
          (push (format nil "[class] ~S" class) output-list)))
      (cond ((keywordp symbol)
              (push "[keyword]" output-list))
            ((constantp symbol)
              (push (format nil "[constant]~:[~; value: ~S~]"
                            (boundp symbol) (symbol-value symbol)) output-list))
            ((boundp symbol)
              (push #+(or LispWorks CLISP) "[variable]"
                    #-(or LispWorks CLISP) (format nil "[variable] value: ~S"
                                                   (symbol-value symbol))
                    output-list)))
      #-(or :cormanlisp :clisp)
      (format t "~&~S ~<~;~^~A~@{~:@_~A~}~;~:>" symbol output-list)
      #+(or :cormanlisp :clisp)
      (loop for line in output-list
            do (format t "~&~S ~A" symbol line)))
    (condition ()
      ;; this seems to be necessary due to some errors I encountered
      ;; with LispWorks
      (format t "~&~S [an error occured while trying to print more info]" symbol))))

(defun regex-apropos (regex &optional packages &key (case-insensitive t))
  "Similar to the standard function APROPOS but returns a list of all
symbols which match the regular expression REGEX. If CASE-INSENSITIVE
is true and REGEX isn't already a scanner, a case-insensitive scanner
is used."
  (declare (optimize speed
                     (safety 0)
                     (space 0)
                     (debug 0)
                     (compilation-speed 0)
                     #+:lispworks (hcl:fixnum-safety 0)))
  (regex-apropos-aux (regex packages case-insensitive)
    (print-symbol-info symbol))
  (values))

(let* ((*use-bmh-matchers* nil)
       (non-word-char-scanner (create-scanner "[^a-zA-Z_0-9]")))
  (defun quote-meta-chars (string &key (start 0) (end (length string)))
    "Quote, i.e. prefix with #\\\\, all non-word characters in STRING."
    (regex-replace-all non-word-char-scanner string "\\\\\\&"
                       :start start :end end)))

(let* ((*use-bmh-matchers* nil)
       (*allow-quoting* nil)
       (quote-char-scanner (create-scanner "\\\\Q"))
       (section-scanner (create-scanner "\\\\Q((?:[^\\\\]|\\\\(?!Q))*?)(?:\\\\E|$)")))
  (defun quote-sections (string)
    "Replace sections inside of STRING which are enclosed by \\Q and
\\E with the quoted equivalent of these sections \(see
QUOTE-META-CHARS). Repeat this as long as there are such
sections. These sections may nest."
    (flet ((quote-substring (target-string start end match-start
                                           match-end reg-starts reg-ends)
             (declare (ignore start end match-start match-end))
             (quote-meta-chars target-string
                               :start (svref reg-starts 0)
                               :end (svref reg-ends 0))))
      (loop for result = string then (regex-replace-all section-scanner
                                                        result
                                                        #'quote-substring)
            while (scan quote-char-scanner result)
            finally (return result)))))

(let* ((*use-bmh-matchers* nil)
       (comment-scanner (create-scanner "(?s)\\(\\?#.*?\\)"))
       (extended-comment-scanner (create-scanner "(?m:#.*?$)|(?s:\\(\\?#.*?\\))"))
       (quote-token-scanner "\\\\[QE]")
       (quote-token-replace-scanner "\\\\([QE])"))
  (defun clean-comments (string &optional extended-mode)
    "Clean \(?#...) comments within STRING for quoting, i.e. convert
\\Q to Q and \\E to E. If EXTENDED-MODE is true, also clean
end-of-line comments, i.e. those starting with #\\# and ending with
#\\Newline."
    (flet ((remove-tokens (target-string start end match-start
                                         match-end reg-starts reg-ends)
             (declare (ignore start end reg-starts reg-ends))
             (loop for result = (nsubseq target-string match-start match-end)
                   then (regex-replace-all quote-token-replace-scanner result "\\1")
                   ;; we must probably repeat this because the comment
                   ;; can contain substrings like \\Q
                   while (scan quote-token-scanner result)
                   finally (return result))))
      (regex-replace-all (if extended-mode
                           extended-comment-scanner
                           comment-scanner)
                         string
                         #'remove-tokens))))

(defun parse-tree-synonym (symbol)
  "Returns the parse tree the SYMBOL symbol is a synonym for. Returns
NIL is SYMBOL wasn't yet defined to be a synonym."
  (get symbol 'parse-tree-synonym))

(defun (setf parse-tree-synonym) (new-parse-tree symbol)
  "Defines SYMBOL to be a synonm for the parse tree NEW-PARSE-TREE."
  (setf (get symbol 'parse-tree-synonym) new-parse-tree))

(defmacro define-parse-tree-synonym (name parse-tree)
  "Defines the symbol NAME to be a synonym for the parse tree
PARSE-TREE. Both arguments are quoted."
  `(eval-when (:compile-toplevel :load-toplevel :execute)
     (setf (parse-tree-synonym ',name) ',parse-tree)))

#+END_SRC

* Config
** [[/Users/Can/Develop/Lisp/others/config/sbcl.cl][sbcl]]
#+BEGIN_SRC lisp 

;;; The following lines added by ql:add-to-init-file:
#-quicklisp
(let ((quicklisp-init (merge-pathnames "quicklisp/setup.lisp"
                                       (user-homedir-pathname))))
  (when (probe-file quicklisp-init)
    (load quicklisp-init)))
;; (load (compile-file #P"~/Emacs/quicklisp/asdf.lisp"))
;;(load "/Develop/Lisp/asdf.3.1.7.lisp")
(setf *default-pathname-defaults* (truename "~/Develop/Lisp"))
(load "init.cl")

#+END_SRC

* Doc
** [[/Users/Can/Develop/Lisp/others/images/zpng/doc/rgb.lisp][rgb]]
#+BEGIN_SRC lisp 
(defpackage #:rgb
  (:use #:cl #:zpng))

(in-package #:rgb)

(defun draw-rgb (file)
  (let ((png (make-instance 'pixel-streamed-png
                             :color-type :truecolor-alpha
                             :width 200
                             :height 200)))
    (with-open-file (stream file
			    :direction :output
			    :if-exists :supersede
			    :if-does-not-exist :create
			    :element-type '(unsigned-byte 8))
      (start-png png stream)
      (loop for a from 38 to 255 by 31
	do (loop for b from 10 to 255 by 10
	     do (loop for g from 38 to 255 by 31
		  do (loop for r from 10 to 255 by 10
			do (write-pixel (list r g b a) png)))))
      (finish-png png))))

#+END_SRC

** [[/Users/Can/Develop/Lisp/others/images/zpng/doc/mandelbrot.lisp][mandelbrot]]
#+BEGIN_SRC lisp 
(defpackage #:mandelbrot
  (:use #:cl #:zpng))

(in-package #:mandelbrot)

(defun draw-mandelbrot (file)
  (let* ((png (make-instance 'png
                             :color-type :grayscale-alpha
                             :width 200
                             :height 200))
         (image (data-array png))
         (max 255))
    (dotimes (y 200 (write-png png file))
      (dotimes (x 200)
        (let ((c (complex (- (/ x 100.0) 1.5) (- (/ y 100.0) 1.0)))
              (z (complex 0.0 0.0))
              (iteration 0))
          (loop
           (setf z (+ (* z z) c))
           (incf iteration)
           (cond ((< 4 (abs z))
                  (setf (aref image y x 1) iteration)
                  (return))
                 ((= iteration max)
                  (setf (aref image y x 1) 255)
                  (return))))))))))

#+END_SRC

* Exploring
** [[/Users/Can/Develop/Lisp/others/young/basic/exploring/factorial.lisp][factorial]]
#+BEGIN_SRC lisp 
(ql:quickload 'cl-ppcre)
(defun factorial (n)
  (let ((result 1))
    (dotimes (i n result)
      (setf result (* result (1+ i))))))

(defun end-zero-count (digit)
  (length (cl-ppcre:scan-to-strings "0*$" (write-to-string digit))))

(defun factorial-end-zero-count (n)
  (end-zero-count (factorial n)))

(dotimes (i 52)
  (let* ((n (1+ i))
	 (result (factorial n)))
  (format t "~a! = ~a (~a ending 0) ~%" n result (end-zero-count result))))


#+END_SRC

** [[/Users/Can/Develop/Lisp/others/young/basic/exploring/cmd.lisp][cmd]]
#+BEGIN_SRC lisp 
#!/usr/local/bin/sbcl --script

(write-line "Hello, World!")

#+END_SRC

* Images
** [[/Users/Can/Develop/Lisp/others/images/convert-image.lisp][convert-image]]
#+BEGIN_SRC lisp 
;; https://github.com/slyrus/opticl
(ql:quickload 'opticl) 
(defpackage #:impatient (:use #:cl #:opticl))
(in-package #:impatient)


(defun play-image (path new-path)
  (let ((img (read-jpeg-file path)))
    ;; (typecase img
    ;;   (8-bit-rgb-image
    ;;    (locally
    ;;        (declare (type 8-bit-rgb-image img))
    ;;      (with-image-bounds (height width)
    ;;          img
    ;;        (time
    ;;         (loop for i below (/ height 3)
    ;;            do (loop for j below (/ width 2)
    ;;                  do 
    ;;                    (multiple-value-bind (r g b)		;; Get the RGB values 
    ;;                        (pixel img i j)
    ;;                      (declare (type (unsigned-byte 8) r g b))
    ;;                      (let ((a (min 255 (round (/ (+ r g b) 2)))))	;; Make it black white
    ;;                        (setf (pixel img i j)
    ;;                              (values a a a)))))))))))
    ;; Change pixel RGB to average, just for test example
    (write-jpeg-file new-path (update-image img))))

(defun filter-image (path new-path)
  (let ((img (read-jpeg-file path)))
    (typecase img
      (8-bit-rgb-image
       (locally
           (declare (type 8-bit-rgb-image img))
         (with-image-bounds (height width)
             img
           (time
            (loop for i below height			;;  Just for test
               do (loop for j below width
                     do 
                       (multiple-value-bind (r g b)		;; Get the RGB values 
                           (pixel img i j)
                         (declare (type (unsigned-byte 8) r g b))
                         (setf (pixel img i j)
                               (if (> i (/ height 2))
                                   (values (- 255 r)
                                           (if (> j (/ width 2)) (- 255 g) (max 0 (- 200 g)))
                                           (- 255 b))
                                   (let ((a (round (/ (+ r g b) 3))))
                                     (values (if (< j (/ width 2))
                                                    a
                                                    (min 255 (* a 2)))
                                             a
                                             a))))))))))))
    (write-jpeg-file new-path img)))

(defun add-line (path new-path)
  (time
   (let ((img (read-jpeg-file path)))
     (horizontal-line img 200 0 600 20 30 250)
     (horizontal-line img 304 0 600 220 30 250)
     (horizontal-line img 422 0 600 20 230 50)
     (write-jpeg-file new-path img))))

(defun fill-the-image (path new-path)
  "Just fill"           
  (time
   (let ((img (read-jpeg-file path)))
     (fill-image img 100 120 110)
     (write-jpeg-file new-path img))))

(defun draw-circle-to-image (path new-path)
  "Circle~~"           
  (time
   (let ((img (read-jpeg-file path)))
     (draw-circle img 100 100 50 50 50 200)
     (draw-circle img 200 100 51 150 50 0) 
     (draw-circle img 100 200 52 200 250 200)
     (draw-circle img 200 200 53 150 50 200)
     (draw-circle img 100 200 54 50 250 100)     
     (draw-circle img 300 100 155 50 50 200)     
     (write-jpeg-file new-path (fit-image-into img :y-max 400 :x-max 500 :pad t)))))



(defun update-image (img)
  "Just for exploration"
  (time (trim-image img 30 50)))
;; (transpose-image img)  ;rotate left
;; (horizontal-flip-image img)
;; (trim-image img 20 50)
;; (vertical-flip-image img)
;;
;; (crop-image img 100 200 660 640)))
;; (edge-detect-image img)))
;; (sharpen-image img)))
;; (blur-image img)))
;; (fit-image-into img :y-max 400 :x-max 200 :pad t))))  


;; (resize-image img height width)

;; (convert-image "test.jpg" "black.jpg")  

#+END_SRC

* Info
** [[/Users/Can/Develop/Lisp/others/young/info/slime-hot-key.lisp][slime-hot-key]]
#+BEGIN_SRC lisp 
(add-hook 'lisp-mode-hook
	  (lambda ()
	    (global-set-key (kbd "C-c C-q") 'slime-close-all-parens-in-sexp)		"C-c C-]"
	    (global-set-key (kbd "C-c C-c") 'slime-compile-defun)
	    (global-set-key (kbd "C-c C-r") 'slime-eval-region)
	    (global-set-key (kbd "C-c C-l") 'slime-load-file)
	    (global-set-key (kbd "C-c C-k") 'slime-compile-and-load-file)
	    (global-set-key (kbd "C-c M-k") 'slime-compile-file)
	    (global-set-key (kbd "C-M-k") 'slime-repl-clear-buffer)
	    (global-set-key (kbd "<tab>") 'slime-complete-symbol-function)
	    (local-set-key (kbd "C-c C-z") 'slime-switch-to-output-buffer)))

indent-buffer  <f9>

aka => Press "," 

change-directory (aka !d, cd)

M-.
Find definition  ⭐️

C-j
M-x slime-repl-newline-and-indent
Open and indent a new line.


C-M-b/f/p/n
Go to the corresponding sexp parenthesis

C-M-u
Move up in parenthesis structure (backward-up-list). 
C-M-d
Move down in parenthesis structure (down-list).

M-r, M-x slime-repl-previous-matching-input
M-s, M-x slime-repl-next-matching-input

M-n, M-x slime-repl-next-input
M-p, M-x slime-repl-previous-input


To cut the text, press C-w.
To copy the text, press M-w.
To paste the text, press C-y.		paste back:	M-y

C-x C-w  	Save to
C-x h 		Select all region 
M-x write-region   Write selected region to a file

C-c C-c
M-x slime-interrupt
Interrupt the Lisp process with SIGINT.


Shortcuts

change-directory (aka !d, cd)
Change the current directory.

change-package (aka !p, in, in-package)
Change the current package.

compile-and-load (aka cl)  => ,cl
Compile (if necessary) and load a lisp file.

defparameter (aka !)
Define a new global, special, variable.

disconnect
Disconnect all connections.

help (aka ?)
Display the help.

pop-directory (aka -d)
Pop the current directory.

pop-package (aka -p)
Pop the top of the package stack.

push-directory (aka +d, pushd)
Push a new directory onto the directory stack.

push-package (aka +p)
Push a package onto the package stack.

pwd
Show the current directory.

quit
Quit the current Lisp.

resend-form
Resend the last form.

restart-inferior-lisp
Restart *inferior-lisp* and reconnect SLIME.

sayoonara
Quit all Lisps and close all SLIME buffers.


C-x { is bound to shrink-window-horizontally
C-x } is bound to enlarge-window-horizontally
#+END_SRC

* Learn
** [[/Users/Can/Develop/Lisp/mine/learn/read-write.cl][read-write]]
#+BEGIN_SRC lisp 
(ql:quickload :cl-ppcre)
(defun reg-replace-string (string &rest rules)
  "Replace the string by regex rules, one by one"           
  (dolist (rule rules string)
    (setf string (cl-ppcre:regex-replace-all
                  (car rule) string (cdr rule)
                  :preserve-case t))))

(defparameter *grep-cache* (make-hash-table :test 'equal))

(defun cached (keyword path &optional (extension "htm"))
  (let* ((key (format nil "~s-~s" path keyword))
         (-result- (gethash key *grep-cache*)))
    (format t "~%Directory: ~a ~%" *default-pathname-defaults*)
    (unless -result-
      (format t "~%~% ❄️  Caching Hashing ~a~%~%" key)
      (let ((shell-cmd (format nil "find ~a~a/*.~a -maxdepth 1 -exec grep -FHni ~S {} \\;"
                               *default-pathname-defaults* path extension
                               keyword)))
        (println shell-cmd)
        (setf -result-            
              (uiop:run-program shell-cmd
                                ;; "grep -Fnri ~S ~a/~a" keyword +source-root+ path)
                                :output '(:string :stripped t)
                                ;; :external-format :latin-1		;; default :utf-8  sometimes exception
                                :ignore-error-status t)))
      (sethash key -result- *grep-cache*))
      ;; (format t "Results: ~A~%" -result-))
    -result-))




(defun search-keyword (keyword &optional (path "document/pcl"))
  "Search keyword in a direcoty"
  (when (= (length keyword) 0)
    (return-from search-keyword "Please give a keyword"))
  ;; (print $shell-cmd)
  ;; (print (cl-ppcre:regex-replace-all "\\(|\\)|\\.|\\?|\\+|\\[" keyword "\\\\&"))
  (with-input-from-string (in (cached keyword path))
    (with-output-to-string (out)
      (loop 
         (multiple-value-bind (string code)
             (read-line in nil "No results... 🦑 ")
           (format out "~&<p>~a</p>"
                   (reg-replace-string string
                                       '("</?[^>]+>" . "-")
                                       '("\\.htm:(\\d)+:" . "\\& &nbsp;&nbsp; ==>> <br />")
                                       (cons (concat-string "(?i)" (cl-ppcre:regex-replace-all "\\(|\\)|\\.|\\?|\\+|\\[" keyword "\\\\\\&"))
                                             (format nil "<strong>~a</strong>" keyword))))
           (when code (return out)))))))


;; (handler-bind ((sb-int:stream-decoding-error
;;                 #'(lambda (c)
;;                     (format t "Error ~a~%" c)
;;                     (invoke-restart (find-restart 'attempt-resync)))))
;;   (uiop:run-program "grep -rni do ." :output '(:string :stripped t)))

#+END_SRC

** [[/Users/Can/Develop/Lisp/mine/learn/hunchentoot.lisp][hunchentoot]]
#+BEGIN_SRC lisp 
;; Wed Oct  9 22:46:38 2019
(ql:quickload :hunchentoot)
($load-file "mine/learn/read-write.cl")
(use-package :hunchentoot)


(defun start-with-hunchentoot (&optional (port 8080))
  "Exploring the Hunchentoot server..."
  (let (($acceptor (make-instance 'easy-acceptor :port port)))
    (start $acceptor)
    (define-easy-handler (say-yo :uri "/yosh") (name)
      (setf (hunchentoot:content-type*) "application/json")
      (format nil "{\"name\":\"Your name: ~A\"}" name ))
    $acceptor))

(defun grep (keyword &optional (folder "."))
  (cmd (format nil "grep -i -r ~S ~a | head" keyword folder) :string))

(defparameter *acceptor* nil)

(defun start-file-server (&optional (port 8888)
                          &aux ($acceptor (make-instance 'easy-acceptor
                                                         :port port
                                                         :document-root "./document/"
                                                         :listen-backlog 100
                                                         :read-timeout 25
                                                         :write-timeout 25
                                                         :name "GreatServer")))
  "Exploring the Hunchentoot server..."
  (when (and *acceptor* (started-p *acceptor*))
    (stop *acceptor*))
  (start $acceptor)
  ;; (setf (acceptor-message-log-destination $acceptor) "message.txt")	;; or nil to disable
  ;; (setf (acceptor-access-log-destination $acceptor) "access.txt")
  (define-easy-handler (search-key :uri "/search") (key)
    (setf (hunchentoot:content-type*) "text/html")
    (format nil "<style>
p {~@
	font-size: 20px; font-weight: 300; color: navy;
}
strong {
	font-weight: 500;
	color: red;
}
</style> ~%~a"
            (search-keyword key)))
  (setf *acceptor* $acceptor))

;; (format t "~&Search ~A" (search-keyword "welcome"))


#+END_SRC

* Lib
** [[/Users/Can/Develop/Lisp/others/lib/sqlite3-sql.lisp][sqlite3-sql]]
#+BEGIN_SRC lisp 
;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
;;;; Name:     sqlite-sql.lisp
;;;; Purpose:  High-level SQLite3 interface
;;;; Authors:  Aurelio Bignoli & Kevin Rosenberg
;;;; Created:  Oct 2004
;;;;
;;;; This file, part of CLSQL, is Copyright (c) 2004-2010 by Aurelio Bignoli & Kevin Rosenberg
;;;;
;;;; CLSQL users are granted the rights to distribute and use this software
;;;; as governed by the terms of the Lisp Lesser GNU Public License
;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
;;;; *************************************************************************

(in-package #:clsql-sqlite3)

(defclass sqlite3-database (database)
  ((sqlite3-db :initarg :sqlite3-db :accessor sqlite3-db)))

(defmethod database-type ((database sqlite3-database))
  :sqlite3)

(defmethod database-initialize-database-type ((database-type (eql :sqlite3)))
  t)

(defun check-sqlite3-connection-spec (connection-spec)
  (check-connection-spec connection-spec :sqlite3 (name &optional init-foreign-func)))

(defmethod database-name-from-spec (connection-spec
                                    (database-type (eql :sqlite3)))
  (check-sqlite3-connection-spec connection-spec)
  (first connection-spec))

(defmethod database-connect (connection-spec (database-type (eql :sqlite3)))
  (check-sqlite3-connection-spec connection-spec)
    (handler-case
        (let ((db (sqlite3:sqlite3-open (first connection-spec)))
              (init-foreign-func (second connection-spec)))
          (declare (type sqlite3:sqlite3-db-type db))
          (when init-foreign-func
            (handler-case
                (funcall init-foreign-func db)
              (condition (c)
                (progn
                  (sqlite3:sqlite3-close db)
                  (error c)))))
          (make-instance 'sqlite3-database
                         :name (database-name-from-spec connection-spec :sqlite3)
                         :database-type :sqlite3
                         :connection-spec connection-spec
                         :sqlite3-db db))
      (sqlite3:sqlite3-error (err)
        (error 'sql-connection-error
               :database-type database-type
               :connection-spec connection-spec
               :error-id (sqlite3:sqlite3-error-code err)
               :message (sqlite3:sqlite3-error-message err)))))

(defmethod database-disconnect ((database sqlite3-database))
  (sqlite3:sqlite3-close (sqlite3-db database))
  (setf (sqlite3-db database) nil)
  t)

(defmethod database-execute-command (sql-expression (database sqlite3-database))
  (handler-case
      (let ((stmt (sqlite3:sqlite3-prepare (sqlite3-db database) sql-expression)))
        (declare (type sqlite3:sqlite3-stmt-type stmt))
        (when stmt
          (unwind-protect
               (sqlite3:sqlite3-step stmt)
            (sqlite3:sqlite3-finalize stmt))))
    (sqlite3:sqlite3-error (err)
      (error 'sql-database-data-error
             :database database
             :expression sql-expression
             :error-id (sqlite3:sqlite3-error-code err)
             :message (sqlite3:sqlite3-error-message err))))
  t)

(defstruct sqlite3-result-set
  (stmt sqlite3:null-stmt
        :type sqlite3:sqlite3-stmt-type)
  (n-col 0 :type fixnum)
  (col-names '())
  (result-types '()))

(declaim (ftype (function (sqlite3:sqlite3-stmt-type fixnum t) list) get-result-types))
(defun get-result-types (stmt n-col result-types)
  (declare (type sqlite3:sqlite3-stmt-type stmt) (type fixnum n-col))
  (if (eq :auto result-types)
      (loop for n from 0 below n-col
            collect (let ((column-type (sqlite3:sqlite3-column-type stmt n)))
                      (cond
                        ((= column-type sqlite3:SQLITE-INTEGER) :int64)
                        ((= column-type sqlite3:SQLITE-FLOAT) :double)
                        ((= column-type sqlite3:SQLITE-TEXT) :string)
                        ((= column-type sqlite3:SQLITE-BLOB) :blob)
                        ((= column-type sqlite3:SQLITE-NULL) :string)
                        (t :string))))
      (loop for type in result-types
            collect (case type
                      ((:int :integer :tinyint) :int32)
                      (:long #+(or x86-64 64bit) :int64 #-(or x86-64 64bit) :int32)
                      (:bigint :int64)
                      ((:float :double) :double)
                      ((:numeric) :number)
                      (otherwise :string)))))

(defmethod database-query-result-set ((query-expression string)
                                      (database sqlite3-database)
                                      &key result-types full-set)
  (let ((stmt sqlite3:null-stmt))
    (declare (type sqlite3:sqlite3-stmt-type stmt))
    (handler-case
        (progn
          (setf stmt (sqlite3:sqlite3-prepare (sqlite3-db database)
                                              query-expression))
          (let* ((n-col (if (sqlite3:sqlite3-step stmt)
                            ;; Non empty result set.
                            (sqlite3:sqlite3-column-count stmt)
                            ;; Empty result set.
                            0))
                 (result-set (make-sqlite3-result-set
                              :stmt stmt
                              :n-col n-col
                              :col-names (loop for n from 0 below n-col
                                               collect (sqlite3:sqlite3-column-name stmt n))
                              :result-types (when (> n-col 0)
                                              (get-result-types stmt n-col result-types)))))
            (if full-set
                (values result-set n-col nil)
                (values result-set n-col))))
    (sqlite3:sqlite3-error (err)
        (progn
          (unless (eq stmt sqlite3:null-stmt)
            (ignore-errors
              (sqlite3:sqlite3-finalize stmt)))
          (error 'sql-database-data-error
                 :database database
                 :expression query-expression
                 :error-id (sqlite3:sqlite3-error-code err)
                 :message (sqlite3:sqlite3-error-message err)))))))

(defmethod database-dump-result-set (result-set (database sqlite3-database))
  (handler-case
      (sqlite3:sqlite3-finalize (sqlite3-result-set-stmt result-set))
    (sqlite3:sqlite3-error (err)
      (error 'sql-database-error
             :message
             (format nil "Error finalizing SQLite3 statement: ~A"
                     (sqlite3:sqlite3-error-message err))))))

(defmethod database-store-next-row (result-set (database sqlite3-database) list)
  (let ((n-col (sqlite3-result-set-n-col result-set)))
    (if (= n-col 0)
        ;; empty result set.
        nil
        ;; Non-empty set.
        (let ((stmt (sqlite3-result-set-stmt result-set)))
          (declare (type sqlite3:sqlite3-stmt-type stmt))
          ;; Store row in list.
          (loop for i = 0 then (1+ i)
                for rest on list
                for types = (sqlite3-result-set-result-types result-set) then (rest types)
                do (setf (car rest)
                         (if (eq (first types) :blob)
                             (clsql-uffi:convert-raw-field
                              (sqlite3:sqlite3-column-blob stmt i)
                              (car types)
                              :length (sqlite3:sqlite3-column-bytes stmt i)
                              :encoding (encoding database))
                             (clsql-uffi:convert-raw-field
                              (sqlite3:sqlite3-column-text stmt i)
                              (car types)
                              :encoding (encoding database)))))
          ;; Advance result set cursor.
          (handler-case
              (unless (sqlite3:sqlite3-step stmt)
                (setf (sqlite3-result-set-n-col result-set) 0))
            (sqlite3:sqlite3-error (err)
              (error 'sql-database-error
                     :message (format nil "Error in sqlite3-step: ~A"
                                      (sqlite3:sqlite3-error-message err)))))
          t))))


(defmethod database-query (query-expression (database sqlite3-database) result-types field-names)
  (declare (optimize (speed 3) (safety 0) (debug 0) (space 0)))
  (handler-case
      (let ((stmt (sqlite3:sqlite3-prepare (sqlite3-db database)
                                           query-expression))
            (rows '())
            (col-names '()))
        (declare (type sqlite3:sqlite3-stmt-type stmt))
        (unwind-protect
             (when (sqlite3:sqlite3-step stmt)
               (let ((n-col (sqlite3:sqlite3-column-count stmt)))
                 (flet ((extract-row-data ()
                          (loop for i from 0 below n-col
                                for types = (get-result-types stmt n-col result-types) then (rest types)
                                collect (if (eq (first types) :blob)
                                            (clsql-uffi:convert-raw-field
                                             (sqlite3:sqlite3-column-blob stmt i)
                                             (car types)
                                             :length (sqlite3:sqlite3-column-bytes stmt i)
                                             :encoding (encoding database))
                                            (clsql-uffi:convert-raw-field
                                             (sqlite3:sqlite3-column-text stmt i)
                                             (car types)
                                             :encoding (encoding database))))))
                   (when field-names
                     (setf col-names (loop for n from 0 below n-col
                                           collect (sqlite3:sqlite3-column-name stmt n))))
                   (push (extract-row-data) rows)
                   (do* () (nil)
                     (if (sqlite3:sqlite3-step stmt)
                         (push (extract-row-data) rows)
                         (return))))))
               (sqlite3:sqlite3-finalize stmt))
        (values (nreverse rows) col-names))
    (sqlite3:sqlite3-error (err)
      (error 'sql-database-data-error
             :database database
             :expression query-expression
             :error-id (sqlite3:sqlite3-error-code err)
             :message (sqlite3:sqlite3-error-message err)))))

;;; Object listing

(defmethod database-list-tables-and-sequences ((database sqlite3-database) &key owner)
  (declare (ignore owner))
  ;; Query is copied from .table command of sqlite3 command line utility.
  (mapcar #'car (database-query
                 "SELECT name FROM sqlite_master WHERE type='table' UNION ALL SELECT name FROM sqlite_temp_master WHERE type='table' ORDER BY name"
                 database nil nil)))

(defmethod database-list-tables ((database sqlite3-database) &key owner)
  (remove-if #'(lambda (s)
                 (and (>= (length s) 11)
                      (string-equal (subseq s 0 11) "_CLSQL_SEQ_")))
             (database-list-tables-and-sequences database :owner owner)))

(defmethod database-list-views ((database sqlite3-database)
                                &key (owner nil))
  (declare (ignore owner))
  (mapcar #'car (database-query
                 "SELECT name FROM sqlite_master WHERE type='view' UNION ALL SELECT name FROM sqlite_temp_master WHERE type='view' ORDER BY name"
                 database nil nil)))

(defmethod database-list-indexes ((database sqlite3-database)
                                  &key (owner nil))
  (declare (ignore owner))
  (mapcar #'car (database-query
                 "SELECT name FROM sqlite_master WHERE type='index' UNION ALL SELECT name FROM sqlite_temp_master WHERE type='index' ORDER BY name"
                 database nil nil)))

(defmethod database-list-table-indexes (table (database sqlite3-database)
                                        &key (owner nil))
  (declare (ignore owner))
  (let ((*print-circle* nil))
    (mapcar #'car
            (database-query
             (format
              nil
              "SELECT name FROM sqlite_master WHERE type='index' AND tbl_name='~A' UNION ALL SELECT name FROM sqlite_temp_master WHERE type='index' AND tbl_name='~A' ORDER BY name"
              table table)
             database nil nil))))

(declaim (inline sqlite3-table-info))
(defun sqlite3-table-info (table database)
  (database-query (format nil "PRAGMA table_info('~A')" table)
                  database nil nil))

(defmethod database-list-attributes (table (database sqlite3-database)
                                           &key (owner nil))
  (declare (ignore owner))
  (mapcar #'(lambda (table-info) (second table-info))
          (sqlite3-table-info table database)))

(defmethod database-attribute-type (attribute table
                                    (database sqlite3-database)
                                    &key (owner nil))
  (declare (ignore owner))

  (loop for field-info in (sqlite3-table-info table database)
      when (string= attribute (second field-info))
      return
        (let* ((raw-type (third field-info))
               (start-length (position #\( raw-type))
               (type (string-trim clsql-sys::+whitespace-chars+
				  (if start-length
				      (subseq raw-type 0 start-length)
				      raw-type)))
               (length (if start-length
                           (parse-integer (subseq raw-type (1+ start-length))
                                          :junk-allowed t)
                         nil)))
          (values (when type (ensure-keyword type))
                  length
                  nil
                  (if (string-equal (fourth field-info) "0")
                      1 0)))))

(defmethod database-create (connection-spec (type (eql :sqlite3)))
  (declare (ignore connection-spec))
  ;; databases are created automatically by Sqlite3
  t)

(defmethod database-destroy (connection-spec (type (eql :sqlite3)))
  (destructuring-bind (name) connection-spec
    (if (probe-file name)
        (delete-file name)
        nil)))

(defmethod database-probe (connection-spec (type (eql :sqlite3)))
  (destructuring-bind (name) connection-spec
    ;; TODO: Add a test that this file is a real sqlite3 database
    (or (string-equal ":memory:" name)
        (and (probe-file name) t))))

;;; Database capabilities

(defmethod db-type-has-boolean-where? ((db-type (eql :sqlite3)))
  nil)

#+END_SRC

** [[/Users/Can/Develop/Lisp/others/lib/socket-server.lisp][socket-server]]
#+BEGIN_SRC lisp 
;;;; See LICENSE for licensing information.
(ql:quickload 'BORDEAUX-THREADS)
(in-package :usocket)

(defvar *server*)

(defun socket-server (host port function &optional arguments
                      &key in-new-thread (protocol :stream)
                           ;; for udp
                           (timeout 1) (max-buffer-size +max-datagram-packet-size+)
                           ;; for tcp
                           element-type (reuse-address t) multi-threading
                           name)
  (let* ((real-host (or host *wildcard-host*))
         (socket (ecase protocol
                   (:stream
                    (apply #'socket-listen
                           `(,real-host ,port
                             ,@(when element-type `(:element-type ,element-type))
                             ,@(when reuse-address `(:reuse-address ,reuse-address)))))
                   (:datagram
                    (socket-connect nil nil :protocol :datagram
                                    :local-host real-host
                                    :local-port port)))))
    (labels ((real-call ()
               (ecase protocol
                 (:stream
                  (tcp-event-loop socket function arguments
                                  :element-type element-type
                                  :multi-threading multi-threading))
                 (:datagram
                  (udp-event-loop socket function arguments
                                  :timeout timeout
                                  :max-buffer-size max-buffer-size)))))
      (if in-new-thread
	  (values (bt:make-thread #'real-call :name (or name "USOCKET Server")) socket)
	(progn
	  (setq *server* socket)
	  (real-call))))))

(defvar *remote-host*)
(defvar *remote-port*)

(defun default-udp-handler (buffer) ; echo
  (declare (type (simple-array (unsigned-byte 8) *) buffer))
  buffer)

(defun udp-event-loop (socket function &optional arguments
                       &key timeout max-buffer-size)
  (let ((buffer (make-array max-buffer-size :element-type '(unsigned-byte 8) :initial-element 0))
        (sockets (list socket)))
    (unwind-protect
        (loop do
          (multiple-value-bind (return-sockets real-time)
              (wait-for-input sockets :timeout timeout)
            (declare (ignore return-sockets))
            (when real-time
              (multiple-value-bind (recv n *remote-host* *remote-port*)
                  (socket-receive socket buffer max-buffer-size)
                (declare (ignore recv))
                (if (plusp n)
                    (progn
                      (let ((reply
                             (apply function (subseq buffer 0 n) arguments)))
                        (when reply
                          (replace buffer reply)
                          (let ((n (socket-send socket buffer (length reply)
                                                :host *remote-host*
                                                :port *remote-port*)))
                            (when (minusp n)
                              (error "send error: ~A~%" n))))))
                  (error "receive error: ~A" n))))
            #+scl (when thread:*quitting-lisp* (return))
            #+(and cmu mp) (mp:process-yield)))
      (socket-close socket)
      (values))))

(defun default-tcp-handler (stream) ; null
  (declare (type stream stream))
  (format stream "Hello world!~%"))

(defun echo-tcp-handler (stream)
  (loop
     (when (listen stream)
       (let ((line (read-line stream nil)))
	 (write-line line stream)
	 (force-output stream)))))

(defun tcp-event-loop (socket function &optional arguments
                       &key element-type multi-threading)
  (let ((real-function #'(lambda (client-socket &rest arguments)
                           (unwind-protect
                               (multiple-value-bind (*remote-host* *remote-port*) (get-peer-name client-socket)
                                 (apply function (socket-stream client-socket) arguments))
                             (close (socket-stream client-socket))
                             (socket-close client-socket)
                             nil))))
    (unwind-protect
        (loop do
          (let* ((client-socket (apply #'socket-accept
                                       `(,socket ,@(when element-type `(:element-type ,element-type)))))
                 (client-stream (socket-stream client-socket)))
            (if multi-threading
                (bt:make-thread (lambda () (apply real-function client-socket arguments))
                                :name "USOCKET Client")
              (prog1 (apply real-function client-socket arguments)
                (close client-stream)
                (socket-close client-socket)))
            #+scl (when thread:*quitting-lisp* (return))
            #+(and cmu mp) (mp:process-yield)))
      (socket-close socket)
      (values))))

#+END_SRC

** [[/Users/Can/Develop/Lisp/others/lib/sdraw.lisp][sdraw]]
#+BEGIN_SRC lisp 
;;; -*- Mode: Lisp -*-
;;;
;;; SDRAW - draws cons cell structures.
;;;
;;; From the book "Common Lisp:  A Gentle Introduction to
;;;      Symbolic Computation" by David S. Touretzky.  
;;; The Benjamin/Cummings Publishing Co., 1990.
;;;
;;; This is the generic version; it will work in any legal Common Lisp.
;;; Revised to include support for circular structures.
;;; Revised again, August, 2003, to work with ANSI Common Lisp and Allegro v6.
;;;
;;; User-level routines:
;;;   (sdraw obj)  - draws obj on the display
;;;   (sdraw-loop) - puts the user in a read-eval-draw loop
;;;   (scrawl obj) - interactively crawl around obj
;;;
;;; Variables:
;;;   *sdraw-print-circle*    If bound, overrides *print-circle*.
;;;   *sdraw-leading-arrow*   Initially nil.  Set to t to get leading arrows.
;;;

(defpackage :sdraw
  (:use :common-lisp)
  (:export sdraw sdraw-loop scrawl *sdraw-print-circle* *sdraw-leading-arrow*))

(in-package :sdraw)

(export '(sdraw::sdraw sdraw::sdraw-loop sdraw::scrawl
	      sdraw::*sdraw-print-circle* sdraw::*sdraw-leading-arrow*))

(shadowing-import  '(sdraw::sdraw sdraw::sdraw-loop sdraw::scrawl
		             sdraw::*sdraw-print-circle*
		             sdraw::*sdraw-leading-arrow*)
		           (find-package :common-lisp-user))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; The parameters below are in units of characters (horizontal)
;;; and lines (vertical).  They apply to all versions of SDRAW,
;;; but their values may change if cons cells are being drawn as
;;; bit maps rather than as character sequences.

(defparameter *sdraw-display-width* 79.)
(defparameter *sdraw-horizontal-atom-cutoff* 79.)
(defparameter *sdraw-horizontal-cons-cutoff* 65.)

(defparameter *etc-string* "etc.")
(defparameter *etc-spacing* 4.)

(defparameter *inter-atom-h-spacing* 3.)
(defparameter *cons-atom-h-arrow-length* 9.)
(defparameter *inter-cons-v-arrow-length* 3.)
(defparameter *cons-v-arrow-offset-threshold* 2.)
(defparameter *cons-v-arrow-offset-value* 1.)
(defparameter *leading-arrow-length* 4)

(defparameter *sdraw-num-lines* 25)
(defparameter *sdraw-vertical-cutoff* 22.)

(defvar *sdraw-leading-arrow* nil)
(defvar *sdraw-print-circle*)
(defvar *sdraw-circular-switch*)
(defvar *circ-detected* nil)
(defvar *circ-label-counter* 0)
(defparameter *circ-hash-table* (make-hash-table :test #'eq :size 20))

(defvar *line-endings* (make-array *sdraw-num-lines*))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; SDRAW and subordinate definitions.

(defun sdraw (obj &aux (*circ-detected* nil))
  (let ((*sdraw-circular-switch*
	     (if (boundp '*sdraw-print-circle*) *sdraw-print-circle*
	         *print-circle*))
	    (start-col (if *sdraw-leading-arrow* *leading-arrow-length* 0)))
    (init-struct1 start-col)
    (clrhash *circ-hash-table*)
    (let* ((first-layout (struct1 obj 0 start-col 0 nil))
	       (second-layout (when *circ-detected*
			                (init-struct1 start-col)
			                (struct1 obj 0 start-col 0 t))))
      (draw-structure (or second-layout first-layout))
      (values))))



(defun init-struct1 (start-col)
  (setf *circ-label-counter* 0)
  (fill *line-endings* most-negative-fixnum)
  (struct-record-position 0 (- start-col *inter-atom-h-spacing*)))

(defun never-seen? (obj)
  (null (gethash obj *circ-hash-table*)))

(defun seen-twice? (obj)
  (numberp (gethash obj *circ-hash-table*)))

(defun needs-label? (obj)
  (zerop (gethash obj *circ-hash-table*)))



(defun struct1 (obj row root-col adj second-pass)
  (cond ((>= row *sdraw-vertical-cutoff*) (struct-process-etc row root-col adj))
	    ((not second-pass)
	     (enter-in-hash-table obj)
	     (struct-first-pass obj row root-col adj))
	    (t (struct-second-pass obj row root-col adj))))

(defun enter-in-hash-table (obj)
  (unless (or (not *sdraw-circular-switch*)
	          (numberp obj)
	          (and (symbolp obj) (symbol-package obj)))
    (cond ((never-seen? obj) (setf (gethash obj *circ-hash-table*) t))
	      (t (setf (gethash obj *circ-hash-table*) 0)
	         (setf *circ-detected* t)))))

(defun struct-first-pass (obj row root-col adj)
  (if (seen-twice? obj)
      (struct-process-circ-reference obj row root-col adj)
      (if (atom obj)
	      (struct-unlabeled-atom (format nil "~S" obj) row root-col adj)
	      (struct-unlabeled-cons obj row root-col adj nil))))

(defun struct-second-pass (obj row root-col adj)
  (cond ((not (seen-twice? obj))
	     (if (atom obj)
	         (struct-unlabeled-atom (format nil "~S" obj) row root-col adj)
	         (struct-unlabeled-cons obj row root-col adj t)))
	    ((needs-label? obj)
	     (if (atom obj)
	         (struct-label-atom obj row root-col adj)
	         (struct-label-cons obj row root-col adj)))
	    (t (struct-process-circ-reference obj row root-col adj))))


;;; Handle the simplest case:  an atom or cons with no #n= label.

(defun struct-unlabeled-atom (atom-string row root-col adj)
  (let* ((start-col (struct-find-start row root-col adj))
	     (end-col (+ start-col adj (length atom-string))))
    (cond ((< end-col *sdraw-horizontal-atom-cutoff*)
	       (struct-record-position row end-col)
	       (list 'atom row (+ start-col adj) atom-string))
	      (t (struct-process-etc row root-col adj)))))

(defun struct-unlabeled-cons (obj row root-col adj second-pass)
  (let* ((cons-start (struct-find-start row root-col adj))
	     (car-structure
	      (struct1 (car obj)
		           (+ row *inter-cons-v-arrow-length*)
		           cons-start adj second-pass))
	     (start-col (third car-structure)))
    (if (>= start-col *sdraw-horizontal-cons-cutoff*)
	    (struct-process-etc row root-col adj)
	    (progn
	      (struct-record-position row (- (+ start-col
					                        *cons-atom-h-arrow-length*)
					                     adj *inter-atom-h-spacing*))
	      (list 'cons row start-col car-structure
		        (struct1 (cdr obj) row (+ start-col *cons-atom-h-arrow-length*)
			             0 second-pass))))))

(defun struct-process-etc (row root-col adj)
  (let ((start-col (struct-find-start row root-col adj)))
    (struct-record-position
     row
     (+ start-col adj (length *etc-string*) *etc-spacing*))
    (list 'msg row (+ start-col adj) *etc-string*)))




;;; Handle objects that need to be labeled with #n=.
;;; Called only on the second pass.

(defun struct-label-atom (obj row root-col adj)
  (assign-label obj)
  (let* ((circ-string (format nil "#~S=" (gethash obj *circ-hash-table*)))
	     (newadj (struct-find-adj row root-col adj (length circ-string)))
	     (atom-string (format nil "~S" obj))
	     (start-col (struct-find-start row root-col adj))
	     (end-col (+ start-col newadj (length atom-string))))
    (cond ((< end-col *sdraw-horizontal-atom-cutoff*)
	       (struct-record-position row end-col)
	       (list 'atom row (+ start-col newadj) atom-string circ-string))
	      (t (struct-process-etc row root-col adj)))))

(defun struct-label-cons (obj row root-col adj)
  (assign-label obj)
  (let* ((string (format nil "#~S=" *circ-label-counter*))
	     (newadj (struct-find-adj row root-col adj (length string)))
	     (cons-start (struct-find-start row root-col adj))
	     (car-structure
	      (struct1 (car obj)
		           (+ row *inter-cons-v-arrow-length*)
		           cons-start newadj t))
	     (start-col (third car-structure)))
    (if (>= start-col *sdraw-horizontal-cons-cutoff*)
	    (struct-process-etc row root-col adj)
	    (progn
	      (struct-record-position row (- (+ start-col
					                        *cons-atom-h-arrow-length*)
					                     adj *inter-atom-h-spacing*))
	      (list 'cons row start-col car-structure
		        (struct1 (cdr obj) row
			             (+ start-col *cons-atom-h-arrow-length*) 0 t)
		        string)))))

(defun assign-label (obj)
  (setf (gethash obj *circ-hash-table*)
	    (incf *circ-label-counter*)))


;;; Handle circular references by displaying them as #n#.
;;; When called on the first pass, this function always uses a label of 0.
;;; It will get the label right on the second pass.

(defun struct-process-circ-reference (obj row root-col adj)
  (let ((start-col (struct-find-start row root-col adj))
	    (string (format nil "#~S#" (gethash obj *circ-hash-table*))))
    (struct-record-position
     row
     (+ (+ start-col adj) (length string)))
    (list 'msg row (+ start-col adj) string)))



;;; Support functions.

(defun struct-find-start (row root-col adj)
  (max root-col
       (- (+ *inter-atom-h-spacing* (aref *line-endings* row)) adj)))

(defun struct-find-adj (row col adj size)
  (let* ((line-end (max 0 (+ *inter-atom-h-spacing*
			                 (aref *line-endings* row))))
	     (newadj (- line-end (- col (max size adj)))))
    (max adj (min (max newadj 0) size))))

(defun struct-record-position (row end-col)
  (setf (aref *line-endings* row) end-col))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; SDRAW-LOOP and subordinate definitions.

(defparameter *sdraw-loop-prompt-string* "S> ")

(defun sdraw-loop ()
  "Read-eval-print loop using sdraw to display results."
  (format t "~&Type any Lisp expression, or :ABORT to exit.~%~%")
  (sdl1))

(defun sdl1 ()
  (loop
     (format t "~&~A" *sdraw-loop-prompt-string*)
     (force-output t)
     (let ((form (read)))
       (setf +++ ++
             ++  +
             +   -
             -   form)
       (if (eq form :abort) (return-from sdl1))
       (let ((result (eval form)))
         (setf /// //
               //  /
               /   (list result)
               *** **
               **  *
               *   result)
         (display-sdl-result *)))))

(defun display-sdl-result (result)
  (sdraw result)
  (let* ((*print-circle* (if (boundp '*sdraw-print-circle*)
			                 *sdraw-print-circle*
		                     *print-circle*))
	     (*print-length* nil)
	     (*print-level* nil)
	     (*print-pretty* #+cmu t #-cmu nil)
	     (full-text (format nil "Result:  ~S" result))
	     (text (if (> (length full-text)
		              *sdraw-display-width*)
		           (concatenate 'string
		                        (subseq full-text 0 (- *sdraw-display-width* 4))
		                        "...)")
		           full-text)))
    (if (consp result)
        (format t "~%~A~%" text))
    (terpri)))

(defun display-sdl-error (error)
  (format t "~A~%~%" error))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; SCRAWL and subordinate definitions.

(defparameter *scrawl-prompt-string* "SCRAWL> ")
(defvar *scrawl-object* nil)
(defvar *scrawl-current-obj*)
(defvar *extracting-sequence* nil)

(defun scrawl (obj)
  "Read-eval-print loop to travel through list"
  (format t "~&Crawl through list:  'H' for help, 'Q' to quit.~%~%")
  (setf *scrawl-object* obj)
  (scrawl-start-cmd)
  (scrawl1))

(defun scrawl1 ()
  (loop
     (format t "~&~A" *scrawl-prompt-string*)
     (force-output t)
     (let ((command (read-uppercase-char)))
       (case command
	     (#\A (scrawl-car-cmd))
	     (#\D (scrawl-cdr-cmd))
	     (#\B (scrawl-back-up-cmd))
	     (#\S (scrawl-start-cmd))
	     (#\H (display-scrawl-help))
	     (#\Q (return))
	     (t (display-scrawl-error))))))

(defun scrawl-car-cmd ()
  (cond ((consp *scrawl-current-obj*)
	     (push 'car *extracting-sequence*)
	     (setf *scrawl-current-obj* (car *scrawl-current-obj*)))
	    (t (format t
	               "~&Can't take CAR or CDR of an atom.  Use B to back up.~%")))
  (display-scrawl-result))

(defun scrawl-cdr-cmd ()
  (cond ((consp *scrawl-current-obj*)
	     (push 'cdr *extracting-sequence*)
	     (setf *scrawl-current-obj* (cdr *scrawl-current-obj*)))
	    (t (format t
	               "~&Can't take CAR or CDR of an atom.  Use B to back up.~%")))
  (display-scrawl-result))

(defun scrawl-back-up-cmd ()
  (cond (*extracting-sequence*
	     (pop *extracting-sequence*)
	     (setf *scrawl-current-obj*
	           (extract-obj *extracting-sequence* *scrawl-object*)))
	    (t (format t "~&Already at beginning of object.")))
  (display-scrawl-result))

(defun scrawl-start-cmd ()
  (setf *scrawl-current-obj* *scrawl-object*)
  (setf *extracting-sequence* nil)
  (display-scrawl-result))

(defun extract-obj (seq obj)
  (reduce #'funcall
	      seq
	      :initial-value obj
	      :from-end t))

(defun get-car/cdr-string ()
  (if (null *extracting-sequence*)
      (format nil "'~S" *scrawl-object*)
      (format nil "(c~Ar '~S)"
	          (map 'string #'(lambda (x)
			                   (ecase x
				                 (car #\a)
				                 (cdr #\d)))
		           *extracting-sequence*)
	          *scrawl-object*)))

(defun display-scrawl-result (&aux (*print-length* nil)
				                (*print-level* nil)
				                (*print-pretty* #+cmu t #-cmu nil)
				                (*print-circle* t))
  (let* ((extract-string (get-car/cdr-string))
	     (text (if (> (length extract-string) *sdraw-display-width*)
		           (concatenate 'string
		                        (subseq extract-string 0
			                            (- *sdraw-display-width* 4))
		                        "...)")
		           extract-string)))
    (sdraw *scrawl-current-obj*)
    (format t "~&~%~A~%~%" text)))

(defun display-scrawl-help ()
  (format t "~&Legal commands:  A)car   D)cdr  B)back up~%")
  (format t "~&                 S)start Q)quit H)help~%"))

(defun display-scrawl-error ()
  (format t "~&Illegal command.~%")
  (display-scrawl-help))

(defun read-uppercase-char ()
  (let ((response (read-line)))
    (and (plusp (length response))
	     (char-upcase (char response 0)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; The following definitions are specific to the tty implementation.

(defparameter *cons-string* "[*|*]")
(defparameter *cons-cell-flatsize* 5.)
(defparameter *cons-h-arrowshaft-char* #\-)
(defparameter *cons-h-arrowhead-char* #\>)
(defparameter *cons-v-line* "|")
(defparameter *cons-v-arrowhead* "v")

(defvar *textline-array* (make-array *sdraw-num-lines*))
(defvar *textline-lengths* (make-array *sdraw-num-lines*))

(eval-when (eval load)
  (dotimes (i *sdraw-num-lines*)
    (setf (aref *textline-array* i)
	      (make-string *sdraw-display-width*))))

(defun char-blt (row start-col string)
  (let ((spos (aref *textline-lengths* row))
	    (line (aref *textline-array* row)))
    (do ((i spos (1+ i)))
	    ((>= i start-col))
      (setf (aref line i) #\Space))
    (replace line string :start1 start-col)
    (setf (aref *textline-lengths* row)
	      (+ start-col (length string)))))

(defun draw-structure (directions)
  (fill *textline-lengths* 0.)
  (when *sdraw-leading-arrow* (draw-leading-arrow))
  (follow-directions directions)
  (dump-display))

(defun draw-leading-arrow ()
  (do ((i 0 (1+ i)))
      ((>= (1+ i) *leading-arrow-length*)
       (char-blt 0 i (string *cons-h-arrowhead-char*)))
    (char-blt 0 i (string *cons-h-arrowshaft-char*))))

(defun follow-directions (dirs &optional is-car)
  (ecase (car dirs)
    (cons (draw-cons dirs))
    ((atom msg) (draw-msg dirs is-car))))

(defun draw-cons (obj)
  (let* ((row (second obj))
	     (col (third obj))
	     (car-component (fourth obj))
	     (cdr-component (fifth obj))
	     (string (sixth obj))
	     (line (aref *textline-array* row))
	     (h-arrow-start (+ col *cons-cell-flatsize*))
	     (h-arrowhead-col (1- (third cdr-component)))
	     (cdr-string? (if (eq 'cons (first cdr-component))
			              (sixth cdr-component)
			              (fifth cdr-component))))
    (if cdr-string? (decf h-arrowhead-col (length cdr-string?)))
    (char-blt row (- col (length string))
	          (if string (concatenate 'string string *cons-string*)
		          *cons-string*))
    (do ((i h-arrow-start (1+ i)))
	    ((>= i h-arrowhead-col))
      (setf (aref line i) *cons-h-arrowshaft-char*))
    (setf (aref line h-arrowhead-col) *cons-h-arrowhead-char*)
    (setf (aref *textline-lengths* row) (1+ h-arrowhead-col))
    (char-blt (+ row 1) (+ col 1) *cons-v-line*)
    (char-blt (+ row 2) (+ col 1) *cons-v-arrowhead*)
    (follow-directions car-component t)
    (follow-directions cdr-component)))

(defun draw-msg (obj is-car)
  (let* ((row (second obj))
	     (col (third obj))
	     (string (fourth obj))
	     (circ-string (fifth obj)))
    (if circ-string (setf string (concatenate 'string circ-string string)))
    (char-blt row
	          (+ (- col (length circ-string))
		         (if (and is-car
			              (<= (length string)
			                  *cons-v-arrow-offset-threshold*))
		             *cons-v-arrow-offset-value*
		             0))
	          string)))

(defun dump-display ()
  (terpri)
  (dotimes (i *sdraw-num-lines*)
    (let ((len (aref *textline-lengths* i)))
      (if (plusp len)
	      (format t "~&~A"
		          (subseq (aref *textline-array* i) 0 len))
	      (return nil))))
  (terpri))

#+END_SRC

** [[/Users/Can/Develop/Lisp/others/lib/portable-sockets.lisp][portable-sockets]]
#+BEGIN_SRC lisp 
;;;; -*- Mode:Common-Lisp; Package:PORTABLE-SOCKETS; Syntax:common-lisp -*-
;;;; *-* File: /usr/local/gbbopen/source/tools/portable-sockets.lisp *-*
;;;; *-* Edited-By: cork *-*
;;;; *-* Last-Edit: Sun Apr  3 14:55:17 2011 *-*
;;;; *-* Machine: twister.local *-*

;;;; **************************************************************************
;;;; **************************************************************************
;;;; *
;;;; *                       Portable Socket Interface
;;;; *
;;;; **************************************************************************
;;;; **************************************************************************
;;;
;;; Written by: Dan Corkill
;;;
;;; Copyright (C) 2005-2011, Dan Corkill <corkill@GBBopen.org>
;;;
;;; Developed and supported by the GBBopen Project (http://GBBopen.org) and
;;; licenced under the Apache 2.0 license (see
;;; http://GBBopen.org/downloads/LICENSE for license details.)
;;;
;;; Bug reports, suggestions, enhancements, and extensions should be sent to
;;; corkill@GBBopen.org.
;;;
;;; On-line documentation for these portable sockets interface entities is
;;; available at http://gbbopen.org/hyperdoc/index.html
;;;
;;; This file requires the GBBopen Portable Threads Interface file
;;; (portable-threads.lisp), but is otherwise self-contained on the supported
;;; CLs.
;;;
;;; * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
;;;
;;;  08-02-05 File created.  (Corkill)
;;;  10-20-05 Make open-connection a generic-function.  (Corkill)
;;;  01-02-06 Rename :address keyword to :interface.  (Corkill)
;;;  05-08-06 Added support for the Scieneer CL. (dtc)
;;;
;;; * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
(defpackage :portable-sockets
  (:use :common-lisp))

(eval-when (:compile-toplevel :load-toplevel :execute)
  (unless (find-package ':portable-sockets)
    (make-package ':portable-sockets
                  :use '(:common-lisp #-ecl :portable-threads))))

(in-package :portable-sockets)

;;; ---------------------------------------------------------------------------
;;; Handle older CLISP versions

#+clisp
(eval-when (:compile-toplevel :load-toplevel :execute)
  (when (= (length (ext:arglist 'socket:socket-server)) 2)
    (pushnew ':old-clisp-version *features*)))

;;; ---------------------------------------------------------------------------
;;; Add a single feature to identify sufficiently new Digitool MCL
;;; implementations (both Digitool MCL and pre-1.2 Clozure CL include the
;;; feature mcl):

#+(and digitool ccl-5.1)
(eval-when (:compile-toplevel :load-toplevel :execute)
  (pushnew ':digitool-mcl *features*))

;;; ---------------------------------------------------------------------------
;;; Add clozure feature to legacy OpenMCL:

#+(and openmcl (not clozure))
(eval-when (:compile-toplevel :load-toplevel :execute)
  (pushnew ':clozure *features*))

;;; ===========================================================================

(eval-when (:compile-toplevel :load-toplevel :execute)
  #+allegro
  (require :sock)
  #+digitool-mcl
  (require :opentransport)
  ;; ECL must be built using ./configure --enable-threads:
  #+ecl
  (require 'sockets)
  #+lispworks
  (require "comm")
  #+sbcl
  (require :sb-bsd-sockets))

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

(eval-when (:compile-toplevel :load-toplevel :execute)
  (export '(*localhost*                 ; not documented
            accept-connection
            close-passive-socket
            local-hostname-and-port
            make-passive-socket
            open-connection
            remote-hostname-and-port
            shutdown-socket-stream
            start-connection-server
            with-open-connection
            write-crlf)))               ; not yet documented

;;; ===========================================================================

(defun portable-sockets-implementation-version ()
  "1.0")

;;; Added to *features* at the end of this file:
(defparameter *portable-sockets-version-keyword* 
    ;; Support cross-case mode CLs:
    (read-from-string (format nil ":portable-sockets-~a" 
                              (portable-sockets-implementation-version))))

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

(defun print-portable-sockets-herald ()
  (format t "~%;;; ~72,,,'-<-~>
;;;  Portable Sockets Interface ~a
;;;
;;;    Developed and supported by the GBBopen Project (http:/GBBopen.org/)
;;;    (See http://GBBopen.org/downloads/LICENSE for license details.)
;;; ~72,,,'-<-~>~2%"
          (portable-sockets-implementation-version)))
  
(eval-when (:load-toplevel)
  (print-portable-sockets-herald))

;;; ===========================================================================
;;;  Occasionally "localhost" isn't configured properly on some machines,
;;;  so we will use dotted notation as the default value:

(defvar *localhost* "127.0.0.1")

;;; ---------------------------------------------------------------------------
;;;  Generic functions

(defgeneric open-connection (host port &key))

;;; ===========================================================================
;;;  Need-to-port reporting

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defun need-to-port-warning/error (entity error)
    (funcall (if error 'error 'warn)
             "~s needs to be defined for ~a~@[ running on ~a~].~
              ~@[~%(Please send this error message and the result of ~
              ~% evaluating (pprint *features*) to bugs@gbbopen.org.)~]"
             entity
             (lisp-implementation-type) 
             (machine-type)
             error)))

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

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defmacro need-to-port (entity)
    ;; Generate compile-time warnings of needed porting:
    (need-to-port-warning/error entity nil)
    ;; Error if called at run time:
    `(need-to-port-warning/error ',entity t)))

;;; ===========================================================================
;;;  Passive-socket class for CLs without one

#+(or cmu
      lispworks
      scl)
(defclass passive-socket ()
  ((fd :type fixnum
       :initarg :fd
       :accessor passive-socket.fd)
   (element-type :type (member signed-byte unsigned-byte base-char)
                 :initarg :element-type
                 :accessor passive-socket.element-type)
   (port :type fixnum
         :initarg :port
         :accessor passive-socket.port)))

#+(or cmu
      lispworks
      scl)
(defmethod print-object ((passive-socket passive-socket) stream)
  (print-unreadable-object (passive-socket stream :type nil)
    (format stream "passive socket at 0.0.0.0/~s"
            (passive-socket.port passive-socket)))
  ;; Print-object must return object:
  passive-socket)

;;; ---------------------------------------------------------------------------
;;;   Hack for SBCL to store socket in socket-stream (in name slot)

#+sbcl
(defmethod sb-bsd-sockets:socket-make-stream 
    :after ((socket sb-bsd-sockets::socket) &rest args)
  (declare (ignore args))
  (setf (sb-impl::fd-stream-name (slot-value socket 'sb-bsd-sockets::stream))
        socket))

;;; ---------------------------------------------------------------------------
;;;   Add missing shutdown to Lispworks
;;;
;;;   how: 0 = SHUT_RD    Disables further receive operations
;;;        1 = SHUT_WR    Disables further send operations
;;;        2 = SHUT_RDWR  Disables further send and receive operations
#+lispworks
(fli::define-foreign-function (shutdown "shutdown")
    ((socket :long)
     (how :long))
  :result-type :fixnum)
;;;
;;;   and for ECL
#+ecl
(uffi:def-function "shutdown"
    ((socket :int)
     (how :int))
  :returning :int)
;;;
;;;   and for SBCL
#+sbcl
(sb-alien:define-alien-routine shutdown sb-alien:int
    (socket sb-alien:int)
    (how sb-alien:int))

;;; ---------------------------------------------------------------------------
;;;   Add selct for ECL (used in accept-connection)

#+ecl
(progn
  (uffi:def-foreign-type nil (:struct timeval (tv-sec :long) (tv-usec :long)))
  (declaim (inline select))
  (uffi:def-function "select"
      ((nfds :int)
       (readfds (* (:struct nil (--fds-bits (:array :long 32)))))
       (writefds (* (:struct nil (--fds-bits (:array :long 32)))))
       (exceptfds (* (:struct nil (--fds-bits (:array :long 32)))))
       (timeout (* (:struct timeval (tv-sec :long) (tv-usec :long)))))
    :returning :int))

;;; ===========================================================================
;;;  Utilities

#+(or cmu
      scl)
(defun ipaddr-to-dotted (ipaddr)
  (declare (type (unsigned-byte 32) ipaddr))
  (format nil "~d.~d.~d.~d"
          (ldb (byte 8 24) ipaddr)
          (ldb (byte 8 16) ipaddr)
          (ldb (byte 8 8) ipaddr)
          (ldb (byte 8 0) ipaddr)))

#+(or cmu
      scl)
(defun ipaddr-to-hostname (ipaddr)
  (declare (optimize (ext:inhibit-warnings 3)))
  (alien:with-alien 
      ((hostent (* ext::hostent) 
                (ext::gethostbyaddr (ext:htonl ipaddr) 4 ext::af-inet)))
    (unless (zerop (sys:sap-int (alien:alien-sap hostent)))
      (alien:slot hostent 'ext::name))))

#+sbcl
(defun ipvector-to-dotted (ipvector)
  (format nil "~d.~d.~d.~d"
          (aref ipvector 0)
          (aref ipvector 1)
          (aref ipvector 2)
          (aref ipvector 3)))

#+sbcl
(defun ipvector-to-hostname (ipvector)
  (let ((hostent
         (handler-case (sb-bsd-sockets:get-host-by-address ipvector)
           (sb-bsd-sockets:name-service-error (condition)
             (values nil condition)))))
    (when hostent
      (sb-bsd-sockets::host-ent-name hostent))))

;;; ===========================================================================
;;;  Connections

(defun open-connection-to-host (host port &key 
                                          (input-timeout nil)
                                          (output-timeout nil)
                                          (keepalive nil))
  ;; The (currently undocumented) :input-timeout extension is only accepted by
  ;; CLISP, Clozure CL, and Lispworks:
  #+(or allegro
        cmu
        digitool-mcl
        ecl
        sbcl
        scl)
  (declare (ignore input-timeout))
  ;; The (currently undocumented) :keepalive extension needs attention on:
  #+(or allegro
        cmu
        digitool-mcl
        ecl
        sbcl
        scl)
  (declare (ignore output-timeout))
  ;; The (currently undocumented) :keepalive extension needs attention on:
  #+(or allegro
        clisp
        cmu
        digitool-mcl
        ecl
        lispworks
        sbcl
        scl)
  (declare (ignore keepalive))
  #+allegro
  (socket:make-socket :remote-host host :remote-port port)
  #+clisp
  (socket:socket-connect port host 
                         :external-format ':unix 
                         :timeout (or input-timeout output-timeout))
  #+clozure
  (ccl:make-socket :remote-host host :remote-port port 
                   :input-timeout input-timeout
                   :output-timeout output-timeout
                   :keepalive keepalive)
  #+cmu
  (let ((socket (extensions:connect-to-inet-socket host port)))
    (system:make-fd-stream 
     socket
     :input 't
     :output 't
     :element-type 'character
     :buffering ':full
     :auto-close 't))
  #+digitool-mcl
  (ccl::open-tcp-stream host port)
  #+ecl
  (si:open-client-stream host port)
  #+lispworks
  (comm:open-tcp-stream host port :timeout (or input-timeout output-timeout))
  #+sbcl
  (let ((socket (make-instance 'sb-bsd-sockets:inet-socket
                  :protocol ':tcp
                  :type ':stream)))
    (sb-bsd-sockets:socket-connect 
     socket 
     (sb-bsd-sockets:host-ent-address
      (sb-bsd-sockets:get-host-by-name host))
     port)
    (sb-bsd-sockets:socket-make-stream 
     socket
     :input 't :output 't
     :element-type 'character
     :buffering ':full))
  #+scl
  (let ((socket (extensions:connect-to-inet-socket host port)))
    (system:make-fd-stream 
     socket
     :input 't
     :output 't
     :element-type 'character
     :buffering ':full
     :auto-close 't))
  #-(or allegro
        clisp
        clozure
        cmu
        digitool-mcl
        ecl
        lispworks
        sbcl
        scl)
  (need-to-port open-connection-to-host))

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

(defmethod open-connection ((host string) port &key input-timeout 
                                                    output-timeout
                                                    keepalive)
  (open-connection-to-host host port 
                           :input-timeout input-timeout
                           :output-timeout output-timeout
                           :keepalive keepalive))

(defmethod open-connection ((host integer) port &key input-timeout
                                                     output-timeout
                                                     keepalive)
  (open-connection-to-host host port 
                           :input-timeout input-timeout
                           :output-timeout output-timeout
                           :keepalive keepalive))

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

(defmacro with-open-connection ((connection host port &key input-timeout
                                                           output-timeout
                                                           keepalive)
                                &body body)
  `(let ((,connection (open-connection ,host ,port
                                       :input-timeout ,input-timeout
                                       :output-timeout ,output-timeout
                                       :keepalive ,keepalive)))
     (unwind-protect
         (progn ,@body)
       (when ,connection
         (close ,connection)))))

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

(defun make-passive-socket (port &key (backlog 5)
                                      interface
                                      keepalive
                                      reuse-address
                                      input-timeout
                                      output-timeout)
  ;; The (currently undocumented) :keepalive extension needs attention on:
  #+(or allegro
        clisp
        cmu
        digitool-mcl
        ecl
        lispworks
        sbcl
        scl)
  (declare (ignore keepalive))
  ;; The (currently undocumented) :input-timeout extension needs attention on:
  #+(or allegro
        clisp
        cmu
        digitool-mcl
        ecl
        lispworks
        sbcl
        scl)
  (declare (ignore input-timeout))
  ;; The (currently undocumented) :output-timeout extension needs attention on:
  #+(or allegro
        clisp
        cmu
        digitool-mcl
        ecl
        lispworks
        sbcl
        scl)
  (declare (ignore output-timeout))
  #+old-clisp-version
  (declare (ignore backlog interface))
  #+allegro 
  (socket:make-socket :connect ':passive 
                      :local-port port
                      :local-host interface
                      :backlog backlog
                      :reuse-address reuse-address)
  #+clisp
  (let ((passive-socket 
         #-old-clisp-version
         (socket:socket-server port
                               :interface interface
                               :backlog backlog)
         #+old-clisp-version
         (socket:socket-server port)))
    (socket:socket-options passive-socket
                           :so-reuseaddr reuse-address)
    passive-socket)
  #+clozure
  (ccl:make-socket :connect ':passive
                   :type ':stream
                   :local-port port
                   :local-host interface
                   :backlog backlog
                   :keepalive keepalive
                   :reuse-address reuse-address
                   :input-timeout input-timeout
                   :output-timeout output-timeout)
  #+cmu
  (let ((fd (ext:create-inet-listener 
             port ':stream 
             :backlog backlog
             :host (or interface 0)
             :reuse-address reuse-address)))
    (make-instance 'passive-socket
      :fd fd
      :element-type 'base-char
      :port port))
  #+digitool-mcl
  (ccl::open-tcp-stream interface port
                        :reuse-local-port-p reuse-address)
  #+ecl
  (let ((passive-socket (make-instance 'sb-bsd-sockets:inet-socket
                          :protocol ':tcp
                          :type ':stream)))
    (when reuse-address
      (setf (sb-bsd-sockets:sockopt-reuse-address passive-socket) 't))
    (sb-bsd-sockets:socket-bind 
     passive-socket
     (if interface
         (sb-bsd-sockets:host-ent-address
          (sb-bsd-sockets:get-host-by-name interface))
         #(0 0 0 0))
     port)
    (sb-bsd-sockets:socket-listen passive-socket backlog)
    passive-socket)
  #+lispworks
  (let ((comm::*use_so_reuseaddr* reuse-address))
    (let ((fd (comm::create-tcp-socket-for-service 
               port 
               :address (or interface 0)
               :backlog backlog)))
      (unless fd
        (error "Local socket address already in use on port ~s."
               port))
      (make-instance 'passive-socket
        :fd fd
        :element-type 'base-char
        :port port)))
  #+sbcl
  (let ((passive-socket (make-instance 'sb-bsd-sockets:inet-socket
                          :protocol ':tcp
                          :type ':stream)))
    (when reuse-address
      (setf (sb-bsd-sockets:sockopt-reuse-address passive-socket) 't))
    (sb-bsd-sockets:socket-bind 
     passive-socket
     (if interface
         (sb-bsd-sockets:host-ent-address
          (sb-bsd-sockets:get-host-by-name interface))
         #(0 0 0 0))
     port)
    (sb-bsd-sockets:socket-listen passive-socket backlog)
    passive-socket)
  #+scl
  (let ((fd (ext:create-inet-listener
             port ':stream 
             :backlog backlog
             :host (or interface 0)
             :reuse-address reuse-address)))
    (make-instance 'passive-socket
      :fd fd
      :element-type 'base-char
      :port port))
  #-(or allegro
        clisp
        clozure
        cmu
        digitool-mcl
        ecl
        lispworks
        sbcl
        scl)
  (need-to-port make-passive-socket))

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

(defun close-passive-socket (passive-socket)
  #+clisp
  (socket:socket-server-close passive-socket)
  #+cmu
  (unix:unix-close (passive-socket.fd passive-socket))
  #+ecl
  (sb-bsd-sockets:socket-close passive-socket)
  #+sbcl
  (sb-bsd-sockets:socket-close passive-socket)
  #+scl
  (unix:unix-close (passive-socket.fd passive-socket))
  #-(or clisp
        cmu
        ecl
        sbcl
        scl)
  (close passive-socket))

;; Close is a method in Lispworks, so we extend it for passive
;; sockets:
#+lispworks
(defmethod close ((passive-socket passive-socket) &key abort)
  (declare (ignore abort))
  (comm::close-socket (passive-socket.fd passive-socket)))

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

(defun shutdown-socket-stream (socket-stream direction)
  ;;; Note: Allegro, CLISP, Clozure, and Digitool-MCL only support :input and
  ;;;       :output direction, so that is all that we document as providing...
  #-(or allegro
        clisp
        clozure
        cmu
        lispworks
        sbcl
        scl)
  (declare (ignore socket-stream direction))
  #+allegro
  (socket:shutdown socket-stream :direction direction)
  #+clisp
  (socket:socket-stream-shutdown socket-stream direction)
  #+clozure
  (ccl:shutdown socket-stream :direction direction)
  #+cmu
  (ext:inet-shutdown (sys:fd-stream-fd socket-stream)
                     (ecase direction
                       (:input ext:shut-rd)
                       (:output ext:shut-wr)
                       #+not-supported
                       (:input-output ext:shut-rdwr)))
  #+lispworks
  (shutdown (comm:socket-stream-socket socket-stream)
            (ecase direction
              (:input 0)
              (:output 1)
              #+not-supported
              (:input-output 2)))
  #+sbcl
  (shutdown (sb-sys::fd-stream-fd socket-stream)
            (ecase direction
              (:input 0)
              (:output 1)
              #+not-supported
              (:input-output 2)))
  #+scl
  (ext:inet-shutdown (sys:fd-stream-fd socket-stream)
                     (ecase direction
                       (:input ext:shut-rd)
                       (:output ext:shut-wr)
                       #+not-supported
                       (:input-output ext:shut-rdwr)))
  #-(or allegro 
        clisp 
        clozure
        cmu
        lispworks
        sbcl
        scl)
  (need-to-port shutdown-socket-stream))
  
;;; ---------------------------------------------------------------------------

(defun accept-connection (passive-socket &key (wait 't))
  #+allegro
  (socket:accept-connection passive-socket :wait wait)
  #+clisp
  (when (cond ((numberp wait)
               (socket:socket-wait passive-socket wait))
              (wait 
               (socket:socket-wait passive-socket))
              (t (socket:socket-wait passive-socket 0)))
    (socket:socket-accept passive-socket :external-format ':unix))
  #+clozure
  (ccl:accept-connection passive-socket :wait wait)
  #+cmu
  (let ((fd (passive-socket.fd passive-socket)))
    (when (sys:wait-until-fd-usable 
           fd ':input
           ;; convert :wait to timeout:
           (cond ((eq wait 't) nil)
                 ((not wait) 0)
                 (t wait)))
      (sys:make-fd-stream
       (ext:accept-tcp-connection fd)
       :input 't
       :output 't
       :element-type (passive-socket.element-type passive-socket)
       :buffering ':full
       :auto-close 't)))
  #+ecl
  (when (progn ; need something like wait-until-fd-usable 
         (sb-bsd-sockets:socket-file-descriptor passive-socket) 
         ':input
         ;; convert :wait to timeout:
         (cond ((eq wait 't) nil)
               ((not wait) 0)
               (t wait)))
    (sb-bsd-sockets:socket-make-stream 
     (sb-bsd-sockets:socket-accept passive-socket)
     :input 't :output 't
     :element-type 'character
     :buffering ':full))
  #+lispworks
  (let ((socket-fd (passive-socket.fd passive-socket)))
    (when (or wait (comm::socket-listen socket-fd))
      (let ((socket (comm::get-fd-from-socket socket-fd)))
        (make-instance 'comm:socket-stream
          :socket socket
          :direction ':io
          :element-type (passive-socket.element-type passive-socket)))))
  #+sbcl
  (when (sb-sys:wait-until-fd-usable 
         (sb-bsd-sockets:socket-file-descriptor passive-socket) 
         ':input
         ;; convert :wait to timeout:
         (cond ((eq wait 't) nil)
               ((not wait) 0)
               (t wait)))
    (sb-bsd-sockets:socket-make-stream 
     (sb-bsd-sockets:socket-accept passive-socket)
     :input 't :output 't
     :element-type 'character
     :buffering ':full))
  #+scl
  (let ((fd (passive-socket.fd passive-socket)))
    (when (sys:wait-until-fd-usable 
           fd ':input
           ;; convert :wait to timeout:
           (cond ((eq wait 't) nil)
                 ((not wait) 0)
                 (t wait)))
      (sys:make-fd-stream
       (ext:accept-tcp-connection fd)
       :input 't
       :output 't
       :element-type (passive-socket.element-type passive-socket)
       :buffering ':full
       :auto-close 't)))
  #-(or allegro 
        clisp
        clozure
        cmu
        ecl 
        lispworks 
        sbcl
        scl)
  (need-to-port accept-connection))

;;; ===========================================================================
;;;  Connection Server
  
(defun start-connection-server (function port 
                                &key (name "Connection Server") 
                                     (backlog 5)
                                     interface
                                     keepalive
                                     reuse-address
                                     input-timeout
                                     output-timeout)
  #+threads-not-available
  (declare (ignore function port name backlog interface reuse-address
                   keepalive input-timout output-timeout))
  #-threads-not-available
  (spawn-thread
   name
   #'(lambda (function port interface backlog reuse-address)
       (let ((passive-socket 
              (make-passive-socket port 
                                   :backlog backlog
                                   :interface interface
                                   :keepalive keepalive
                                   :reuse-address reuse-address
                                   :input-timeout input-timeout
                                   :output-timeout output-timeout)))
         (unwind-protect
             (loop
               (let ((connection (accept-connection passive-socket)))
                 (funcall function connection)))
           (close-passive-socket passive-socket))))
   function port interface backlog reuse-address)
  #+threads-not-available
  (threads-not-available 'start-connection-server))

;;; ===========================================================================
;;;  Socket Attribute Readers

(defun local-hostname-and-port (connection &optional do-not-resolve)
  #-(or allegro
        clisp 
        clozure
        cmu
        lispworks
        sbcl
        scl)
  (declare (ignore connection do-not-resolve))
  #+allegro
  (let* ((ipaddr (socket:local-host connection))
         (dotted (socket:ipaddr-to-dotted ipaddr)))
    (values (if do-not-resolve
                dotted
                (let ((resolved (socket:ipaddr-to-hostname ipaddr)))
                  (if resolved
                      (format nil "~a (~a)" dotted resolved)
                      dotted)))
            (socket:local-port connection)))
  #+clisp
  (socket:socket-stream-local connection (not do-not-resolve))
  #+clozure
  (let* ((ipaddr (ccl:local-host connection))
         (dotted (ccl:ipaddr-to-dotted ipaddr)))
    (values (if do-not-resolve
                dotted
                (let ((resolved 
                       ;; CCL can error here:
                       (ignore-errors (ccl:ipaddr-to-hostname ipaddr))))
                  (if resolved
                      (format nil "~a (~a)" dotted resolved)
                      dotted)))
            (ccl:local-port connection)))
  #+cmu
  (let ((fd (sys:fd-stream-fd connection)))
    (multiple-value-bind (ipaddr port)
        (ext:get-socket-host-and-port fd)
      (let ((dotted (ipaddr-to-dotted ipaddr)))
        (values (if do-not-resolve
                    dotted
                    (let ((resolved (ipaddr-to-hostname ipaddr)))
                      (if resolved
                          (format nil "~a (~a)" dotted resolved)
                          dotted)))
                port))))   
  #+lispworks
  (multiple-value-bind (ipaddr port)
      (comm:socket-stream-address connection)
    (let ((dotted (comm:ip-address-string ipaddr)))
      (values (if do-not-resolve
                  dotted
                  (let ((resolved (comm::get-host-entry ipaddr
                                                        :fields '(:name))))
                    (if resolved
                        (format nil "~a (~a)" dotted resolved)
                        dotted)))
            port)))
  #+sbcl
  (let ((socket (sb-impl::fd-stream-name connection)))
    (multiple-value-bind (ipvector port)
        (sb-bsd-sockets:socket-name socket)
      (let ((dotted (ipvector-to-dotted ipvector)))
        (values (if do-not-resolve
                    dotted
                    (let ((resolved (ipvector-to-hostname ipvector)))
                      (if resolved
                          (format nil "~a (~a)" dotted resolved)
                          dotted)))
                port))))        
  #+scl
  (let ((fd (sys:fd-stream-fd connection)))
    (multiple-value-bind (ipaddr port)
        (ext:get-socket-host-and-port fd)
      (let ((dotted (ipaddr-to-dotted ipaddr)))
        (values (if do-not-resolve
                    dotted
                    (let ((resolved (ipaddr-to-hostname ipaddr)))
                      (if resolved
                          (format nil "~a (~a)" dotted resolved)
                          dotted)))
                port))))   
  #-(or allegro
        clisp 
        clozure
        cmu
        lispworks
        sbcl
        scl)
  (need-to-port local-hostname-and-port))

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

(defun remote-hostname-and-port (connection &optional do-not-resolve)
  #-(or allegro
        clisp
        clozure
        cmu
        lispworks
        sbcl
        scl)
  (declare (ignore connection do-not-resolve))
  #+allegro
  (let* ((ipaddr (socket:remote-host connection))
         (dotted (socket:ipaddr-to-dotted ipaddr)))
    (values (if do-not-resolve
                dotted
                (let ((resolved (socket:ipaddr-to-hostname ipaddr)))
                  (if resolved
                      (format nil "~a (~a)" dotted resolved)
                      dotted)))
            (socket:remote-port connection)))
  #+clisp
  (socket:socket-stream-peer connection (not do-not-resolve))
  #+clozure
  (let* ((ipaddr (ccl:remote-host connection))
         (dotted (ccl:ipaddr-to-dotted ipaddr)))
    (values (if do-not-resolve
                dotted
                (let ((resolved
                       ;; CCL can error here:
                       (ignore-errors (ccl:ipaddr-to-hostname ipaddr))))
                  (if resolved
                      (format nil "~a (~a)" dotted resolved)
                      dotted)))
            (ccl:remote-port connection)))
  #+cmu
  (let ((fd (sys:fd-stream-fd connection)))
    (multiple-value-bind (ipaddr port)
        (ext:get-peer-host-and-port fd)
      (let ((dotted (ipaddr-to-dotted ipaddr)))
        (values (if do-not-resolve
                    dotted
                    (let ((resolved (ipaddr-to-hostname ipaddr)))
                      (if resolved
                          (format nil "~a (~a)" dotted resolved)
                          dotted)))
                port))))   
  #+lispworks
  (multiple-value-bind (ipaddr port)
      (comm:socket-stream-peer-address connection)
    (let ((dotted (comm:ip-address-string ipaddr)))
      (values (if do-not-resolve
                  dotted
                  (let ((resolved (comm::get-host-entry ipaddr
                                                        :fields '(:name))))
                    (if resolved
                        (format nil "~a (~a)" dotted resolved)
                        dotted)))
            port)))
  #+sbcl
  (let ((socket (sb-impl::fd-stream-name connection)))
    (multiple-value-bind (ipvector port)
        (sb-bsd-sockets:socket-peername socket)
      (let ((dotted (ipvector-to-dotted ipvector)))
        (values (if do-not-resolve
                    dotted
                    (let ((resolved (ipvector-to-hostname ipvector)))
                      (if resolved
                          (format nil "~a (~a)" dotted resolved)
                          dotted)))
                port))))        
  #+scl
  (let ((fd (sys:fd-stream-fd connection)))
    (multiple-value-bind (ipaddr port)
        (ext:get-peer-host-and-port fd)
      (let ((dotted (ipaddr-to-dotted ipaddr)))
        (values (if do-not-resolve
                    dotted
                    (let ((resolved (ipaddr-to-hostname ipaddr)))
                      (if resolved
                          (format nil "~a (~a)" dotted resolved)
                          dotted)))
                port))))   
  #-(or allegro
        clisp
        clozure
        cmu 
        lispworks
        sbcl
        scl)
  (need-to-port remote-hostname-and-port))

;;; ===========================================================================
;;;  Useful for HTTP line termination:

(defun write-crlf (&optional (stream *standard-output*))
  ;; HTTP requires CR/LF line termination: 
  (write-char #\return stream)
  (write-char #\linefeed stream))

;;; ===========================================================================
;;;  Portable sockets interface is fully loaded:

(pushnew ':portable-sockets *features*)
(pushnew *portable-sockets-version-keyword* *features*)

;;; ===========================================================================
;;;                               End of File
;;; ===========================================================================

#+END_SRC

** [[/Users/Can/Develop/Lisp/others/lib/on-lisp.lisp][on-lisp]]
#+BEGIN_SRC lisp 
; The code in this file was mechanically extracted from the TeX
; source files of _On Lisp_.  Some operators are multiply defined,
; as they were in the book.  Usually this means just that you get
; an upwardly compatible version 2 of whatever it is.  Note, though,
; that if you load this whole file you get:
;  1. the cltl1 versions of alrec and atrec.
;  2. varsym? defined as needed by the Prolog compiler.  So if you
;     want to use e.g. match with variables that begin with question
;     marks, comment out the final definition of varsym?

; If you have questions or comments about this code, or you want
; something I didn't include, send mail to lispcode@paulgraham.com

;; (proclaim '(inline last1 single append1 conc1 mklist))
;; (proclaim '(optimize speed))

(defun last1 (lst)
  (car (last lst)))

(defun single (lst)
  (and (consp lst) (not (cdr lst))))

(defun append1 (lst obj) 
  (append lst (list obj)))

(defun conc1 (lst obj)   
  (nconc lst (list obj)))

(defun mklist (obj)
  (if (listp obj) obj (list obj)))

(defun longer (x y)
  (labels ((compare (x y)
             (and (consp x) 
                  (or (null y)
                      (compare (cdr x) (cdr y))))))
    (if (and (listp x) (listp y))
        (compare x y)
        (> (length x) (length y)))))
 
(defun filter (fn lst)
  (let ((acc nil))
    (dolist (x lst)
      (let ((val (funcall fn x)))
        (if val (push val acc))))
    (nreverse acc)))

(defun group (source n)
  (if (zerop n) (error "zero length"))
  (labels ((rec (source acc)
             (let ((rest (nthcdr n source)))
               (if (consp rest)
                   (rec rest (cons (subseq source 0 n) acc))
                   (nreverse (cons source acc))))))
    (if source (rec source nil) nil)))

(defun flatten (x)
  (labels ((rec (x acc)
             (cond ((null x) acc)
                   ((atom x) (cons x acc))
                   (t (rec (car x) (rec (cdr x) acc))))))
    (rec x nil))) 

(defun prune (test tree)
  (labels ((rec (tree acc)
             (cond ((null tree) (nreverse acc))
                   ((consp (car tree))
                    (rec (cdr tree) 
                         (cons (rec (car tree) nil) acc)))
                   (t (rec (cdr tree)
                           (if (funcall test (car tree))
                               acc
                               (cons (car tree) acc)))))))
    (rec tree nil)))

(defun find2 (fn lst)
  (if (null lst)
      nil
      (let ((val (funcall fn (car lst))))
        (if val
            (values (car lst) val)
            (find2 fn (cdr lst))))))

(defun before (x y lst &key (test #'eql))
  (and lst
       (let ((first (car lst)))
         (cond ((funcall test y first) nil)
               ((funcall test x first) lst)
               (t (before x y (cdr lst) :test test))))))

(defun after (x y lst &key (test #'eql))
  (let ((rest (before y x lst :test test)))
    (and rest (member x rest :test test))))

(defun duplicate (obj lst &key (test #'eql))
  (member obj (cdr (member obj lst :test test)) 
          :test test))

(defun split-if (fn lst)
  (let ((acc nil))
    (do ((src lst (cdr src)))
        ((or (null src) (funcall fn (car src)))
         (values (nreverse acc) src))
      (push (car src) acc))))

(defun most (fn lst)
  (if (null lst)
      (values nil nil)
      (let* ((wins (car lst))
             (max (funcall fn wins)))
        (dolist (obj (cdr lst))
          (let ((score (funcall fn obj)))
            (when (> score max)
              (setq wins obj
                    max  score))))
        (values wins max))))

(defun best (fn lst)
  (if (null lst)
      nil
      (let ((wins (car lst)))
        (dolist (obj (cdr lst))
          (if (funcall fn obj wins)
              (setq wins obj)))
        wins)))

(defun mostn (fn lst)
  (if (null lst)
      (values nil nil)
      (let ((result (list (car lst)))
            (max (funcall fn (car lst))))
        (dolist (obj (cdr lst))
          (let ((score (funcall fn obj)))
            (cond ((> score max)
                   (setq max    score
                         result (list obj)))
                  ((= score max)
                   (push obj result)))))
        (values (nreverse result) max))))

(defun map0-n (fn n)
  (mapa-b fn 0 n))

(defun map1-n (fn n)
  (mapa-b fn 1 n))

(defun mapa-b (fn a b &optional (step 1))
  (do ((i a (+ i step))
       (result nil))
      ((> i b) (nreverse result))
    (push (funcall fn i) result)))

(defun map-> (fn start test-fn succ-fn)
  (do ((i start (funcall succ-fn i))
       (result nil))
      ((funcall test-fn i) (nreverse result))
    (push (funcall fn i) result)))

(defun mappend (fn &rest lsts)
  (apply #'append (apply #'mapcar fn lsts)))

(defun mapcars (fn &rest lsts)
  (let ((result nil))
    (dolist (lst lsts)
      (dolist (obj lst)
        (push (funcall fn obj) result)))
    (nreverse result)))

(defun rmapcar (fn &rest args)
  (if (some #'atom args)
      (apply fn args)
      (apply #'mapcar 
             #'(lambda (&rest args) 
                 (apply #'rmapcar fn args))
             args)))

(defun readlist (&rest args)
  (values (read-from-string
            (concatenate 'string "("
                                 (apply #'read-line args)
                                 ")"))))

(defun prompt (&rest args)
  (apply #'format *query-io* args)
  (read *query-io*))

(defun break-loop (fn quit &rest args)
  (format *query-io* "Entering break-loop.~%")
  (loop
    (let ((in (apply #'prompt args)))
      (if (funcall quit in)
          (return)
          (format *query-io* "~A~%" (funcall fn in))))))

(defun mkstr (&rest args)
  (with-output-to-string (s)
    (dolist (a args) (princ a s))))

(defun symb (&rest args)
  (values (intern (apply #'mkstr args))))

(defun reread (&rest args)
  (values (read-from-string (apply #'mkstr args))))

(defun explode (sym)
  (map 'list #'(lambda (c)
                 (intern (make-string 1 
                                      :initial-element c)))
             (symbol-name sym)))

(defvar *!equivs* (make-hash-table))

(defun ! (fn)
  (or (gethash fn *!equivs*) fn))

(defun def! (fn fn!)
  (setf (gethash fn *!equivs*) fn!))

(defun memoize (fn)
  (let ((cache (make-hash-table :test #'equal)))
    #'(lambda (&rest args)
        (multiple-value-bind (val win) (gethash args cache)
          (if win
              val
              (setf (gethash args cache) 
                    (apply fn args)))))))

(defun compose (&rest fns)
  (if fns
      (let ((fn1 (car (last fns)))
            (fns (butlast fns)))
        #'(lambda (&rest args)
            (reduce #'funcall fns 
                    :from-end t
                    :initial-value (apply fn1 args))))
      #'identity))

(defun fif (if then &optional else)
  #'(lambda (x)
      (if (funcall if x)
          (funcall then x)
          (if else (funcall else x)))))

(defun fint (fn &rest fns)
  (if (null fns)
      fn
      (let ((chain (apply #'fint fns)))
        #'(lambda (x) 
            (and (funcall fn x) (funcall chain x))))))

(defun fun (fn &rest fns)
  (if (null fns)
      fn
      (let ((chain (apply #'fun fns)))
        #'(lambda (x)
            (or (funcall fn x) (funcall chain x))))))

(defun lrec (rec &optional base)
  (labels ((self (lst)
             (if (null lst)
                 (if (functionp base)
                     (funcall base)
                     base)
                 (funcall rec (car lst)
                              #'(lambda () 
                                  (self (cdr lst)))))))
    #'self))

(defun rfind-if (fn tree)
  (if (atom tree)
      (and (funcall fn tree) tree)
      (or (rfind-if fn (car tree))
          (if (cdr tree) (rfind-if fn (cdr tree))))))

(defun ttrav (rec &optional (base #'identity))
  (labels ((self (tree)
             (if (atom tree)
                 (if (functionp base)
                     (funcall base tree)
                     base)
                 (funcall rec (self (car tree))
                              (if (cdr tree) 
                                  (self (cdr tree)))))))
    #'self))

(defun trec (rec &optional (base #'identity))
  (labels 
    ((self (tree)
       (if (atom tree)
           (if (functionp base)
               (funcall base tree)
               base)
           (funcall rec tree 
                        #'(lambda () 
                            (self (car tree)))
                        #'(lambda () 
                            (if (cdr tree)
                                (self (cdr tree))))))))
    #'self))

(defmacro mac (expr) 
  `(pprint (macroexpand-1 ',expr)))

(defmacro when-bind ((var expr) &body body)
  `(let ((,var ,expr))
     (when ,var
       ,@body)))

(defmacro when-bind* (binds &body body)
  (if (null binds)
      `(progn ,@body)
      `(let (,(car binds))
         (if ,(caar binds)
             (when-bind* ,(cdr binds) ,@body)))))

(defmacro with-gensyms (syms &body body)
  `(let ,(mapcar #'(lambda (s)
                     `(,s (gensym)))
                 syms)
     ,@body))

(defmacro condlet (clauses &body body)
  (let ((bodfn (gensym))
        (vars (mapcar #'(lambda (v) (cons v (gensym)))
                      (remove-duplicates
                        (mapcar #'car 
                                (mappend #'cdr clauses))))))
    `(labels ((,bodfn ,(mapcar #'car vars)
                 ,@body))
       (cond ,@(mapcar #'(lambda (cl)
                           (condlet-clause vars cl bodfn))
                       clauses)))))

(defun condlet-clause (vars cl bodfn)
  `(,(car cl) (let ,(mapcar #'cdr vars)
                (let ,(condlet-binds vars cl)
                  (,bodfn ,@(mapcar #'cdr vars))))))


(defun condlet-binds (vars cl)
  (mapcar #'(lambda (bindform)
              (if (consp bindform)
                  (cons (cdr (assoc (car bindform) vars))
                        (cdr bindform))))
          (cdr cl)))

(defmacro if3 (test t-case nil-case ?-case)
  `(case ,test
     ((nil) ,nil-case)
     (?     ,?-case)
     (t     ,t-case)))

(defmacro nif (expr pos zero neg)
  (let ((g (gensym)))
    `(let ((,g ,expr))
       (cond ((plusp ,g) ,pos)
             ((zerop ,g) ,zero)
             (t ,neg)))))

(defmacro in (obj &rest choices)
  (let ((insym (gensym)))
    `(let ((,insym ,obj))
       (or ,@(mapcar #'(lambda (c) `(eql ,insym ,c))
                     choices)))))

(defmacro inq (obj &rest args)
  `(in ,obj ,@(mapcar #'(lambda (a)
                          `',a)
                      args)))

(defmacro in-if (fn &rest choices)
  (let ((fnsym (gensym)))
    `(let ((,fnsym ,fn))
       (or ,@(mapcar #'(lambda (c)
                         `(funcall ,fnsym ,c))
                     choices)))))

(defmacro >case (expr &rest clauses)
  (let ((g (gensym)))
    `(let ((,g ,expr))
       (cond ,@(mapcar #'(lambda (cl) (>casex g cl))
                       clauses)))))

(defun >casex (g cl)
  (let ((key (car cl)) (rest (cdr cl)))
    (cond ((consp key) `((in ,g ,@key) ,@rest))
          ((inq key t otherwise) `(t ,@rest))
          (t (error "bad >case clause")))))

(defmacro while (test &body body)
  `(do ()
       ((not ,test))
     ,@body))

(defmacro till (test &body body)
  `(do ()
       (,test)
     ,@body))

(defmacro for ((var start stop) &body body)
  (let ((gstop (gensym)))
    `(do ((,var ,start (1+ ,var))
          (,gstop ,stop))
         ((> ,var ,gstop))
       ,@body)))

(defmacro do-tuples/o (parms source &body body)
  (if parms
      (let ((src (gensym)))
        `(prog ((,src ,source))
           (mapc #'(lambda ,parms ,@body)
                 ,@(map0-n #'(lambda (n)
                               `(nthcdr ,n ,src))
                           (1- (length parms))))))))

(defmacro do-tuples/c (parms source &body body)
  (if parms
      (with-gensyms (src rest bodfn)
        (let ((len (length parms)))
          `(let ((,src ,source))
             (when (nthcdr ,(1- len) ,src)
               (labels ((,bodfn ,parms ,@body))
                 (do ((,rest ,src (cdr ,rest)))
                     ((not (nthcdr ,(1- len) ,rest))
                      ,@(mapcar #'(lambda (args)
                                    `(,bodfn ,@args))
                                (dt-args len rest src))
                      nil)
                   (,bodfn ,@(map1-n #'(lambda (n)
                                         `(nth ,(1- n) 
                                               ,rest))
                                     len))))))))))
 
(defun dt-args (len rest src)
  (map0-n #'(lambda (m)
              (map1-n #'(lambda (n) 
                          (let ((x (+ m n)))
                            (if (>= x len)
                                `(nth ,(- x len) ,src)
                                `(nth ,(1- x) ,rest))))
                      len))
          (- len 2)))

(defmacro mvdo* (parm-cl test-cl &body body)
  (mvdo-gen parm-cl parm-cl test-cl body))

(defun mvdo-gen (binds rebinds test body)
  (if (null binds)
      (let ((label (gensym)))
        `(prog nil
           ,label
           (if ,(car test)
               (return (progn ,@(cdr test))))
           ,@body
           ,@(mvdo-rebind-gen rebinds)
           (go ,label)))
      (let ((rec (mvdo-gen (cdr binds) rebinds test body)))
        (let ((var/s (caar binds)) (expr (cadar binds)))
          (if (atom var/s)
              `(let ((,var/s ,expr)) ,rec)
              `(multiple-value-bind ,var/s ,expr ,rec))))))

(defun mvdo-rebind-gen (rebinds)
  (cond ((null rebinds) nil)
        ((< (length (car rebinds)) 3)
         (mvdo-rebind-gen (cdr rebinds)))
        (t
         (cons (list (if (atom (caar rebinds))
                         'setq
                         'multiple-value-setq)
                     (caar rebinds)
                     (third (car rebinds)))
               (mvdo-rebind-gen (cdr rebinds))))))

(defmacro mvpsetq (&rest args)
  (let* ((pairs (group args 2))
         (syms  (mapcar #'(lambda (p)
                            (mapcar #'(lambda (x) (gensym))
                                    (mklist (car p))))
                        pairs)))
    (labels ((rec (ps ss)
               (if (null ps)
                   `(setq
                     ,@(mapcan #'(lambda (p s)
                                   (shuffle (mklist (car p)) 
                                            s))
                               pairs syms))
                   (let ((body (rec (cdr ps) (cdr ss))))
                     (let ((var/s (caar ps))
                           (expr (cadar ps)))
                       (if (consp var/s)
                           `(multiple-value-bind ,(car ss) 
                                                 ,expr
                              ,body)
                           `(let ((,@(car ss) ,expr))
                              ,body)))))))
      (rec pairs syms))))

(defun shuffle (x y)
  (cond ((null x) y)
        ((null y) x)
        (t (list* (car x) (car y) 
                  (shuffle (cdr x) (cdr y))))))

(defmacro mvdo (binds (test &rest result) &body body)
  (let ((label (gensym))
        (temps (mapcar #'(lambda (b)
                           (if (listp (car b))
                               (mapcar #'(lambda (x) 
                                           (gensym))
                                       (car b))
                               (gensym)))
                       binds)))
    `(let ,(mappend #'mklist temps)
       (mvpsetq ,@(mapcan #'(lambda (b var)
                              (list var (cadr b)))
                          binds
                          temps))
       (prog ,(mapcar #'(lambda (b var) (list b var))
                     (mappend #'mklist (mapcar #'car binds))
                     (mappend #'mklist temps))
         ,label 
         (if ,test
             (return (progn ,@result)))
         ,@body
         (mvpsetq ,@(mapcan #'(lambda (b)
                                (if (third b)
                                    (list (car b) 
                                          (third b))))
                            binds))
         (go ,label)))))

(defmacro allf (val &rest args)
  (with-gensyms (gval)
    `(let ((,gval ,val))
       (setf ,@(mapcan #'(lambda (a) (list a gval))
                       args)))))

(defmacro nilf (&rest args) `(allf nil ,@args))

(defmacro tf (&rest args) `(allf t ,@args))

(defmacro toggle (&rest args)
  `(progn
     ,@(mapcar #'(lambda (a) `(toggle2 ,a))
               args)))

(define-modify-macro toggle2 () not)

(define-modify-macro concf (obj) nconc)

(define-modify-macro conc1f (obj) 
  (lambda (place obj)
    (nconc place (list obj))))

(define-modify-macro concnew (obj &rest args)
  (lambda (place obj &rest args)
    (unless (apply #'member obj place args)
      (nconc place (list obj)))))

(defmacro _f (op place &rest args)
  (multiple-value-bind (vars forms var set access) 
                       (get-setf-method place)
    `(let* (,@(mapcar #'list vars forms)
            (,(car var) (,op ,access ,@args)))
       ,set)))

(defmacro pull (obj place &rest args)
  (multiple-value-bind (vars forms var set access)
                       (get-setf-method place)
    (let ((g (gensym)))
      `(let* ((,g ,obj)
              ,@(mapcar #'list vars forms)
              (,(car var) (delete ,g ,access ,@args)))
         ,set))))

(defmacro pull-if (test place &rest args) 
  (multiple-value-bind (vars forms var set access) 
                       (get-setf-method place) 
    (let ((g (gensym))) 
      `(let* ((,g ,test) 
              ,@(mapcar #'list vars forms) 
              (,(car var) (delete-if ,g ,access ,@args))) 
         ,set)))) 

(defmacro popn (n place) 
  (multiple-value-bind (vars forms var set access) 
                       (get-setf-method place) 
    (with-gensyms (gn glst)
      `(let* ((,gn ,n)
              ,@(mapcar #'list vars forms)
              (,glst ,access)
              (,(car var) (nthcdr ,gn ,glst)))
         (prog1 (subseq ,glst 0 ,gn)
                ,set)))))

(defmacro sortf (op &rest places)
  (let* ((meths (mapcar #'(lambda (p)
                            (multiple-value-list 
                              (get-setf-method p)))
                        places))
         (temps (apply #'append (mapcar #'third meths))))
    `(let* ,(mapcar #'list
                    (mapcan #'(lambda (m)
                                (append (first m) 
                                        (third m)))
                            meths)
                    (mapcan #'(lambda (m)
                                (append (second m) 
                                        (list (fifth m))))
                            meths))
       ,@(mapcon #'(lambda (rest)
                     (mapcar 
                       #'(lambda (arg)
                           `(unless (,op ,(car rest) ,arg)
                              (rotatef ,(car rest) ,arg)))
                       (cdr rest)))
                 temps)
       ,@(mapcar #'fourth meths))))

(defmacro aif (test-form then-form &optional else-form)
  `(let ((it ,test-form))
     (if it ,then-form ,else-form)))

(defmacro awhen (test-form &body body)
  `(aif ,test-form
        (progn ,@body)))

(defmacro awhile (expr &body body)
  `(do ((it ,expr ,expr))
       ((not it))
     ,@body))

(defmacro aand (&rest args)
  (cond ((null args) t)
        ((null (cdr args)) (car args))
        (t `(aif ,(car args) (aand ,@(cdr args))))))

(defmacro acond (&rest clauses)
  (if (null clauses)
      nil
      (let ((cl1 (car clauses))
            (sym (gensym)))
        `(let ((,sym ,(car cl1)))
           (if ,sym
               (let ((it ,sym)) ,@(cdr cl1))
               (acond ,@(cdr clauses)))))))

(defmacro alambda (parms &body body)
  `(labels ((self ,parms ,@body))
     #'self))

(defmacro ablock (tag &rest args)
  `(block ,tag
     ,(funcall (alambda (args)
                 (case (length args)
                   (0 nil)
                   (1 (car args))
                   (t `(let ((it ,(car args)))
                         ,(self (cdr args))))))
               args)))

(defmacro aif2 (test &optional then else)
  (let ((win (gensym)))
    `(multiple-value-bind (it ,win) ,test
       (if (or it ,win) ,then ,else))))

(defmacro awhen2 (test &body body)
  `(aif2 ,test
         (progn ,@body)))

(defmacro awhile2 (test &body body)
  (let ((flag (gensym)))
    `(let ((,flag t))
       (while ,flag
         (aif2 ,test
               (progn ,@body)
               (setq ,flag nil))))))

(defmacro acond2 (&rest clauses)
  (if (null clauses)
      nil
      (let ((cl1 (car clauses))
            (val (gensym))
            (win (gensym)))
        `(multiple-value-bind (,val ,win) ,(car cl1)
           (if (or ,val ,win)
               (let ((it ,val)) ,@(cdr cl1))
               (acond2 ,@(cdr clauses)))))))

(let ((g (gensym)))
  (defun read2 (&optional (str *standard-input*))
    (let ((val (read str nil g)))
      (unless (equal val g) (values val t)))))

(defmacro do-file (filename &body body)
  (let ((str (gensym)))
    `(with-open-file (,str ,filename)
       (awhile2 (read2 ,str)
         ,@body))))

(defmacro fn (expr) `#',(rbuild expr))
 
(defun rbuild (expr)
  (if (or (atom expr) (eq (car expr) 'lambda))
      expr
      (if (eq (car expr) 'compose)
          (build-compose (cdr expr))
          (build-call (car expr) (cdr expr)))))

(defun build-call (op fns)
  (let ((g (gensym)))
    `(lambda (,g)
       (,op ,@(mapcar #'(lambda (f)
                          `(,(rbuild f) ,g))
                      fns)))))

(defun build-compose (fns)
  (let ((g (gensym)))
    `(lambda (,g)
       ,(labels ((rec (fns)
                   (if fns
                       `(,(rbuild (car fns)) 
                         ,(rec (cdr fns)))
                       g)))
          (rec fns)))))

(defmacro alrec (rec &optional base)
  "cltl2 version"
  (let ((gfn (gensym)))
    `(lrec #'(lambda (it ,gfn) 
               (symbol-macrolet ((rec (funcall ,gfn)))
                 ,rec))
           ,base)))

(defmacro alrec (rec &optional base)
  "cltl1 version"
  (let ((gfn (gensym)))
    `(lrec #'(lambda (it ,gfn)
               (labels ((rec () (funcall ,gfn)))
                 ,rec))
           ,base)))

(defmacro on-cdrs (rec base &rest lsts)
  `(funcall (alrec ,rec #'(lambda () ,base)) ,@lsts))

(defun unions (&rest sets)
  (on-cdrs (union it rec) (car sets) (cdr sets)))

(defun intersections (&rest sets)
  (unless (some #'null sets)
    (on-cdrs (intersection it rec) (car sets) (cdr sets))))

(defun differences (set &rest outs)
  (on-cdrs (set-difference rec it) set outs))

(defun maxmin (args)
  (when args
    (on-cdrs (multiple-value-bind (mx mn) rec
               (values (max mx it) (min mn it)))
             (values (car args) (car args))
             (cdr args))))

(defmacro atrec (rec &optional (base 'it))
  "cltl2 version"
  (let ((lfn (gensym)) (rfn (gensym)))
    `(trec #'(lambda (it ,lfn ,rfn)
               (symbol-macrolet ((left (funcall ,lfn))
                                 (right (funcall ,rfn)))
                 ,rec))
           #'(lambda (it) ,base))))

(defmacro atrec (rec &optional (base 'it))
  "cltl1 version"
  (let ((lfn (gensym)) (rfn (gensym)))
    `(trec #'(lambda (it ,lfn ,rfn)
               (labels ((left () (funcall ,lfn))
                        (right () (funcall ,rfn)))
                 ,rec))
           #'(lambda (it) ,base))))

(defmacro on-trees (rec base &rest trees)
  `(funcall (atrec ,rec ,base) ,@trees))

(defconstant unforced (gensym))

(defstruct delay  forced closure)

(defmacro delay (expr)
  (let ((self (gensym)))
    `(let ((,self (make-delay :forced unforced)))
       (setf (delay-closure ,self)
             #'(lambda ()
                 (setf (delay-forced ,self) ,expr)))
       ,self)))

(defun force (x)
  (if (delay-p x)
      (if (eq (delay-forced x) unforced)
          (funcall (delay-closure x))
          (delay-forced x))
      x))

(defmacro abbrev (short long)
  `(defmacro ,short (&rest args)
     `(,',long ,@args)))

(defmacro abbrevs (&rest names)
  `(progn
     ,@(mapcar #'(lambda (pair)
                   `(abbrev ,@pair))
               (group names 2))))

(defmacro propmacro (propname)
  `(defmacro ,propname (obj)
     `(get ,obj ',',propname)))

(defmacro propmacros (&rest props)
  `(progn
     ,@(mapcar #'(lambda (p) `(propmacro ,p))
               props)))

(defmacro defanaph (name &optional calls)
   (let ((calls (or calls (pop-symbol name))))
    `(defmacro ,name (&rest args)
       (anaphex args (list ',calls)))))

(defun anaphex (args expr)
  (if args
      (let ((sym (gensym)))
        `(let* ((,sym ,(car args))
                (it ,sym))
           ,(anaphex (cdr args)
                     (append expr (list sym)))))
      expr))

(defun pop-symbol (sym)
  (intern (subseq (symbol-name sym) 1)))

(defmacro defanaph (name &optional &key calls (rule :all))
  (let* ((opname (or calls (pop-symbol name)))
         (body (case rule
                 (:all   `(anaphex1 args '(,opname)))
                 (:first `(anaphex2 ',opname args))
                 (:place `(anaphex3 ',opname args)))))
    `(defmacro ,name (&rest args)
       ,body)))

(defun anaphex1 (args call)
  (if args
      (let ((sym (gensym)))
        `(let* ((,sym ,(car args))
                (it ,sym))
           ,(anaphex1 (cdr args)
                      (append call (list sym)))))
      call))

(defun anaphex2 (op args)
  `(let ((it ,(car args))) (,op it ,@(cdr args))))

(defun anaphex3 (op args)
  `(_f (lambda (it) (,op it ,@(cdr args))) ,(car args)))

(defmacro defdelim (left right parms &body body)
  `(ddfn ,left ,right #'(lambda ,parms ,@body)))

(let ((rpar (get-macro-character #\) )))
  (defun ddfn (left right fn)
    (set-macro-character right rpar)
    (set-dispatch-macro-character #\# left
      #'(lambda (stream char1 char2)
          (apply fn 
                 (read-delimited-list right stream t))))))

(defmacro dbind (pat seq &body body)
  (let ((gseq (gensym)))
    `(let ((,gseq ,seq))
       ,(dbind-ex (destruc pat gseq #'atom) body))))

(defun destruc (pat seq &optional (atom? #'atom) (n 0))
  (if (null pat)
      nil
      (let ((rest (cond ((funcall atom? pat) pat)
                        ((eq (car pat) '&rest) (cadr pat))
                        ((eq (car pat) '&body) (cadr pat))
                        (t nil))))
       (if rest
           `((,rest (subseq ,seq ,n)))
           (let ((p (car pat))
                 (rec (destruc (cdr pat) seq atom? (1+ n))))
             (if (funcall atom? p)
                 (cons `(,p (elt ,seq ,n))
                       rec)
                 (let ((var (gensym)))
                   (cons (cons `(,var (elt ,seq ,n))
                               (destruc p var atom?))
                         rec))))))))

(defun dbind-ex (binds body)
  (if (null binds)
      `(progn ,@body)
      `(let ,(mapcar #'(lambda (b)
                         (if (consp (car b))
                             (car b)
                             b))
                     binds)
        ,(dbind-ex (mapcan #'(lambda (b)
                               (if (consp (car b))
                                   (cdr b)))
                           binds)
                   body))))

(defmacro with-matrix (pats ar &body body)
  (let ((gar (gensym)))
    `(let ((,gar ,ar))
       (let ,(let ((row -1))
               (mapcan 
                 #'(lambda (pat)
                     (incf row)
                     (setq col -1)
                     (mapcar #'(lambda (p)
                                 `(,p (aref ,gar 
                                            ,row 
                                            ,(incf col))))
                              pat))
                 pats))
         ,@body))))

(defmacro with-array (pat ar &body body)
  (let ((gar (gensym)))
    `(let ((,gar ,ar))
       (let ,(mapcar #'(lambda (p)
                         `(,(car p) (aref ,gar ,@(cdr p))))
                     pat)
         ,@body))))

(defmacro with-struct ((name . fields) struct &body body)
  (let ((gs (gensym)))
    `(let ((,gs ,struct))
       (let ,(mapcar #'(lambda (f)
                         `(,f (,(symb name f) ,gs)))
                     fields)
         ,@body))))

(defmacro with-places (pat seq &body body)
  (let ((gseq (gensym)))
    `(let ((,gseq ,seq))
       ,(wplac-ex (destruc pat gseq #'atom) body))))

(defun wplac-ex (binds body)
  (if (null binds)
      `(progn ,@body)
      `(symbol-macrolet ,(mapcar #'(lambda (b)
                                     (if (consp (car b))
                                         (car b)
                                         b))
                                 binds)
        ,(wplac-ex (mapcan #'(lambda (b)
                               (if (consp (car b))
                                   (cdr b)))
                           binds)
                   body))))

(defun match (x y &optional binds)
  (acond2
    ((or (eql x y) (eql x '_) (eql y '_)) (values binds t))
    ((binding x binds) (match it y binds))
    ((binding y binds) (match x it binds))
    ((varsym? x) (values (cons (cons x y) binds) t))
    ((varsym? y) (values (cons (cons y x) binds) t))
    ((and (consp x) (consp y) (match (car x) (car y) binds))
     (match (cdr x) (cdr y) it))
    (t (values nil nil))))

(defun varsym? (x)
  (and (symbolp x) (eq (char (symbol-name x) 0) #\?)))

(defun binding (x binds)
  (labels ((recbind (x binds)
             (aif (assoc x binds)
                  (or (recbind (cdr it) binds)
                      it))))
    (let ((b (recbind x binds)))
      (values (cdr b) b))))

(defmacro if-match (pat seq then &optional else)
  `(aif2 (match ',pat ,seq)
         (let ,(mapcar #'(lambda (v)
                           `(,v (binding ',v it)))
                       (vars-in then #'atom))
           ,then)
         ,else))

(defun vars-in (expr &optional (atom? #'atom))
  (if (funcall atom? expr)
      (if (var? expr) (list expr))
      (union (vars-in (car expr) atom?)
             (vars-in (cdr expr) atom?))))

(defun var? (x)
  (and (symbolp x) (eq (char (symbol-name x) 0) #\?)))

(defun abab (seq)
  (if-match (?x ?y ?x ?y) seq
      (values ?x ?y)
      nil))

(defmacro if-match (pat seq then &optional else)
  `(let ,(mapcar #'(lambda (v) `(,v ',(gensym)))
                 (vars-in pat #'simple?))
     (pat-match ,pat ,seq ,then ,else)))

(defmacro pat-match (pat seq then else)
  (if (simple? pat)
      (match1 `((,pat ,seq)) then else)
      (with-gensyms (gseq gelse)
        `(labels ((,gelse () ,else))
           ,(gen-match (cons (list gseq seq) 
                             (destruc pat gseq #'simple?))
                       then 
                       `(,gelse))))))

(defun simple? (x) (or (atom x) (eq (car x) 'quote)))

(defun gen-match (refs then else)
  (if (null refs)
      then
      (let ((then (gen-match (cdr refs) then else)))
        (if (simple? (caar refs))
            (match1 refs then else)
            (gen-match (car refs) then else)))))

(defun match1 (refs then else)
  (dbind ((pat expr) . rest) refs
    (cond ((gensym? pat)
           `(let ((,pat ,expr))
              (if (and (typep ,pat 'sequence)
                       ,(length-test pat rest))
                  ,then
                  ,else)))
          ((eq pat '_) then)
          ((var? pat)
           (let ((ge (gensym)))
             `(let ((,ge ,expr))
                (if (or (gensym? ,pat) (equal ,pat ,ge))
                    (let ((,pat ,ge)) ,then)
                    ,else))))
          (t `(if (equal ,pat ,expr) ,then ,else)))))

(defun gensym? (s) 
  (and (symbolp s) (not (symbol-package s))))

(defun length-test (pat rest)
  (let ((fin (caadar (last rest))))
    (if (or (consp fin) (eq fin 'elt))
        `(= (length ,pat) ,(length rest))
        `(> (length ,pat) ,(- (length rest) 2)))))

(defun make-db (&optional (size 100))
  (make-hash-table :size size))

(defvar *default-db* (make-db))

(defun clear-db (&optional (db *default-db*))
  (clrhash db))

(defmacro db-query (key &optional (db '*default-db*))
  `(gethash ,key ,db))
  
(defun db-push (key val &optional (db *default-db*))
  (push val (db-query key db)))

(defmacro fact (pred &rest args)
  `(progn (db-push ',pred ',args)
          ',args))

(defmacro with-answer (query &body body)
  (let ((binds (gensym)))
    `(dolist (,binds (interpret-query ',query))
       (let ,(mapcar #'(lambda (v)
                         `(,v (binding ',v ,binds)))
                     (vars-in query #'atom))
         ,@body))))

(defun interpret-query (expr &optional binds)
  (case (car expr)   
    (and  (interpret-and (reverse (cdr expr)) binds))
    (or   (interpret-or (cdr expr) binds))
    (not  (interpret-not (cadr expr) binds))
    (t    (lookup (car expr) (cdr expr) binds))))
 
(defun interpret-and (clauses binds)
  (if (null clauses)
      (list binds)
      (mapcan #'(lambda (b)
                  (interpret-query (car clauses) b))
              (interpret-and (cdr clauses) binds))))
 
(defun interpret-or (clauses binds)
  (mapcan #'(lambda (c)
              (interpret-query c binds))
          clauses))
 
(defun interpret-not (clause binds)
  (if (interpret-query clause binds)
      nil
      (list binds)))

(defun lookup (pred args &optional binds)
  (mapcan #'(lambda (x)
              (aif2 (match x args binds) (list it)))
          (db-query pred)))

(defmacro with-answer (query &body body)
  `(with-gensyms ,(vars-in query #'simple?)
     ,(compile-query query `(progn ,@body))))

(defun compile-query (q body)
  (case (car q)
    (and  (compile-and (cdr q) body))
    (or   (compile-or  (cdr q) body))
    (not  (compile-not (cadr q) body))
    (lisp `(if ,(cadr q) ,body))
    (t    (compile-simple q body))))

(defun compile-simple (q body)
  (let ((fact (gensym)))
    `(dolist (,fact (db-query ',(car q)))
       (pat-match ,(cdr q) ,fact ,body nil))))

(defun compile-and (clauses body)
  (if (null clauses)
      body
      (compile-query (car clauses)
                     (compile-and (cdr clauses) body))))

(defun compile-or (clauses body)
  (if (null clauses)
      nil
      (let ((gbod (gensym))
            (vars (vars-in body #'simple?)))
        `(labels ((,gbod ,vars ,body))
           ,@(mapcar #'(lambda (cl)
                         (compile-query cl `(,gbod ,@vars)))
                     clauses)))))

(defun compile-not (q body)
  (let ((tag (gensym)))
    `(if (block ,tag
           ,(compile-query q `(return-from ,tag nil))
           t)
         ,body)))

(setq *cont* #'identity)

(defmacro =lambda (parms &body body) 
  `#'(lambda (*cont* ,@parms) ,@body))

(defmacro =defun (name parms &body body)
  (let ((f (intern (concatenate 'string
                                "=" (symbol-name name)))))
    `(progn
       (defmacro ,name ,parms
         `(,',f *cont* ,,@parms))
       (defun ,f (*cont* ,@parms) ,@body))))
 
(defmacro =bind (parms expr &body body)
  `(let ((*cont* #'(lambda ,parms ,@body))) ,expr))
    
(defmacro =values (&rest retvals)
  `(funcall *cont* ,@retvals))

(defmacro =funcall (fn &rest args)
  `(funcall ,fn *cont* ,@args))

(defmacro =apply (fn &rest args)
  `(apply ,fn *cont* ,@args))

(defparameter *paths* nil)
(defconstant failsym '@)

(defmacro choose (&rest choices)
  (if choices
      `(progn
         ,@(mapcar #'(lambda (c)
                       `(push #'(lambda () ,c) *paths*))
                   (reverse (cdr choices)))
         ,(car choices))
      '(fail)))

(defmacro choose-bind (var choices &body body)
  `(cb #'(lambda (,var) ,@body) ,choices))
 
(defun cb (fn choices)
  (if choices
     (progn
       (if (cdr choices)
           (push #'(lambda () (cb fn (cdr choices)))
                 *paths*))
       (funcall fn (car choices)))
     (fail)))
 
(defun fail ()
  (if *paths*
      (funcall (pop *paths*))
      failsym))

(defstruct proc  pri state wait) 

(proclaim '(special *procs* *proc*))

(defvar *halt* (gensym))

(defvar *default-proc*
        (make-proc :state #'(lambda (x) 
                              (format t "~%>> ")
                              (princ (eval (read)))
                              (pick-process))))
        
(defmacro fork (expr pri)
  `(prog1 ',expr
          (push (make-proc 
                  :state #'(lambda (,(gensym))
                             ,expr
                             (pick-process))
                  :pri   ,pri)
                *procs*)))

(defmacro program (name args &body body)
  `(=defun ,name ,args
     (setq *procs* nil)
     ,@body 
     (catch *halt* (loop (pick-process)))))

(defun pick-process ()
  (multiple-value-bind (p val) (most-urgent-process)
    (setq *proc*  p
          *procs* (delete p *procs*))
    (funcall (proc-state p) val)))
    
(defun most-urgent-process ()
  (let ((proc1 *default-proc*) (max -1) (val1 t))
    (dolist (p *procs*)
      (let ((pri (proc-pri p)))
        (if (> pri max)
            (let ((val (or (not (proc-wait p))
                           (funcall (proc-wait p)))))
              (when val
                (setq proc1 p
                      max   pri
                      val1  val))))))
    (values proc1 val1)))

(defun arbitrator (test cont)
  (setf (proc-state *proc*) cont 
        (proc-wait *proc*)  test)
  (push *proc* *procs*)
  (pick-process))
 
(defmacro wait (parm test &body body)
  `(arbitrator #'(lambda () ,test) 
               #'(lambda (,parm) ,@body))) 
 
(defmacro yield (&body body)
  `(arbitrator nil #'(lambda (,(gensym)) ,@body)))
 
(defun setpri (n) (setf (proc-pri *proc*) n))

(defun halt (&optional val) (throw *halt* val))
 
(defun kill (&optional obj &rest args)
  (if obj
      (setq *procs* (apply #'delete obj *procs* args))
      (pick-process)))

(defvar *open-doors* nil)

(=defun pedestrian () 
  (wait d (car *open-doors*)
    (format t "Entering ~A~%" d)))

(program ped () 
  (fork (pedestrian) 1))

(=defun capture (city) 
  (take city)
  (setpri 1)
  (yield
    (fortify city)))

(=defun plunder (city) 
  (loot city)
  (ransom city))

(defun take (c)    (format t "Liberating ~A.~%" c)) 
(defun fortify (c) (format t "Rebuilding ~A.~%" c)) 
(defun loot (c)    (format t "Nationalizing ~A.~%" c)) 
(defun ransom (c)  (format t "Refinancing ~A.~%" c))

(program barbarians ()   
  (fork (capture 'rome) 100)
  (fork (plunder 'rome) 98))

(defmacro defnode (name &rest arcs)
  `(=defun ,name (pos regs) (choose ,@arcs)))
 
(defmacro down (sub next &rest cmds)
  `(=bind (* pos regs) (,sub pos (cons nil regs))
     (,next pos ,(compile-cmds cmds))))
 
(defmacro cat (cat next &rest cmds)
  `(if (= (length *sent*) pos)
       (fail)
       (let ((* (nth pos *sent*)))
         (if (member ',cat (types *))
             (,next (1+ pos) ,(compile-cmds cmds))
             (fail)))))

(defmacro jump (next &rest cmds)
  `(,next pos ,(compile-cmds cmds)))

(defun compile-cmds (cmds)
  (if (null cmds)
      'regs
      `(,@(car cmds) ,(compile-cmds (cdr cmds)))))

(defmacro up (expr)
  `(let ((* (nth pos *sent*)))
     (=values ,expr pos (cdr regs))))

(defmacro getr (key &optional (regs 'regs))
  `(let ((result (cdr (assoc ',key (car ,regs)))))
     (if (cdr result) result (car result))))

(defmacro set-register (key val regs)
  `(cons (cons (cons ,key ,val) (car ,regs)) 
         (cdr ,regs)))

(defmacro setr (key val regs)
  `(set-register ',key (list ,val) ,regs))

(defmacro pushr (key val regs)
  `(set-register ',key
                 (cons ,val (cdr (assoc ',key (car ,regs))))
                 ,regs))

(defmacro with-parses (node sent &body body)
  (with-gensyms (pos regs)
    `(progn
       (setq *sent* ,sent)
       (setq *paths* nil)
       (=bind (parse ,pos ,regs) (,node 0 '(nil))
         (if (= ,pos (length *sent*))
             (progn ,@body (fail))
             (fail))))))

(defun types (word)
  (case word 
    ((do does did) '(aux v))
    ((time times) '(n v))
    ((fly flies) '(n v))
    ((like) '(v prep))
    ((liked likes) '(v))
    ((a an the) '(det))
    ((arrow arrows) '(n))
    ((i you he she him her it) '(pron))))

(defnode mods
  (cat n mods/n
    (setr mods *)))

(defnode mods/n
  (cat n mods/n
    (pushr mods *))
  (up `(n-group ,(getr mods))))

(defnode np
  (cat det np/det
    (setr det *))
  (jump np/det
    (setr det nil))
  (cat pron  pron
    (setr n *)))

(defnode pron
  (up `(np (pronoun ,(getr n)))))

(defnode np/det
  (down mods np/mods
    (setr mods *))
  (jump np/mods
    (setr mods nil)))

(defnode np/mods
  (cat n np/n
    (setr n *)))

(defnode np/n
  (up `(np (det ,(getr det))
           (modifiers ,(getr mods))
           (noun ,(getr n))))
  (down pp np/pp
    (setr pp *)))

(defnode np/pp
  (up `(np (det ,(getr det))
           (modifiers ,(getr mods))
           (noun ,(getr n))
           ,(getr pp))))

(defnode pp
  (cat prep pp/prep
    (setr prep *)))

(defnode pp/prep
  (down np pp/np
    (setr op *)))
 
(defnode pp/np
  (up `(pp (prep ,(getr prep))
           (obj ,(getr op)))))

(defnode s
  (down np s/subj
    (setr mood 'decl)
    (setr subj *))
  (cat v v
    (setr mood 'imp)
    (setr subj '(np (pron you)))
    (setr aux nil)
    (setr v *)))

(defnode s/subj
  (cat v v
    (setr aux nil)
    (setr v *)))

(defnode v
  (up `(s (mood ,(getr mood))
          (subj ,(getr subj))
          (vcl (aux ,(getr aux))
               (v ,(getr v)))))
  (down np s/obj
    (setr obj *)))

(defnode s/obj
  (up `(s (mood ,(getr mood))
          (subj ,(getr subj))
          (vcl (aux ,(getr aux))
               (v ,(getr v)))
          (obj ,(getr obj)))))

(defmacro with-inference (query &body body)
 `(progn
    (setq *paths* nil)
    (=bind (binds) (prove-query ',(rep_ query) nil)
      (let ,(mapcar #'(lambda (v) 
                        `(,v (fullbind ',v binds)))
                    (vars-in query #'atom))
        ,@body 
        (fail)))))

(defun rep_ (x)
  (if (atom x) 
      (if (eq x '_) (gensym "?") x)
      (cons (rep_ (car x)) (rep_ (cdr x)))))

(defun fullbind (x b)
  (cond ((varsym? x) (aif2 (binding x b) 
                           (fullbind it b) 
                           (gensym)))
        ((atom x) x)
        (t (cons (fullbind (car x) b) 
                 (fullbind (cdr x) b)))))

(defun varsym? (x)
  (and (symbolp x) (eq (char (symbol-name x) 0) #\?)))

(defmacro with-inference (query &rest body)
  (let ((vars (vars-in query #'simple?)) (gb (gensym)))
    `(with-gensyms ,vars
       (setq *paths* nil)
       (=bind (,gb) ,(gen-query (rep_ query))
         (let ,(mapcar #'(lambda (v) 
                           `(,v (fullbind ,v ,gb)))
                       vars)
           ,@body)
         (fail)))))

(defun varsym? (x) 
  (and (symbolp x) (not (symbol-package x))))

(defun gen-query (expr &optional binds)
  (case (car expr)
    (and (gen-and (cdr expr) binds))
    (or  (gen-or  (cdr expr) binds))
    (not (gen-not (cadr expr) binds))
    (t   `(prove (list ',(car expr) 
                       ,@(mapcar #'form (cdr expr))) 
                 ,binds))))
 
(defun gen-and (clauses binds)
  (if (null clauses)
      `(=values ,binds)
      (let ((gb (gensym)))
        `(=bind (,gb) ,(gen-query (car clauses) binds)
           ,(gen-and (cdr clauses) gb)))))
 
(defun gen-or (clauses binds)
  `(choose
     ,@(mapcar #'(lambda (c) (gen-query c binds)) 
               clauses)))
 
(defun gen-not (expr binds)
  (let ((gpaths (gensym)))
    `(let ((,gpaths *paths*))
       (setq *paths* nil)
       (choose (=bind (b) ,(gen-query expr binds)
                 (setq *paths* ,gpaths)
                 (fail))
               (progn
                 (setq *paths* ,gpaths)
                 (=values ,binds))))))

(=defun prove (query binds)
   (choose-bind r *rules* (=funcall r query binds)))

(defun form (pat)
  (if (simple? pat)
      pat
      `(cons ,(form (car pat)) ,(form (cdr pat)))))

(defvar *rules* nil)

(defmacro <- (con &rest ant)
  (let ((ant (if (= (length ant) 1) 
                 (car ant) 
                 `(and ,@ant))))
    `(length (conc1f *rules* 
                     ,(rule-fn (rep_ ant) (rep_ con))))))

(defun rule-fn (ant con)
  (with-gensyms (val win fact binds)
    `(=lambda (,fact ,binds)
       (with-gensyms ,(vars-in (list ant con) #'simple?)
         (multiple-value-bind 
             (,val ,win) 
             (match ,fact
                    (list ',(car con)
                          ,@(mapcar #'form (cdr con))) 
                    ,binds)
           (if ,win 
               ,(gen-query ant val) 
               (fail)))))))

(defun rule-fn (ant con)
  (with-gensyms (val win fact binds paths)                 ;
    `(=lambda (,fact ,binds ,paths)                        ;
       (with-gensyms ,(vars-in (list ant con) #'simple?)
         (multiple-value-bind 
             (,val ,win) 
             (match ,fact
                    (list ',(car con) 
                          ,@(mapcar #'form (cdr con))) 
                    ,binds)
           (if ,win 
               ,(gen-query ant val paths)                  ;
               (fail)))))))

(defmacro with-inference (query &rest body)
  (let ((vars (vars-in query #'simple?)) (gb (gensym)))
    `(with-gensyms ,vars
       (setq *paths* nil)
       (=bind (,gb) ,(gen-query (rep_ query) nil '*paths*) ;
         (let ,(mapcar #'(lambda (v) 
                           `(,v (fullbind ,v ,gb)))
                       vars)
           ,@body)
         (fail)))))

(defun gen-query (expr binds paths)                        ;
  (case (car expr)
    (and  (gen-and (cdr expr) binds paths))                ;
    (or   (gen-or  (cdr expr) binds paths))                ;
    (not  (gen-not (cadr expr) binds paths))               ;
    (lisp (gen-lisp (cadr expr) binds))                    ;
    (is   (gen-is (cadr expr) (third expr) binds))         ;
    (cut  `(progn (setq *paths* ,paths)                    ;
                  (=values ,binds)))                       ;
    (t    `(prove (list ',(car expr) 
                        ,@(mapcar #'form (cdr expr)))
                  ,binds *paths*))))                       ;
 
(=defun prove (query binds paths)                          ;
   (choose-bind r *rules* 
     (=funcall r query binds paths)))                      ;

(defun gen-and (clauses binds paths)                       ;
  (if (null clauses)
      `(=values ,binds)
      (let ((gb (gensym)))
       `(=bind (,gb) ,(gen-query (car clauses) binds paths);
          ,(gen-and (cdr clauses) gb paths)))))            ;

(defun gen-or (clauses binds paths)                        ;
  `(choose
     ,@(mapcar #'(lambda (c) (gen-query c binds paths))    ;
               clauses)))
 
(defun gen-not (expr binds paths)                          ;
  (let ((gpaths (gensym)))
    `(let ((,gpaths *paths*))
       (setq *paths* nil)
       (choose (=bind (b) ,(gen-query expr binds paths)    ;
                 (setq *paths* ,gpaths)
                 (fail))
               (progn
                 (setq *paths* ,gpaths)
                 (=values ,binds))))))
 
(defmacro with-binds (binds expr)
  `(let ,(mapcar #'(lambda (v) `(,v (fullbind ,v ,binds)))
                 (vars-in expr))
     ,expr))
 
(defun gen-lisp (expr binds)
  `(if (with-binds ,binds ,expr)
       (=values ,binds)
       (fail)))
 
(defun gen-is (expr1 expr2 binds)
  `(aif2 (match ,expr1 (with-binds ,binds ,expr2) ,binds)
         (=values it)
         (fail)))

(defun rget (obj prop)
  (some2 #'(lambda (a) (gethash prop a))
         (get-ancestors obj)))

(defun get-ancestors (obj)
  (labels ((getall (x)
             (append (list x)
                     (mapcan #'getall
                             (gethash 'parents x)))))
    (stable-sort (delete-duplicates (getall obj))
                 #'(lambda (x y)
                     (member y (gethash 'parents x))))))

(defun some2 (fn lst)
  (if (atom lst)
      nil
      (multiple-value-bind (val win) (funcall fn (car lst))
        (if (or val win)
            (values val win)
            (some2 fn (cdr lst))))))

(defun obj (&rest parents)
  (let ((obj (make-hash-table)))
    (setf (gethash 'parents obj) parents)
    (ancestors obj)
    obj))

(defun ancestors (obj)
  (or (gethash 'ancestors obj)
      (setf (gethash 'ancestors obj) (get-ancestors obj))))

(defun rget (obj prop)
  (some2 #'(lambda (a) (gethash prop a))
         (ancestors obj)))

(defmacro defprop (name &optional meth?)
  `(progn
     (defun ,name (obj &rest args)
       ,(if meth?
            `(run-methods obj ',name args)
            `(rget obj ',name)))
     (defsetf ,name (obj) (val)
       `(setf (gethash ',',name ,obj) ,val))))

(defun run-methods (obj name args)
  (let ((meth (rget obj name)))
    (if meth 
        (apply meth obj args)
        (error "No ~A method for ~A." name obj))))

(defstruct meth  around before primary after)

(defmacro meth- (field obj)
  (let ((gobj (gensym)))
    `(let ((,gobj ,obj))
       (and (meth-p ,gobj)
            (,(symb 'meth- field) ,gobj)))))

(defun run-methods (obj name args)
  (let ((pri (rget obj name :primary)))
    (if pri
        (let ((ar (rget obj name :around)))
          (if ar
              (apply ar obj args)
              (run-core-methods obj name args pri)))
        (error "No primary ~A method for ~A." name obj))))

(defun run-core-methods (obj name args &optional pri)
  (multiple-value-prog1
    (progn (run-befores obj name args)
           (apply (or pri (rget obj name :primary)) 
                  obj args))
    (run-afters obj name args)))

(defun rget (obj prop &optional meth (skip 0))
  (some2 #'(lambda (a) 
             (multiple-value-bind (val win) (gethash prop a)
               (if win
                   (case meth (:around  (meth- around val))
                              (:primary (meth- primary val))
                              (t (values val win))))))
         (nthcdr skip (ancestors obj))))

(defun run-befores (obj prop args)
  (dolist (a (ancestors obj))
    (let ((bm (meth- before (gethash prop a))))
      (if bm (apply bm obj args)))))

(defun run-afters (obj prop args)
  (labels ((rec (lst)
             (when lst
               (rec (cdr lst))
               (let ((am (meth- after 
                                (gethash prop (car lst)))))
                 (if am (apply am (car lst) args))))))
    (rec (ancestors obj))))

(defmacro defmeth ((name &optional (type :primary)) 
                   obj parms &body body)
  (let ((gobj (gensym)))
    `(let ((,gobj ,obj))
       (defprop ,name t)
       (unless (meth-p (gethash ',name ,gobj))
         (setf (gethash ',name ,gobj) (make-meth)))
       (setf (,(symb 'meth- type) (gethash ',name ,gobj))
             ,(build-meth name type gobj parms body)))))

(defun build-meth (name type gobj parms body)
  (let ((gargs (gensym)))
    `#'(lambda (&rest ,gargs)
          (labels 
            ((call-next ()
               ,(if (or (eq type :primary) 
                        (eq type :around))
                    `(cnm ,gobj ',name (cdr ,gargs) ,type)
                    '(error "Illegal call-next.")))
             (next-p ()
               ,(case type
                  (:around 
                   `(or (rget ,gobj ',name :around 1)
                        (rget ,gobj ',name :primary))) 
                  (:primary 
                   `(rget ,gobj ',name :primary 1))
                  (t nil))))
            (apply #'(lambda ,parms ,@body) ,gargs)))))

(defun cnm (obj name args type)
  (case type
    (:around  (let ((ar (rget obj name :around 1)))
                (if ar
                    (apply ar obj args)
                    (run-core-methods obj name args))))
    (:primary (let ((pri (rget obj name :primary 1)))
                (if pri
                    (apply pri obj args)
                    (error "No next method."))))))

(defmacro undefmeth ((name &optional (type :primary)) obj)
  `(setf (,(symb 'meth- type) (gethash ',name ,obj)) 
         nil))

(defmacro children (obj) 
  `(gethash 'children ,obj))

(defun parents (obj)
  (gethash 'parents obj))

(defun set-parents (obj pars)
  (dolist (p (parents obj))
    (setf (children p) 
          (delete obj (children p))))
  (setf (gethash 'parents obj) pars)
  (dolist (p pars)
    (pushnew obj (children p)))
  (maphier #'(lambda (obj) 
               (setf (gethash 'ancestors obj) 
                     (get-ancestors obj)))
           obj)
  pars)

(defsetf parents set-parents)

(defun maphier (fn obj)
  (funcall fn obj)
  (dolist (c (children obj))
    (maphier fn c)))

(defun obj (&rest parents)
  (let ((obj (make-hash-table)))
    (setf (parents obj) parents)
    obj))

(defmacro defcomb (name op)
  `(progn
     (defprop ,name t)
     (setf (get ',name 'mcombine)
           ,(case op
              (:standard nil)
              (:progn '#'(lambda (&rest args) 
                           (car (last args))))
              (t op)))))

(defun run-core-methods (obj name args &optional pri)
  (let ((comb (get name 'mcombine)))
    (if comb
        (if (symbolp comb)
            (funcall (case comb (:and #'comb-and)
                                (:or  #'comb-or))
                     obj name args (ancestors obj))
            (comb-normal comb obj name args))
        (multiple-value-prog1
          (progn (run-befores obj name args)
                 (apply (or pri (rget obj name :primary))
                        obj args))
          (run-afters obj name args)))))

(defun comb-normal (comb obj name args)
  (apply comb
         (mapcan #'(lambda (a)
                     (let* ((pm (meth- primary 
                                       (gethash name a)))
                            (val (if pm 
                                     (apply pm obj args))))
                        (if val (list val))))
                 (ancestors obj))))

(defun comb-and (obj name args ancs &optional (last t))
  (if (null ancs)
      last
      (let ((pm (meth- primary (gethash name (car ancs)))))
        (if pm
            (let ((new (apply pm obj args)))
              (and new 
                   (comb-and obj name args (cdr ancs) new)))
            (comb-and obj name args (cdr ancs) last)))))

(defun comb-or (obj name args ancs)
  (and ancs
       (let ((pm (meth- primary (gethash name (car ancs)))))
         (or (and pm (apply pm obj args))
             (comb-or obj name args (cdr ancs))))))

(defmacro undefmethod (name &rest args)
  (if (consp (car args))
      (udm name nil (car args))
      (udm name (list (car args)) (cadr args))))

(defun udm (name qual specs)
  (let ((classes (mapcar #'(lambda (s)
                             `(find-class ',s))
                         specs)))
    `(remove-method (symbol-function ',name)
                    (find-method (symbol-function ',name)
                                 ',qual
                                 (list ,@classes)))))

(defun compall ()
  (do-symbols (s)
    (when (fboundp s)
      (unless (compiled-function-p (symbol-function s))
        (print s)
        (compile s)))))

(defmacro check (expr)
  `(block nil
     (with-inference ,expr
       (return t))))

; This code is copyright 1993 by Paul Graham, but anyone who wants 
; to use the code in any nonprofit activity, or distribute free
; verbatim copies (including this notice), is encouraged to do so.

#+END_SRC

** [[/Users/Can/Develop/Lisp/others/lib/dtrace.lisp][dtrace]]
#+BEGIN_SRC lisp 
;;; -*- Mode: Lisp; Package: DTRACE -*-

;;; DTRACE is a portable alternative to the Common Lisp TRACE and UNTRACE
;;; macros.  It offers a more detailed display than most tracing tools.
;;;
;;; From the book "Common Lisp:  A Gentle Introduction to
;;;      Symbolic Computation" by David S. Touretzky.  
;;; The Benjamin/Cummings Publishing Co., 1990.
;;;
;;; This is the generic version.  It should work in any legal Common Lisp.
;;; Revised August, 2003, to work with ANSI Common Lisp and Allegro v6.
;;;
;;; User-level routines:
;;;   DTRACE  - same syntax as TRACE
;;;   DUNTRACE - same syntax as UNTRACE

(defpackage :dtrace
  (:use :common-lisp)
  (:export dtrace duntrace
	   *dtrace-print-length* *dtrace-print-level*
	   *dtrace-print-circle* *dtrace-print-pretty*
	   *dtrace-print-array*))

(in-package :dtrace)	    

(eval-when (eval load)
  (shadowing-import '(dtrace duntrace) (find-package :common-lisp-user)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; DTRACE and subordinate routines.

(defparameter *dtrace-print-length* 7)
(defparameter *dtrace-print-level*  4)
(defparameter *dtrace-print-circle* t)
(defparameter *dtrace-print-pretty* nil)
(defparameter *dtrace-print-array* *print-array*)

(defvar *traced-functions* nil)
(defvar *trace-level* 0)

(defmacro dtrace (&rest function-names)
  "Turns on detailed tracing for specified functions.  Undo with DUNTRACE."
  (if (null function-names)
      (list 'quote *traced-functions*)
      (list 'quote (mapcan #'dtrace1 function-names))))

(defun dtrace1 (name)
  (unless (symbolp name)
    (format *error-output* "~&~S is an invalid function name." name)
    (return-from dtrace1 nil))
  (unless (fboundp name)
    (format *error-output* "~&~S undefined function." name)
    (return-from dtrace1 nil))
  (eval `(untrace ,name))	;; if they're tracing it, undo their trace
  (duntrace1 name)		;; if we're tracing it, undo our trace
  (when (special-operator-p name)
    (format *error-output*
	    "~&Can't trace ~S because it's a special form." name)
    (return-from dtrace1 nil))
  (if (macro-function name)
      (trace-macro name)
      (trace-function name))
  (setf *traced-functions* (nconc *traced-functions* (list name)))
  (list name))

;;; The functions below reference DISPLAY-xxx routines that can be made
;;; implementation specific for fancy graphics.  Generic versions of
;;; these routines are defined later in this file.

(defmacro with-dtrace-printer-settings (&body body)
  `(let ((*print-length* *dtrace-print-length*)
	 (*print-level* *dtrace-print-level*)
	 (*print-circle* *dtrace-print-circle*)
	 (*print-pretty* *dtrace-print-pretty*)
	 (*print-array* *dtrace-print-array*))
     ,@body))

(defun trace-function (name)
  (let* ((formal-arglist (fetch-arglist name))
	 (old-defn (symbol-function name))
	 (new-defn
	  #'(lambda (&rest argument-list)
	      (let ((result nil))
		(display-function-entry name)
		(let ((*trace-level* (1+ *trace-level*)))
		  (with-dtrace-printer-settings
		   (show-function-args argument-list formal-arglist))
		  (setf result (multiple-value-list
				(apply old-defn argument-list))))
		(display-function-return name result)
		(values-list result)))))
    (setf (get name 'original-definition) old-defn)
    (setf (get name 'traced-definition) new-defn)
    (setf (get name 'traced-type) 'defun)
    (setf (symbol-function name) new-defn)))

(defun trace-macro (name)
  (let* ((formal-arglist (fetch-arglist name))
	 (old-defn (macro-function name))
	 (new-defn
	  #'(lambda (macro-args env)
	      (let ((result nil))
		(display-function-entry name 'macro)
		(let ((*trace-level* (1+ *trace-level*)))
		  (with-dtrace-printer-settings
		   (show-function-args macro-args formal-arglist))
		  (setf result (funcall old-defn macro-args env)))
	(display-function-return name (list result) 'macro)
		(values result)))))
    (setf (get name 'original-definition) old-defn)
    (setf (get name 'traced-definition) new-defn)
    (setf (get name 'traced-type) 'defmacro)
    (setf (macro-function name) new-defn)))

(defun show-function-args (actuals formals &optional (argcount 0))
  (cond ((null actuals) nil)
	((null formals) (handle-args-numerically actuals argcount))
	(t (case (first formals)
	     (&optional (show-function-args
			 actuals (rest formals) argcount))
	     (&rest (show-function-args
		     (list actuals) (rest formals) argcount))
	     (&key (handle-keyword-args actuals))
	     (&aux (show-function-args actuals nil argcount))
	     (t (handle-one-arg (first actuals) (first formals))
		(show-function-args (rest actuals)
				    (rest formals)
				    (1+ argcount)))))))

(defun handle-args-numerically (actuals argcount)
  (dolist (x actuals)
    (incf argcount)
    (display-arg-numeric x argcount)))

(defun handle-one-arg (val varspec)
  (cond ((atom varspec) (display-one-arg val varspec))
	(t (display-one-arg val (first varspec))
	   (if (third varspec)
	       (display-one-arg t (third varspec))))))

(defun handle-keyword-args (actuals)
  (cond ((null actuals))
	((keywordp (first actuals))
	 (display-one-arg (second actuals) (first actuals))
	 (handle-keyword-args (rest (rest actuals))))
	(t (display-one-arg actuals "Extra args:"))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; DUNTRACE and subordinate routines.

(defmacro duntrace (&rest function-names)
  "Turns off tracing for specified functions.  
   With no args, turns off all tracing."
  (setf *trace-level* 0)  ;; safety precaution
  (list 'quote
	(mapcan #'duntrace1 (or function-names *traced-functions*))))

(defun duntrace1 (name)
  (unless (symbolp name)
    (format *error-output* "~&~S is an invalid function name." name)
    (return-from duntrace1 nil))
  (setf *traced-functions* (delete name *traced-functions*))
  (let ((orig-defn (get name 'original-definition 'none))
	(traced-defn (get name 'traced-definition))
	(traced-type (get name 'traced-type 'none)))
    (unless (or (eq orig-defn 'none)
		(not (fboundp name))
		(not (equal traced-defn  ;; did it get redefined?
			 (ecase traced-type
			   (defun (symbol-function name))
			   (defmacro (macro-function name))))))
      (ecase traced-type
	(defun (setf (symbol-function name) orig-defn))
	(defmacro (setf (macro-function name) orig-defn)))))
  (remprop name 'traced-definition)
  (remprop name 'traced-type)
  (remprop name 'original-definition)
  (list name))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Display routines.
;;;
;;; The code below generates vanilla character output for ordinary 
;;; displays.  It can be replaced with special graphics code if the
;;; implementation permits, e.g., on a PC you can use the IBM graphic
;;; character set to draw nicer-looking arrows.  On a color PC you 
;;; can use different colors for arrows, for function names, for 
;;; argument values, and so on.

(defparameter *entry-arrow-string* "----")
(defparameter *vertical-string*    "|   ")
(defparameter *exit-arrow-string*  " \\--")

(defparameter *trace-wraparound* 15)

(defun display-function-entry (name &optional ftype)
  (space-over)
  (draw-entry-arrow)
  (format *trace-output* "Enter ~S" name)
  (if (eq ftype 'macro)
      (format *trace-output* " macro")))

(defun display-one-arg (val name)
  (space-over)
  (format *trace-output*
	  (typecase name
	    (keyword "  ~S ~S")
	    (string  "  ~A ~S")
	    (t "  ~S = ~S"))
	  name val))

(defun display-arg-numeric (val num)
  (space-over)
  (format *trace-output* "  arg-~D = ~S" num val))

(defun display-function-return (name results &optional ftype)
  (with-dtrace-printer-settings
    (space-over)
    (draw-exit-arrow)
    (format *trace-output* "~S ~A"
	    name
	    (if (eq ftype 'macro) "expanded to" "returned"))
    (cond ((null results))
	  ((null (rest results)) (format *trace-output* " ~S" (first results)))
	  (t (format *trace-output* " values ~{~S, ~}~s"
		     (butlast results)
		     (car (last results)))))))

(defun space-over ()
  (format *trace-output* "~&")
  (dotimes (i (mod *trace-level* *trace-wraparound*))
    (format *trace-output* "~A" *vertical-string*)))

(defun draw-entry-arrow ()
  (format *trace-output* "~A" *entry-arrow-string*))

(defun draw-exit-arrow ()
  (format *trace-output* "~A" *exit-arrow-string*))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; The function FETCH-ARGLIST is implementation dependent.  It 
;;; returns the formal argument list of a function as it would 
;;; appear in a DEFUN or lambda expression, including any lambda
;;; list keywords.  Here are versions of FETCH-ARGLIST for three
;;; Lisp implementations.

;;; Minimal generic version
#-(or lucid allegro gclisp kcl cmu)
  (defun fetch-arglist (fn)
    (declare (ignore fn))
    nil)

;;; Lucid version
#+lucid
  (defun fetch-arglist (fn)
    (system::arglist fn))


#+allegro
  (defun fetch-arglist (fn)
    (excl::arglist fn))

;;; GCLisp 1.1 version
#+gclisp
  (defun fetch-arglist (fn)
    (if (macro-function fn)
	'(&rest "Form =")
	(lambda-list fn)))

;;; KCL version
#+kcl
(defun fetch-arglist (fn)
  (let ((x (symbol-function fn)))
    (cond ((atom x) nil)
	  ((eq (first x) 'macro) (list '&rest "Form ="))
	  (t (third x)))))

;;; CMU Common Lisp version.  This version looks in a symbol's
;;; function cell and knows how to take apart lexical closures
;;; and compiled code objects found there.
#+cmu
  (defun fetch-arglist (x &optional original-x)
    (cond ((symbolp x) (fetch-arglist (symbol-function x) x))
	  ((compiled-function-p x)
	   (read-from-string
	    (lisp::%primitive header-ref x
			      lisp::%function-arg-names-slot)))
	  ((listp x) (case (first x)
		       (lambda (second x))
		       (lisp::%lexical-closure% (fetch-arglist (second x)))
		       (system:macro '(&rest "Form ="))
		       (t '(&rest "Arglist:"))))
	  (t (cerror (format nil
                        "Use a reasonable default argument list for ~S"
		        original-x)
		"Unkown object in function cell of ~S:  ~S" original-x x)
	     '())))

#+END_SRC

** [[/Users/Can/Develop/Lisp/others/lib/acl2.lisp][acl2]]
#+BEGIN_SRC lisp 
; The code in this file was mechanically extracted from the TeX
; source files of _Ansi Common Lisp_, except for bst-remove and
; bst-delete and their subroutines, which replace broken versions 
; in the book.

; If you have questions or comments about this code, or you want
; something I didn't include, send mail to lispcode@paulgraham.com.

; This code is copyright 1995 by Paul Graham, but anyone who wants
; to use it is free to do so.

; *** list ***


(defun compress (x)
  (if (consp x) 
      (compr (car x) 1 (cdr x))
      x))

(defun compr (elt n lst)
  (if (null lst)
      (list (n-elts elt n))
      (let ((next (car lst)))
        (if (eql next elt)
            (compr elt (+ n 1) (cdr lst))
            (cons (n-elts elt n)
                  (compr next 1 (cdr lst)))))))

(defun n-elts (elt n)
  (if (> n 1)
      (list n elt)
      elt))


(defun uncompress (lst)
  (if (null lst)
      nil
      (let ((elt (car lst))
            (rest (uncompress (cdr lst))))
        (if (consp elt)
            (append (apply #'list-of elt)
                    rest)
            (cons elt rest)))))

(defun list-of (n elt)
  (if (zerop n)
      nil
      (cons elt (list-of (- n 1) elt))))


(defun mirror? (s)
  (let ((len (length s)))
    (and (evenp len)
         (let ((mid (/ len 2)))
           (equal (subseq s 0 mid)
                  (reverse (subseq s mid)))))))


(defun shortest-path (start end net)
  (bfs end (list (list start)) net))

(defun bfs (end queue net)
  (if (null queue)
      nil
      (let ((path (car queue)))
        (let ((node (car path)))
          (if (eql node end)
              (reverse path)
              (bfs end
                   (append (cdr queue)
                           (new-paths path node net))
                   net))))))

(defun new-paths (path node net)
  (mapcar #'(lambda (n)
              (cons n path))
          (cdr (assoc node net))))


; *** dat ***


(defun bin-search (obj vec)
  (let ((len (length vec)))
    (and (not (zerop len))
         (finder obj vec 0 (- len 1)))))

(defun finder (obj vec start end)
  (let ((range (- end start)))
    (if (zerop range)
        (if (eql obj (aref vec start))
            obj
            nil)
        (let ((mid (+ start (round (/ range 2)))))
          (let ((obj2 (aref vec mid)))
            (if (< obj obj2)
                (finder obj vec start (- mid 1))
                (if (> obj obj2)
                    (finder obj vec (+ mid 1) end)
                    obj)))))))


(defun mirror? (s)
  (let ((len (length s)))
    (and (evenp len)
         (do ((forward 0 (+ forward 1))
              (back (- len 1) (- back 1)))
             ((or (> forward back)
                  (not (eql (elt s forward)
                            (elt s back))))
              (> forward back))))))


(defun second-word (str)
  (let ((p1 (+ (position #\  str) 1)))
    (subseq str p1 (position #\  str :start p1))))


(defun tokens (str test start)
  (let ((p1 (position-if test str :start start)))
   (if p1
       (let ((p2 (position-if #'(lambda (c) 
                                  (not (funcall test c)))
                              str :start p1)))
         (cons (subseq str p1 p2)
               (if p2 
                   (tokens str test p2) 
                   nil)))
       nil)))

(defun constituent (c)
  (and (graphic-char-p c)
       (not (char= c #\  ))))


(defun parse-date (str)
  (let ((toks (tokens str #'constituent 0)))
    (list (parse-integer (first toks))
          (parse-month   (second toks))
          (parse-integer (third toks)))))

(defconstant month-names
  #("jan" "feb" "mar" "apr" "may" "jun"
    "jul" "aug" "sep" "oct" "nov" "dec"))

(defun parse-month (str)
  (let ((p (position str month-names 
                     :test #'string-equal)))
    (if p
        (+ p 1)
        nil)))


(defun read-integer (str)
  (if (every #'digit-char-p str)
      (let ((accum 0))
        (dotimes (pos (length str))
          (setf accum (+ (* accum 10)
                         (digit-char-p (char str pos)))))
        accum)
      nil))

(defstruct (node (:print-function
                  (lambda (n s d)
                    (format s "#<~A>" (node-elt n)))))
  elt (l nil) (r nil))

(defun bst-insert (obj bst <)
  (if (null bst)
      (make-node :elt obj)
      (let ((elt (node-elt bst)))
        (if (eql obj elt)
            bst
            (if (funcall < obj elt)
                (make-node
                  :elt elt
                  :l   (bst-insert obj (node-l bst) <)
                  :r   (node-r bst))
                (make-node
                  :elt elt
                  :r   (bst-insert obj (node-r bst) <)
                  :l   (node-l bst)))))))

(defun bst-find (obj bst <)
  (if (null bst)
      nil
      (let ((elt (node-elt bst)))
        (if (eql obj elt)
            bst
            (if (funcall < obj elt)
                (bst-find obj (node-l bst) <)
                (bst-find obj (node-r bst) <))))))

(defun bst-min (bst)
  (and bst
       (or (bst-min (node-l bst)) bst)))

(defun bst-max (bst)
  (and bst
       (or (bst-max (node-r bst)) bst)))

(defun bst-traverse (fn bst)
  (when bst
    (bst-traverse fn (node-l bst))
    (funcall fn (node-elt bst))
    (bst-traverse fn (node-r bst))))

; >>> Replaces bst-remove from book, which was broken.

(defun bst-remove (obj bst <)
  (if (null bst)
      nil
      (let ((elt (node-elt bst)))
        (if (eql obj elt)
            (percolate bst)
            (if (funcall < obj elt)
                (make-node
                  :elt elt
                  :l (bst-remove obj (node-l bst) <)
                  :r (node-r bst))
                (make-node
                  :elt elt
                  :r (bst-remove obj (node-r bst) <)
                  :l (node-l bst)))))))

(defun percolate (bst)
  (let ((l (node-l bst)) (r (node-r bst)))
    (cond ((null l) r)
          ((null r) l)
          (t (if (zerop (random 2))
                 (make-node :elt (node-elt (bst-max l))
                            :r r
                            :l (bst-remove-max l))
                 (make-node :elt (node-elt (bst-min r))
                            :r (bst-remove-min r)
                            :l l)))))) 

(defun bst-remove-min (bst)
  (if (null (node-l bst))  
      (node-r bst)
      (make-node :elt (node-elt bst)
                 :l   (bst-remove-min (node-l bst))
                 :r   (node-r bst))))

(defun bst-remove-max (bst)
  (if (null (node-r bst)) 
      (node-l bst)
      (make-node :elt (node-elt bst)
                 :l (node-l bst)
                 :r (bst-remove-max (node-r bst)))))



; *** con ***


(defun read-integer (str)
  (let ((accum 0))
    (dotimes (pos (length str))
      (let ((i (digit-char-p (char str pos))))
        (if i
            (setf accum (+ (* accum 10) i))
            (return-from read-integer nil))))
    accum))


(defun factorial (n)
  (do ((j n (- j 1))
       (f 1 (* j f)))
      ((= j 0) f)))


(defconstant month
  #(0 31 59 90 120 151 181 212 243 273 304 334 365))

(defconstant yzero 2000)

(defun leap? (y)
  (and (zerop (mod y 4))
       (or (zerop (mod y 400))
           (not (zerop (mod y 100))))))

(defun date->num (d m y)
  (+ (- d 1) (month-num m y) (year-num y)))

(defun month-num (m y)
  (+ (svref month (- m 1))
     (if (and (> m 2) (leap? y)) 1 0)))

(defun year-num (y)
  (let ((d 0))
    (if (>= y yzero)
        (dotimes (i (- y yzero) d)
          (incf d (year-days (+ yzero i))))
        (dotimes (i (- yzero y) (- d))
          (incf d (year-days (+ y i)))))))

(defun year-days (y) (if (leap? y) 366 365))


(defun num->date (n)
  (multiple-value-bind (y left) (num-year n)
    (multiple-value-bind (m d) (num-month left y)
      (values d m y))))

(defun num-year (n)
  (if (< n 0)
      (do* ((y (- yzero 1) (- y 1))
            (d (- (year-days y)) (- d (year-days y))))
           ((<= d n) (values y (- n d))))
      (do* ((y yzero (+ y 1))
            (prev 0 d)
            (d (year-days y) (+ d (year-days y))))
           ((> d n) (values y (- n prev))))))

(defun num-month (n y)
  (if (leap? y)
      (cond ((= n 59) (values 2 29))
            ((> n 59) (nmon (- n 1)))
            (t        (nmon n)))
      (nmon n)))

(defun nmon (n)
  (let ((m (position n month :test #'<)))
    (values m (+ 1 (- n (svref month (- m 1)))))))

(defun date+ (d m y n)
  (num->date (+ (date->num d m y) n)))


; *** fn ***


(defun single? (lst)
  (and (consp lst) (null (cdr lst))))

(defun append1 (lst obj)
  (append lst (list obj)))

(defun map-int (fn n)
  (let ((acc nil))
    (dotimes (i n)
      (push (funcall fn i) acc))
    (nreverse acc)))

(defun filter (fn lst)
  (let ((acc nil))
    (dolist (x lst)
      (let ((val (funcall fn x)))
        (if val (push val acc))))
    (nreverse acc)))

(defun most (fn lst)
  (if (null lst)
      (values nil nil)
      (let* ((wins (car lst))
             (max (funcall fn wins)))
        (dolist (obj (cdr lst))
          (let ((score (funcall fn obj)))
            (when (> score max)
              (setf wins obj
                    max  score))))
        (values wins max))))


(defun make-adder (n)
  #'(lambda (x)
      (+ x n)))


(let ((counter 0))
  (defun reset ()
    (setf counter 0))
  (defun stamp ()
    (setf counter (+ counter 1))))


(defun compose (&rest fns)
  (destructuring-bind (fn1 . rest) (reverse fns)
    #'(lambda (&rest args)
        (reduce #'(lambda (v f) (funcall f v))
                rest
                :initial-value (apply fn1 args)))))

(defun disjoin (fn &rest fns)
  (if (null fns)
      fn
      (let ((disj (apply #'disjoin fns)))
        #'(lambda (&rest args)
            (or (apply fn args) (apply disj args))))))

(defun conjoin (fn &rest fns)
  (if (null fns)
      fn
      (let ((conj (apply #'conjoin fns)))
        #'(lambda (&rest args)
            (and (apply fn args) (apply conj args))))))

(defun curry (fn &rest args)
  #'(lambda (&rest args2)
      (apply fn (append args args2))))

(defun rcurry (fn &rest args)
  #'(lambda (&rest args2)
      (apply fn (append args2 args))))

(defun always (x) #'(lambda (&rest args) x))


(defun fib (n)
  (if (<= n 1)
      1
      (+ (fib (- n 1))
         (fib (- n 2)))))


(defun fib (n)
  (do ((i  n (- i 1))
       (f1 1 (+ f1 f2))
       (f2 1 f1))
      ((<= i 1) f1)))


; *** io ***


(defun pseudo-cat (file)
  (with-open-file (str file :direction :input)
    (do ((line (read-line str nil 'eof) 
               (read-line str nil 'eof)))
        ((eql line 'eof))
      (format t "~A~%" line))))


(defstruct buf
  vec (start -1) (used -1) (new -1) (end -1))

(defun bref (buf n)
  (svref (buf-vec buf)
         (mod n (length (buf-vec buf)))))

(defun (setf bref) (val buf n)
  (setf (svref (buf-vec buf)
               (mod n (length (buf-vec buf))))
        val))

(defun new-buf (len)
  (make-buf :vec (make-array len)))

(defun buf-insert (x b)
  (setf (bref b (incf (buf-end b))) x))

(defun buf-pop (b)
  (prog1 
    (bref b (incf (buf-start b)))
    (setf (buf-used b) (buf-start b)
          (buf-new  b) (buf-end   b))))

(defun buf-next (b)
  (when (< (buf-used b) (buf-new b))
    (bref b (incf (buf-used b)))))

(defun buf-reset (b)
  (setf (buf-used b) (buf-start b)
        (buf-new  b) (buf-end   b)))

(defun buf-clear (b)
  (setf (buf-start b) -1 (buf-used  b) -1
        (buf-new   b) -1 (buf-end   b) -1))

(defun buf-flush (b str)
  (do ((i (1+ (buf-used b)) (1+ i)))
      ((> i (buf-end b)))
    (princ (bref b i) str)))


(defun file-subst (old new file1 file2)
  (with-open-file (in file1 :direction :input)
     (with-open-file (out file2 :direction :output
                                :if-exists :supersede)
       (stream-subst old new in out))))

(defun stream-subst (old new in out)
  (let* ((pos 0)
         (len (length old))
         (buf (new-buf len))
         (from-buf nil))
    (do ((c (read-char in nil :eof)
            (or (setf from-buf (buf-next buf))
                (read-char in nil :eof))))
        ((eql c :eof))
      (cond ((char= c (char old pos))
             (incf pos)
             (cond ((= pos len)            ; 3
                    (princ new out)
                    (setf pos 0)
                    (buf-clear buf))
                   ((not from-buf)         ; 2
                    (buf-insert c buf))))
            ((zerop pos)                   ; 1
             (princ c out)
             (when from-buf
               (buf-pop buf)
               (buf-reset buf)))
            (t                             ; 4
             (unless from-buf
               (buf-insert c buf))
             (princ (buf-pop buf) out)
             (buf-reset buf)
             (setf pos 0))))
    (buf-flush buf out)))


; *** sym ***


(defparameter *words* (make-hash-table :size 10000))

(defconstant maxword 100)

(defun read-text (pathname)
  (with-open-file (s pathname :direction :input)
    (let ((buffer (make-string maxword))
          (pos 0))
      (do ((c (read-char s nil :eof) 
              (read-char s nil :eof)))
          ((eql c :eof))
        (if (or (alpha-char-p c) (char= c #\'))
            (progn
              (setf (aref buffer pos) c)
              (incf pos))
            (progn
              (unless (zerop pos)
                (see (intern (string-downcase 
                               (subseq buffer 0 pos))))
                (setf pos 0))
              (let ((p (punc c)))
                (if p (see p)))))))))
  
(defun punc (c)
  (case c
    (#\. '|.|) (#\, '|,|) (#\; '|;|) 
    (#\! '|!|) (#\? '|?|) ))

(let ((prev `|.|))
  (defun see (symb)
    (let ((pair (assoc symb (gethash prev *words*))))
      (if (null pair)
          (push (cons symb 1) (gethash prev *words*))
          (incf (cdr pair))))
    (setf prev symb)))


(defun generate-text (n &optional (prev '|.|))
  (if (zerop n)
      (terpri)
      (let ((next (random-next prev)))
        (format t "~A " next)
        (generate-text (1- n) next))))

(defun random-next (prev)
  (let* ((choices (gethash prev *words*))
         (i (random (reduce #'+ choices 
                            :key #'cdr))))
    (dolist (pair choices)
      (if (minusp (decf i (cdr pair)))
          (return (car pair))))))


; *** num ***


(defun palindrome? (x)
 (let ((mid (/ (length x) 2)))
   (equal (subseq x 0 (floor mid))
          (reverse (subseq x (ceiling mid))))))


(defun sq (x) (* x x))

(defun mag (x y z)
  (sqrt (+ (sq x) (sq y) (sq z))))

(defun unit-vector (x y z)
  (let ((d (mag x y z)))
    (values (/ x d) (/ y d) (/ z d))))

(defstruct (point (:conc-name nil))  
  x y z)

(defun distance (p1 p2)
  (mag (- (x p1) (x p2))
       (- (y p1) (y p2))
       (- (z p1) (z p2))))

(defun minroot (a b c)
  (if (zerop a)
      (/ (- c) b)
      (let ((disc (- (sq b) (* 4 a c))))
        (unless (minusp disc)
          (let ((discrt (sqrt disc)))
            (min (/ (+ (- b) discrt) (* 2 a))
                 (/ (- (- b) discrt) (* 2 a))))))))


(defstruct surface  color)

(defparameter *world* nil)
(defconstant eye (make-point :x 0 :y 0 :z 200))

(defun tracer (pathname &optional (res 1))
  (with-open-file (p pathname :direction :output :if-exists :overwrite :if-does-not-exist :create)
    (format p "P2 ~A ~A 255" (* res 100) (* res 100))
    (let ((inc (/ res)))
      (do ((y -50 (+ y inc)))
          ((< (- 50 y) inc))
        (do ((x -50 (+ x inc)))
            ((< (- 50 x) inc))
          (print (color-at x y) p))))))

(defun color-at (x y)
  (multiple-value-bind (xr yr zr) 
                       (unit-vector (- x (x eye))
                                    (- y (y eye))
                                    (- 0 (z eye)))
    (round (* (sendray eye xr yr zr) 255))))

(defun sendray (pt xr yr zr)
  (multiple-value-bind (s int) (first-hit pt xr yr zr)
    (if s
        (* (lambert s int xr yr zr) (surface-color s))
        0)))

(defun first-hit (pt xr yr zr)
  (let (surface hit dist)
    (dolist (s *world*)
      (let ((h (intersect s pt xr yr zr)))
        (when h
          (let ((d (distance h pt)))
            (when (or (null dist) (< d dist))
              (setf surface s hit h dist d))))))
    (values surface hit)))

(defun lambert (s int xr yr zr)
  (multiple-value-bind (xn yn zn) (normal s int)
    (max 0 (+ (* xr xn) (* yr yn) (* zr zn)))))


(defstruct (sphere (:include surface))  
  radius center)

(defun defsphere (x y z r c)
  (let ((s (make-sphere 
             :radius r
             :center (make-point :x x :y y :z z)
             :color  c)))
    (push s *world*)
    s))

(defun intersect (s pt xr yr zr)
  (funcall (typecase s (sphere #'sphere-intersect))
           s pt xr yr zr))

(defun sphere-intersect (s pt xr yr zr)
  (let* ((c (sphere-center s))
         (n (minroot (+ (sq xr) (sq yr) (sq zr))
                     (* 2 (+ (* (- (x pt) (x c)) xr)
                             (* (- (y pt) (y c)) yr)
                             (* (- (z pt) (z c)) zr)))
                     (+ (sq (- (x pt) (x c)))
                        (sq (- (y pt) (y c)))
                        (sq (- (z pt) (z c)))
                        (- (sq (sphere-radius s)))))))
    (if n
        (make-point :x  (+ (x pt) (* n xr))
                    :y  (+ (y pt) (* n yr))
                    :z  (+ (z pt) (* n zr))))))

(defun normal (s pt)
  (funcall (typecase s (sphere #'sphere-normal))
           s pt))

(defun sphere-normal (s pt)
  (let ((c (sphere-center s)))
    (unit-vector (- (x c) (x pt))
                 (- (y c) (y pt))
                 (- (z c) (z pt)))))


(defun ray-test (&optional (res 1))
  (setf *world* nil)
  (defsphere 0 -300 -1200 200 .8)
  (defsphere -80 -150 -1200 200 .4)
  (defsphere 70 -100 -1200 200 .9)
  (do ((x -2 (1+ x)))
      ((> x 2))
    (do ((z 2 (1+ z)))
        ((> z 7))
      (defsphere (* x 200) 300 (* z -400) 40 .75)))
  (time (tracer (make-pathname :name "spheres.pgm") res)))


; *** mac ***


(defmacro nil! (x)
  `(setf ,x nil))


(defmacro while (test &rest body)
  `(do ()
       ((not ,test))
     ,@body))


(defun quicksort (vec l r)
  (let ((i l) 
        (j r) 
        (p (svref vec (round (+ l r) 2))))    ; 1
    (while (<= i j)                           ; 2
      (while (< (svref vec i) p) (incf i))
      (while (> (svref vec j) p) (decf j))
      (when (<= i j)
        (rotatef (svref vec i) (svref vec j))
        (incf i)
        (decf j)))
    (if (> (- j l) 1) (quicksort vec l j))    ; 3
    (if (> (- r i) 1) (quicksort vec i r)))
  vec)


(defmacro ntimes (n &rest body)
  (let ((g (gensym))
        (h (gensym)))
    `(let ((,h ,n))
       (do ((,g 0 (+ ,g 1)))
           ((>= ,g ,h))
         ,@body))))


(define-modify-macro append1f (val)
  (lambda (lst val) (append lst (list val))))


(defmacro for (var start stop &body body)
  (let ((gstop (gensym)))
    `(do ((,var ,start (1+ ,var))
          (,gstop ,stop))
         ((> ,var ,gstop))
       ,@body)))

(defmacro in (obj &rest choices)
  (let ((insym (gensym)))
    `(let ((,insym ,obj))
       (or ,@(mapcar #'(lambda (c) `(eql ,insym ,c))
                     choices)))))

(defmacro random-choice (&rest exprs)
  `(case (random ,(length exprs))
     ,@(let ((key -1))
         (mapcar #'(lambda (expr)
                     `(,(incf key) ,expr))
                 exprs))))

(defmacro avg (&rest args)
  `(/ (+ ,@args) ,(length args)))

(defmacro with-gensyms (syms &body body)
  `(let ,(mapcar #'(lambda (s)
                     `(,s (gensym)))
                 syms)
     ,@body))

(defmacro aif (test then &optional else)
  `(let ((it ,test))
     (if it ,then ,else)))


; *** mod ***


(defun make-queue () (cons nil nil))

(defun enqueue (obj q)
  (if (null (car q))
      (setf (cdr q) (setf (car q) (list obj)))
      (setf (cdr (cdr q)) (list obj)
            (cdr q) (cdr (cdr q))))
  (car q))

(defun dequeue (q) 
  (pop (car q)))


(defun mappend (fn &rest lsts)
  (apply #'append (apply #'mapcar fn lsts)))


(defun bst-insert! (obj bst <)
  (if (null bst)
      (make-node :elt obj)
      (progn (bsti obj bst <)
             bst)))

(defun bsti (obj bst <)
  (let ((elt (node-elt bst)))
    (if (eql obj elt)
        bst
        (if (funcall < obj elt)
            (let ((l (node-l bst)))
              (if l
                  (bsti obj l <)
                  (setf (node-l bst) 
                        (make-node :elt obj))))
            (let ((r (node-r bst)))
              (if r
                  (bsti obj r <)
                  (setf (node-r bst) 
                        (make-node :elt obj))))))))

; >>> Replaces bst-delete from book, which was broken.

(defun bst-delete (obj bst <)
  (if (null bst)
      nil       
      (if (eql obj (node-elt bst))
          (del-root bst)
          (progn
            (if (funcall < obj (node-elt bst))
                (setf (node-l bst) (bst-delete obj (node-l bst) <))
                (setf (node-r bst) (bst-delete obj (node-r bst) <)))
            bst)))) 
  
(defun del-root (bst)
  (let ((l (node-l bst)) (r (node-r bst)))
    (cond ((null l) r)
          ((null r) l)
          (t        (if (zerop (random 2))
                        (cutnext r bst nil)
                        (cutprev l bst nil))))))

(defun cutnext (bst root prev)
  (if (node-l bst)
      (cutnext (node-l bst) root bst)
      (if prev
          (progn
            (setf (node-elt root) (node-elt bst)
                  (node-l prev)   (node-r bst))
            root)
          (progn
            (setf (node-l bst)    (node-l root))
            bst))))

(defun cutprev (bst root prev)
  (if (node-r bst)
      (cutprev (node-r bst) root bst)
      (if prev
          (progn
            (setf (node-elt root) (node-elt bst)
                  (node-r prev)   (node-l bst))
            root)
          (progn
            (setf (node-r bst)    (node-r root))
            bst))))

(defun replace-node (old new)
  (setf (node-elt old) (node-elt new)
        (node-l   old) (node-l   new)
        (node-r   old) (node-r   new)))

(defun cutmin (bst par dir)
  (if (node-l bst)
      (cutmin (node-l bst) bst :l)
      (progn
        (set-par par dir (node-r bst))
        (node-elt bst))))

(defun cutmax (bst par dir)
  (if (node-r bst)
      (cutmax (node-r bst) bst :r)
      (progn
        (set-par par dir (node-l bst))
        (node-elt bst))))

(defun set-par (par dir val)
  (case dir
    (:l (setf (node-l par) val))
    (:r (setf (node-r par) val))))


(defstruct (dl (:print-function print-dl))
  prev data next)

(defun print-dl (dl stream depth)
  (declare (ignore depth))
  (format stream "#<DL ~A>" (dl->list dl)))

(defun dl->list (lst)
  (if (dl-p lst)
      (cons (dl-data lst) (dl->list (dl-next lst)))
      lst))

(defun dl-insert (x lst)
  (let ((elt (make-dl :data x :next lst)))
    (when (dl-p lst)
      (if (dl-prev lst)
          (setf (dl-next (dl-prev lst)) elt
                (dl-prev elt) (dl-prev lst)))
      (setf (dl-prev lst) elt))
    elt))

(defun dl-list (&rest args)
  (reduce #'dl-insert args
          :from-end t :initial-value nil))

(defun dl-remove (lst)
  (if (dl-prev lst)
      (setf (dl-next (dl-prev lst)) (dl-next lst)))
  (if (dl-next lst)
      (setf (dl-prev (dl-next lst)) (dl-prev lst)))
  (dl-next lst))


(defun circular (lst)
  (setf (cdr (last lst)) lst))


; *** speed ***


(defun length/tr (lst)
  (labels ((len (lst acc)
             (if (null lst)
                 acc
                 (len (cdr lst) (1+ acc)))))
    (len lst 0)))


(setf a (make-array '(1000 1000)
                    :element-type 'single-float
                    :initial-element 1.0s0))

(defun sum-elts (a)
  (declare (type (simple-array single-float (1000 1000)) 
                 a))
  (let ((sum 0.0s0))
    (declare (type single-float sum))
    (dotimes (r 1000)
      (dotimes (c 1000)
        (incf sum (aref a r c))))
    sum))


(defconstant dict (make-array 25000 :fill-pointer 0))

(defun read-words (from)
  (setf (fill-pointer dict) 0)
  (with-open-file (in from :direction :input)
    (do ((w (read-line in nil :eof)
            (read-line in nil :eof)))
        ((eql w :eof))
      (vector-push w dict))))

(defun xform (fn seq) (map-into seq fn seq))

(defun write-words (to)
  (with-open-file (out to :direction :output
                          :if-exists :supersede)
    (map nil #'(lambda (x)
                 (fresh-line out)
                 (princ x out))
             (xform #'nreverse
                    (sort (xform #'nreverse dict)
                          #'string<)))))


(defparameter *harbor* nil)

(defstruct ship 
  name flag tons)

(defun enter (n f d)
  (push (make-ship :name n :flag f :tons d)
        *harbor*))

(defun find-ship (n)
  (find n *harbor* :key #'ship-name))

(defun leave (n)
  (setf *harbor* 
        (delete (find-ship n) *harbor*)))


(defconstant pool (make-array 1000 :fill-pointer t))

(dotimes (i 1000) 
  (setf (aref pool i) (make-ship)))

(defconstant harbor (make-hash-table :size 1100 
                                     :test #'eq))

(defun enter (n f d)
  (let ((s (if (plusp (length pool))
               (vector-pop pool)
               (make-ship))))
    (setf (ship-name s)        n
          (ship-flag s)        f
          (ship-tons s)        d
          (gethash n harbor) s)))

(defun find-ship (n) (gethash n harbor))

(defun leave (n)
  (let ((s (gethash n harbor)))
    (remhash n harbor)
    (vector-push s pool)))


; *** web ***


(defmacro as (tag content)
  `(format t "<~(~A~)>~A</~(~A~)>" 
             ',tag ,content ',tag))

(defmacro with (tag &rest body)
  `(progn
     (format t "~&<~(~A~)>~%" ',tag)
     ,@body
     (format t "~&</~(~A~)>~%" ',tag)))

(defun brs (&optional (n 1))
  (fresh-line)
  (dotimes (i n)
    (princ "<br>"))
  (terpri))


(defun html-file (base)
  (format nil "~(~A~).html" base))

(defmacro page (name title &rest body)
  (let ((ti (gensym)))
    `(with-open-file (*standard-output*
                      (html-file ,name)
                      :direction :output
                      :if-exists :supersede)
       (let ((,ti ,title))
         (as title ,ti)
         (with center
           (as h2 (string-upcase ,ti)))
         (brs 3)
         ,@body))))


(defmacro with-link (dest &rest body)
  `(progn
     (format t "<a href=\"~A\">" (html-file ,dest))
     ,@body
     (princ "</a>")))

(defun link-item (dest text)
  (princ "<li>")
  (with-link dest
    (princ text)))

(defun button (dest text)
  (princ "[ ")
  (with-link dest
    (princ text))
  (format t " ]~%"))


(defun map3 (fn lst)
  (labels ((rec (curr prev next left)
             (funcall fn curr prev next)
             (when left
               (rec (car left) 
                    curr 
                    (cadr left) 
                    (cdr left)))))
    (when lst
      (rec (car lst) nil (cadr lst) (cdr lst)))))


(defparameter *sections* nil)

(defstruct item
  id title text)

(defstruct section
  id title items)

(defmacro defitem (id title text)
  `(setf ,id
         (make-item :id     ',id
                    :title  ,title
                    :text   ,text)))

(defmacro defsection (id title &rest items)
  `(setf ,id
         (make-section :id    ',id
                       :title ,title
                       :items (list ,@items))))

(defun defsite (&rest sections)
  (setf *sections* sections))


(defconstant contents "contents")
(defconstant index    "index")

(defun gen-contents (&optional (sections *sections*))
  (page contents contents
    (with ol
      (dolist (s sections)
        (link-item (section-id s) (section-title s))
        (brs 2))
      (link-item index (string-capitalize index)))))

(defun gen-index (&optional (sections *sections*))
  (page index index
    (with ol
      (dolist (i (all-items sections))
        (link-item (item-id i) (item-title i))
        (brs 2)))))

(defun all-items (sections)
  (let ((is nil))
    (dolist (s sections)
      (dolist (i (section-items s))
        (setf is (merge 'list (list i) is #'title<))))
    is))

(defun title< (x y)
  (string-lessp (item-title x) (item-title y)))


(defun gen-site ()
  (map3 #'gen-section *sections*)
  (gen-contents)
  (gen-index))

(defun gen-section (sect <sect sect>)
  (page (section-id sect) (section-title sect)
    (with ol
      (map3 #'(lambda (item <item item>)
                (link-item (item-id item)
                           (item-title item))
                (brs 2)
                (gen-item sect item <item item>))
            (section-items sect)))
    (brs 3)
    (gen-move-buttons (if <sect (section-id <sect))
                      contents
                      (if sect> (section-id sect>)))))

(defun gen-item (sect item <item item>)
  (page (item-id item) (item-title item)
    (princ (item-text item))
    (brs 3)
    (gen-move-buttons (if <item (item-id <item))
                      (section-id sect)
                      (if item> (item-id item>)))))

(defun gen-move-buttons (back up forward)
  (if back (button back "Back"))
  (if up (button up "Up"))
  (if forward (button forward "Forward")))


; *** inf ***


(defun match (x y &optional binds)
  (cond 
   ((eql x y) (values binds t))
   ((assoc x binds) (match (binding x binds) y binds))
   ((assoc y binds) (match x (binding y binds) binds))
   ((var? x) (values (cons (cons x y) binds) t))
   ((var? y) (values (cons (cons y x) binds) t))
   (t
    (when (and (consp x) (consp y))
      (multiple-value-bind (b2 yes) 
                           (match (car x) (car y) binds)
        (and yes (match (cdr x) (cdr y) b2)))))))

(defun var? (x)
  (and (symbolp x) 
       (eql (char (symbol-name x) 0) #\?)))

(defun binding (x binds)
  (let ((b (assoc x binds)))
    (if b
        (or (binding (cdr b) binds)
            (cdr b)))))


(defvar *rules* (make-hash-table))

(defmacro <- (con &optional ant)
  `(length (push (cons (cdr ',con) ',ant)
                 (gethash (car ',con) *rules*))))


(defun prove (expr &optional binds)
  (case (car expr)
    (and (prove-and (reverse (cdr expr)) binds))
    (or  (prove-or (cdr expr) binds))
    (not (prove-not (cadr expr) binds))
    (t   (prove-simple (car expr) (cdr expr) binds))))

(defun prove-simple (pred args binds)
  (mapcan #'(lambda (r)
              (multiple-value-bind (b2 yes) 
                                   (match args (car r) 
                                          binds)
                (when yes
                  (if (cdr r) 
                      (prove (cdr r) b2) 
                      (list b2)))))
          (mapcar #'change-vars 
                  (gethash pred *rules*))))

(defun change-vars (r)
  (sublis (mapcar #'(lambda (v) (cons v (gensym "?")))
                  (vars-in r))
          r))

(defun vars-in (expr)
  (if (atom expr)
      (if (var? expr) (list expr))
      (union (vars-in (car expr))
             (vars-in (cdr expr)))))


(defun prove-and (clauses binds)
  (if (null clauses)
      (list binds)
      (mapcan #'(lambda (b)
                  (prove (car clauses) b))
              (prove-and (cdr clauses) binds))))

(defun prove-or (clauses binds)
  (mapcan #'(lambda (c) (prove c binds))
          clauses))

(defun prove-not (clause binds)
  (unless (prove clause binds)
    (list binds)))


(defmacro with-answer (query &body body)
  (let ((binds (gensym)))
    `(dolist (,binds (prove ',query))
       (let ,(mapcar #'(lambda (v)
                         `(,v (binding ',v ,binds)))
                     (vars-in query))
         ,@body))))


; *** ob ***


(defmacro parents (v) `(svref ,v 0))
(defmacro layout (v) `(the simple-vector (svref ,v 1)))
(defmacro preclist (v) `(svref ,v 2))
 
(defmacro class (&optional parents &rest props)
  `(class-fn (list ,@parents) ',props))
 
(defun class-fn (parents props)
  (let* ((all (union (inherit-props parents) props))
         (obj (make-array (+ (length all) 3)
                          :initial-element :nil)))
    (setf (parents obj)  parents
          (layout obj)   (coerce all 'simple-vector)
          (preclist obj) (precedence obj))
    obj))
 
(defun inherit-props (classes)
  (delete-duplicates
    (mapcan #'(lambda (c)
                (nconc (coerce (layout c) 'list)
                       (inherit-props (parents c))))
            classes)))
 
(defun precedence (obj)
  (labels ((traverse (x)
             (cons x
                   (mapcan #'traverse (parents x)))))
    (delete-duplicates (traverse obj))))

(defun inst (parent)
  (let ((obj (copy-seq parent)))
    (setf (parents obj)  parent 
          (preclist obj) nil)
    (fill obj :nil :start 3)
    obj))


;(declaim (inline lookup (setf lookup)))

(defun rget (prop obj next?)
  (let ((prec (preclist obj)))
    (if prec
        (dolist (c (if next? (cdr prec) prec) :nil)
          (let ((val (lookup prop c)))
            (unless (eq val :nil) (return val))))
        (let ((val (lookup prop obj)))
          (if (eq val :nil)
              (rget prop (parents obj) nil)
              val)))))

(defun lookup (prop obj)
  (let ((off (position prop (layout obj) :test #'eq)))
    (if off (svref obj (+ off 3)) :nil)))
 
(defun (setf lookup) (val prop obj)
  (let ((off (position prop (layout obj) :test #'eq)))
    (if off
        (setf (svref obj (+ off 3)) val)
        (error "Can't set ~A of ~A." val obj))))


(declaim (inline run-methods))

(defmacro defprop (name &optional meth?)
  `(progn
     (defun ,name (obj &rest args)
       ,(if meth?
            `(run-methods obj ',name args)
            `(rget ',name obj nil)))
     (defun (setf ,name) (val obj)
       (setf (lookup ',name obj) val))))
 
(defun run-methods (obj name args)
  (let ((meth (rget name obj nil)))
    (if (not (eq meth :nil))
        (apply meth obj args)
        (error "No ~A method for ~A." name obj))))
 
(defmacro defmeth (name obj parms &rest body)
  (let ((gobj (gensym)))
    `(let ((,gobj ,obj))
       (defprop ,name t)
       (setf (lookup ',name ,gobj)
             (labels ((next () (rget ,gobj ',name t)))
               #'(lambda ,parms ,@body))))))


; *** adv ***


(defun copy-file (from to)
  (with-open-file (in from :direction :input
                           :element-type 'unsigned-byte)
    (with-open-file (out to :direction :output
                            :element-type 'unsigned-byte)
      (do ((i (read-byte in nil -1)
              (read-byte in nil -1)))
          ((minusp i))
        (declare (fixnum i))
        (write-byte i out)))))


(set-dispatch-macro-character #\# #\?
  #'(lambda (stream char1 char2)
      (list 'quote
            (let ((lst nil))
              (dotimes (i (+ (read stream t nil t) 1))
                (push i lst))
              (nreverse lst)))))


(set-macro-character #\} (get-macro-character #\)))

(set-dispatch-macro-character #\# #\{
  #'(lambda (stream char1 char2)
      (let ((accum nil)
            (pair (read-delimited-list #\} stream t)))
        (do ((i (car pair) (+ i 1)))
            ((> i (cadr pair))
             (list 'quote (nreverse accum)))
          (push i accum)))))


(defun even/odd (ns)
  (loop for n in ns
        if (evenp n) 
           collect n into evens
           else collect n into odds
        finally (return (values evens odds))))


(defun user-input (prompt)
  (format t prompt)
  (let ((str (read-line)))
    (or (ignore-errors (read-from-string str))
        nil)))



; *** notes ***


(defun float-limits ()
  (dolist (m '(most least))
    (dolist (s '(positive negative))
      (dolist (f '(short single double long))
        (let ((n (intern (string-upcase
                           (format nil "~A-~A-~A-float" 
                                         m  s  f)))))
          (format t "~30A ~A~%" n (symbol-value n)))))))


(defmacro bst-push (obj bst <)
  (multiple-value-bind (vars forms var set access)
                       (get-setf-expansion bst)
    (let ((g (gensym)))
      `(let* ((,g ,obj)
              ,@(mapcar #'list vars forms)
              (,(car var) (bst-insert! ,g ,access ,<)))
         ,set))))


(defmacro with-type (type expr)
  `(the ,type ,(if (atom expr) 
                   expr
                   (expand-call type (binarize expr)))))

(defun expand-call (type expr)
  `(,(car expr) ,@(mapcar #'(lambda (a) 
                              `(with-type ,type ,a))
                          (cdr expr))))

(defun binarize (expr)
  (if (and (nthcdr 3 expr)
           (member (car expr) '(+ - * /)))
      (destructuring-bind (op a1 a2 . rest) expr
        (binarize `(,op (,op ,a1 ,a2) ,@rest)))
      expr))


(defmacro with-slotref ((name prop class) &rest body)
  (let ((g (gensym)))
    `(let ((,g (+ 3 (position ,prop (layout ,class) 
                              :test #'eq)))) 
       (macrolet ((,name (obj) `(svref ,obj ,',g)))
         ,@body))))


(defun eval2 (expr)
  (case (and (consp expr) (car expr))
    (comma (error "unmatched comma"))
    (bq    (eval-bq (second expr) 1))
    (t     (eval expr))))

(defun eval-bq (expr n)
  (cond ((atom expr)
         expr)
        ((eql (car expr) 'comma)
         (if (= n 1)
             (eval2 (second expr))
             (list 'comma (eval-bq (second expr)
                                   (1- n)))))
        ((eql (car expr) 'bq)
         (list 'bq (eval-bq (second expr) (1+ n))))
        (t
         (cons (eval-bq (car expr) n)
               (eval-bq (cdr expr) n)))))


; *** lib ***


(defun -abs (n) 
  (if (typep n 'complex)
      (sqrt (+ (expt (realpart n) 2) (expt (imagpart n) 2)))
      (if (< n 0) (- n) n)))

(defun -adjoin (obj lst &rest args)
  (if (apply #'member obj lst args) lst (cons obj lst)))
(defmacro -and (&rest args)
  (cond ((null args) t)
        ((cdr args)  `(if ,(car args) (-and ,@(cdr args))))
        (t           (car args))))

(defun -append (&optional first &rest rest)
  (if (null rest) 
      first
      (nconc (copy-list first) (apply #'-append rest))))

(defun -atom (x) (not (consp x)))

(defun -butlast (lst &optional (n 1))
  (nreverse (nthcdr n (reverse lst))))

(defun -cadr (x) (car (cdr x)))

(defmacro -case (arg &rest clauses)
  (let ((g (gensym)))
    `(let ((,g ,arg))
       (cond ,@(mapcar #'(lambda (cl)
                           (let ((k (car cl)))
                             `(,(cond ((member k '(t otherwise))
                                       t)
                                      ((consp k)
                                       `(member ,g ',k))
                                      (t `(eql ,g ',k)))
                               (progn ,@(cdr cl)))))
                       clauses)))))

(defun -cddr (x) (cdr (cdr x)))

(defun -complement (fn)
  #'(lambda (&rest args) (not (apply fn args))))

(defmacro -cond (&rest args)
  (if (null args)
      nil
      (let ((clause (car args)))
        (if (cdr clause)
            `(if ,(car clause)
                 (progn ,@(cdr clause))
                 (-cond ,@(cdr args)))
            `(or ,(car clause)
                 (-cond ,@(cdr args)))))))

(defun -consp (x) (typep x 'cons))

(defun -constantly (x) #'(lambda (&rest args) x))

(defun -copy-list (lst)
  (labels ((cl (x)
             (if (atom x)
                 x
                 (cons (car x) 
                       (cl (cdr x))))))
    (cons (car lst) 
          (cl (cdr lst)))))

(defun -copy-tree (tr)
  (if (atom tr)
      tr
      (cons (-copy-tree (car tr))
            (-copy-tree (cdr tr)))))

(defmacro -defun (name parms &rest body)
  (multiple-value-bind (dec doc bod) (analyze-body body)
    `(progn
       (setf (fdefinition ',name)
             #'(lambda ,parms 
                 ,@dec
                 (block ,(if (atom name) name (second name))
                   ,@bod))
             (documentation ',name 'function)
             ,doc)
       ',name)))

(defun analyze-body (body &optional dec doc)
  (let ((expr (car body)))
    (cond ((and (consp expr) (eq (car expr) 'declare))
           (analyze-body (cdr body) (cons expr dec) doc))
          ((and (stringp expr) (not doc) (cdr body))
           (if dec
               (values dec expr (cdr body))
               (analyze-body (cdr body) dec expr)))
          (t (values dec doc body)))))






; This definition is not strictly correct; see let.

(defmacro -do (binds (test &rest result) &rest body)
  (let ((fn (gensym)))
    `(block nil
       (labels ((,fn ,(mapcar #'car binds)
                   (cond (,test ,@result)
                         (t (tagbody ,@body)
                            (,fn ,@(mapcar #'third binds))))))
         (,fn ,@(mapcar #'second binds))))))

(defmacro -dolist ((var lst &optional result) &rest body)
  (let ((g (gensym)))
    `(do ((,g ,lst (cdr ,g)))
         ((atom ,g) (let ((,var nil)) ,result))
       (let ((,var (car ,g)))
         ,@body))))

(defun -eql (x y)
  (typecase x
    (character (and (typep y 'character) (char= x y)))
    (number    (and (eq (type-of x) (type-of y))
                    (= x y))) 
    (t         (eq x y))))

(defun -evenp (x) 
  (typecase x
    (integer (= 0 (mod x 2)))
    (t       (error "non-integer argument"))))

(defun -funcall (fn &rest args) (apply fn args))

(defun -identity (x) x)

; This definition is not strictly correct: the expression
; (let ((&key 1) (&optional 2))) is legal, but its expansion
; is not.

(defmacro -let (parms &rest body)
  `((lambda ,(mapcar #'(lambda (x)
                         (if (atom x) x (car x)))
                     parms)
      ,@body)
    ,@(mapcar #'(lambda (x) 
                  (if (atom x) nil (cadr x)))
              parms)))
(defun -list (&rest elts) (copy-list elts))

(defun -listp (x) (or (consp x) (null x)))

(defun -mapcan (fn &rest lsts)
  (apply #'nconc (apply #'mapcar fn lsts)))

(defun -mapcar (fn &rest lsts)
  (cond ((member nil lsts) nil)
        ((null (cdr lsts))
         (let ((lst (car lsts)))
           (cons (funcall fn (car lst))
                 (-mapcar fn (cdr lst)))))
        (t
         (cons (apply fn (-mapcar #'car lsts))
               (apply #'-mapcar fn
                      (-mapcar #'cdr lsts))))))

(defun -member (x lst &key test test-not key)
  (let ((fn (or test
                (if test-not
                    (complement test-not))
                    #'eql)))
    (member-if #'(lambda (y)
                   (funcall fn x y))
               lst
               :key key)))

(defun -member-if (fn lst &key (key #'identity))
  (cond ((atom lst) nil)
        ((funcall fn (funcall key (car lst))) lst)
        (t (-member-if fn (cdr lst) :key key))))

(defun -mod (n m)
  (nth-value 1 (floor n m)))

(defun -nconc (&optional lst &rest rest)
  (if rest
      (let ((rest-conc (apply #'-nconc rest)))
        (if (consp lst)
            (progn (setf (cdr (last lst)) rest-conc) 
                   lst)
            rest-conc))
      lst))

(defun -not (x) (eq x nil))
(defun -nreverse (seq)
  (labels ((nrl (lst)
             (let ((prev nil))
               (do ()
                   ((null lst) prev)
                 (psetf (cdr lst) prev
                        prev      lst
                        lst       (cdr lst)))))
           (nrv (vec)
             (let* ((len (length vec))
                    (ilimit (truncate (/ len 2))))
               (do ((i 0 (1+ i))
                    (j (1- len) (1- j)))
                   ((>= i ilimit) vec)
                 (rotatef (aref vec i) (aref vec j))))))
    (if (typep seq 'vector)
        (nrv seq)
        (nrl seq))))

(defun -null (x) (eq x nil))

(defmacro -or (&optional first &rest rest)
  (if (null rest)
      first
      (let ((g (gensym)))
        `(let ((,g ,first))
           (if ,g 
               ,g 
               (-or ,@rest))))))

; Not in CL, but needed in several definitions here.

(defun pair (lst)
  (if (null lst)
      nil
      (cons (cons (car lst) (cadr lst))
            (pair (cddr lst)))))

(defun -pairlis (keys vals &optional alist) 
  (unless (= (length keys) (length vals))
    (error "mismatched lengths"))
  (nconc (mapcar #'cons keys vals) alist))




(defmacro -pop (place)
  (multiple-value-bind (vars forms var set access)
                       (get-setf-expansion place)
    (let ((g (gensym)))
      `(let* (,@(mapcar #'list vars forms)
              (,g ,access)
              (,(car var) (cdr ,g)))
         (prog1 (car ,g)
                ,set)))))

(defmacro -prog1 (arg1 &rest args)
  (let ((g (gensym)))
    `(let ((,g ,arg1))
       ,@args
       ,g)))

(defmacro -prog2 (arg1 arg2 &rest args)
  (let ((g (gensym)))
    `(let ((,g (progn ,arg1 ,arg2)))
       ,@args
       ,g)))

(defmacro -progn (&rest args) `(let nil ,@args))

(defmacro -psetf (&rest args)
  (unless (evenp (length args)) 
    (error "odd number of arguments"))
  (let* ((pairs (pair args))
         (syms (mapcar #'(lambda (x) (gensym)) 
                       pairs)))
    `(let ,(mapcar #'list
                   syms
                   (mapcar #'cdr pairs))
       (setf ,@(mapcan #'list
                       (mapcar #'car pairs)
                       syms)))))

(defmacro -push (obj place)
  (multiple-value-bind (vars forms var set access)
                       (get-setf-expansion place)
    (let ((g (gensym)))
      `(let* ((,g ,obj)
              ,@(mapcar #'list vars forms)
              (,(car var) (cons ,g ,access)))
         ,set))))
  
(defun -rem (n m)
  (nth-value 1 (truncate n m)))

(defmacro -rotatef (&rest args)
  `(psetf ,@(mapcan #'list
                    args
                    (append (cdr args) 
                            (list (car args))))))

(defun -second (x) (cadr x))

(defmacro -setf (&rest args)
  (if (null args)
      nil
      `(setf2 ,@args)))

(defmacro setf2 (place val &rest args)
  (multiple-value-bind (vars forms var set)
                       (get-setf-expansion place)
    `(progn
       (let* (,@(mapcar #'list vars forms)
              (,(car var) ,val))
         ,set)
       ,@(if args `((setf2 ,@args)) nil))))

(defun -signum (n) 
  (if (zerop n) 0 (/ n (abs n))))

(defun -stringp (x) (typep x 'string))

(defun -tailp (x y)
  (or (eql x y)
      (and (consp y) (-tailp x (cdr y)))))

(defun -third (x) (car (cdr (cdr x))))

(defun -truncate (n &optional (d 1))
  (if (> n 0) (floor n d) (ceiling n d)))

(defmacro -typecase (arg &rest clauses)
  (let ((g (gensym)))
    `(let ((,g ,arg))
       (cond ,@(mapcar #'(lambda (cl)
                           `((typep ,g ',(car cl)) 
                             (progn ,@(cdr cl))))
                       clauses)))))
(defmacro -unless (arg &rest body)
  `(if (not ,arg)
       (progn ,@body)))

(defmacro -when (arg &rest body)
  `(if ,arg (progn ,@body)))

(defun -1+ (x) (+ x 1))

(defun -1- (x) (- x 1))

(defun ->= (first &rest rest)
  (or (null rest)
      (and (or (> first (car rest)) (= first (car rest)))
           (apply #'->= rest))))


#+END_SRC

* Lisp
** [[/Users/Can/Develop/Lisp/init.cl][init]]
#+BEGIN_SRC lisp 
(format t "~&~%Welcome to Lisp 🌈  ~%~%")
;; (ql:quickload :cl-strings)
(ql:quickload :cl-ppcre)
(setf sb-impl::*default-external-format* :utf-8)
;; (setq *default-pathname-defaults* "/Users/Can/Develop/Lisp/")
(defun string-index (string string-list)
  "Return the index of string in a string list"           
  (position string string-list :test 'string=))


(defun path-end-with (path end)
  "Return the path end with someone"
  (let ((dirs (cl-ppcre:split "/" (namestring path))))
    (pathname
     (format nil "/~{~a~^/~}/" (subseq dirs 0 (+ 1 (string-index end dirs)))))))

(defconstant +source-root+ (path-end-with *default-pathname-defaults* "Lisp"))


(defun $rooted-path (name)
  (concatenate 'string (namestring +source-root+) name))

(defun $load-file (path-name)
  "Load the code in the source root"           
  (load ($rooted-path path-name)))

(defparameter *source-list* '())

(defun substringp (needle haystack &key (test 'char=))
  (search (string needle)
          (string haystack)
          :test test))

(defvar -load-count- 0)
(defun $load-directory (dir &optional (type "cl"))
  "Load the codes in a direcotry"           
  (let ((codes (directory (make-pathname :directory (namestring (truename ($rooted-path dir)))
				         :name :wild
				         :type type))))
    (push codes *source-list*)
    (incf -load-count-)
    (dolist (source codes)
      ;; (if (> -load-count- 1) (format t "~& 💥 Loading: ~A 💥~%" (pathname-name source)))
      (unless (or (substringp ".#" (namestring source))	; .#string.cl
                  (equal source *load-truename*))     ; don't load itself, or will go into infinite loop
        (load source)))))

($load-directory "mine/basic")
($load-file "mine/learn/hunchentoot.lisp")
;; ($load-directory "server" "lisp")
;; (format t "~%Initialized~%")



#+END_SRC

** [[/Users/Can/Develop/Lisp/info.cl][info]]
#+BEGIN_SRC lisp 
(asdf:defsystem ...)

(&allow-other-keys &aux 
&body &environment &key
sb-int:&more &optional
&rest &whole)

#+END_SRC

** [[/Users/Can/Develop/Lisp/tools.lisp][tools]]
#+BEGIN_SRC lisp 
(in-package :celwk)
;;; Example of use:  (ppmx (incf a))
(defmacro ppmx (form &optional (count 30))
  "Pretty prints the macro expansion of FORM."
  `(let* ((exp1 (macroexpand-1 ',form))
	      (exp (macroexpand exp1))
	      (*print-circle* nil))
     (cond ((equal exp exp1)
	        (output "~&Macro expansion: ~%~A" (wrapped-code exp "*" ,count)))
	       (t (output "~&First step of expansion:")
	          (pprint exp1)
	          (output "~%~%Final expansion:")
	          (pprint exp)))
     (output "~%~%")
     (values)))

(defparameter +day-names+
  '("Monday"
    "Tuesday"
    "Wednesday"
    "Thursday"
    "Friday"
    "Saturday"
    "Sunday"))
;; "~10a"  => padding left with Spaces
;; "~10@a" => padding right
(defvar max-length (apply #'max (mapcar #'length +day-names+)))
(defun local-time (second minute hour date month year day-of-week dst-p tz)
  (declare (ignore dst-p))
  (input "~2,'0d:~2,'0d:~2,'0d of ~a, ~2,'0d/~2,'0d/~d (GMT~@d)"
         hour
         minute
	     second
	     (input (concat "~" (write-to-string max-length) "@a") (nth day-of-week +day-names+))	;; padding right
         month
	     date
	     year
	     (- tz)))
;; time-zone 0
(defun time-of-universal (timestamp &key (from 1900))
  (apply #'local-time (multiple-value-list (decode-universal-time
                                            (+ timestamp (encode-universal-time 0 0 0 1 1 from 0))))))



(defun now ()
  (apply #'local-time (multiple-value-list (get-decoded-time))))

(defmacro timing (&body forms)
  (let ((real1 (gensym))
	    (real2 (gensym))
	    (run1 (gensym))
	    (run2 (gensym))
	    (result (gensym)))
    `(let* ((,real1 (get-internal-real-time))
	        (,run1 (get-internal-run-time))
	        (,result (progn ,@forms))
	        (,run2 (get-internal-run-time))
	        (,real2 (get-internal-real-time)))
	   (format *debug-io* ";;; Computation took:~%")
	   (format *debug-io* ";;;  ~f seconds of real time~%"
		       (/ (- ,real2 ,real1) internal-time-units-per-second))
	   (format t ";;;  ~f seconds of run time~%"
		       (/ (- ,run2 ,run1) internal-time-units-per-second))
	   ,result)))

(defmacro bound? (name)
  `(cond
     ((boundp  ',name) (funcall #'values t :value (when (fboundp ',name) :function)))
     ((fboundp ',name) (values t :function nil))
     (t (values nil nil))))



(defun org-code (code &key (type "lisp"))
  (format nil "#+BEGIN_SRC ~a ~%~a~%#+END_SRC~%" type code))

(defun build-orgs (&key (dir "mine") (suffixes '("lisp" "cl")) (type "lisp") (deep t))
  "Note: the path DIR is relative to the path when executing."
  (with-output-to-string (stream)
    (let* ((dirs (group-by (compose #'string-capitalize #'last* #'pathname-directory)
                           (files-with-suffix suffixes :dir dir :deep deep)
                           :out #'cons))
           (paths (sort dirs
                        (^(d1 d2) (string< (car d1) (car d2))))))

      (mapcan (^(folder)
                (let ((folder-name (car folder))
                      (files (cdr folder)))
                  (format stream "~&* ~a~%~{** [[~a][~a]]~%~a~%~}"
                          folder-name
                          (mapcan (^(file)
                                    (list file
                                          (pathname-name file)
                                          (org-code (read-file file) :type type)))
                                  files))))                        
              paths))))

(defun update-coding-org (&key (path "me/coding2") (dir "mine"))
  (unless (search ".org" path)
    (setf path (concat path ".org")))
  (write-to-file path (build-orgs :dir dir)))

(defun test ()
  (probe-file "mine"))


;; (write-to-file "./recipes.org" (build-orgs :dir "~/Books/LISP Books/Common Lisp Recipes-code"))


(defmacro vprint (&rest vars)
  "(vprint a b x):
 a: **
 b: **
 x: **"
  `(output "~@{~a: ~a~%~}"
           ,@(mapcan (^(x) `(',x ,x)) vars)))


;; (set-macro-character #\= (get-macro-character #\;)) => for copy the example code from LispWorkds
;; (set-macro-character #\= nil)	=> Cancel when your code includes '='

#+END_SRC

** [[/Users/Can/Develop/Lisp/string.lisp][string]]
#+BEGIN_SRC lisp 
(in-package :celwk)
(defmacro concats (&rest types)
  `(progn
     ,@(mapcar (^(type)
                 `(defun ,(read-from-string (input "concat-~s" type)) (&rest values)
                    (apply #'concatenate (cons ',type values))))
               types)))

(concats string list vector)
(alias concat concat-string)

(defun string-join (string-list &optional (seperator ""))
  "The list must consist of Strings"
  (let ((result (first string-list)))
	(dolist (string (rest string-list) result)
	  (setf result (concat-string result seperator string)))))

(defun string-repeat (string n)
  "Create a string repeated n times"
  (string-join (fill (make-list n) string)))

(defun string-of-code (code)
  "Return lowercase string from the code"
  (string-downcase (write-to-string code)))
;; write-to-string 		symbol => string
;; read-from-string  	string => symbol
;; (eval (read-from-string "(+ 1 2 3)"))  => 6
;; (equal '(+ 1 2 3) (read-from-string "(+ 1 2 3)"))  t

(defun wrapped-code (code &optional (seperator "=") (count 30))
  (input "~A~%~A~%~2:*~A"
         (string-repeat seperator count)
         (string-of-code code)))

(load-package :cl-ppcre)
(defun join (string-list
             &key (seperator " ") (out nil) (fn #'identity)              
             &aux (seperator (cl-ppcre:regex-replace-all "~" seperator "~~")))
  "Join the string list"           
  (format out
          (input "~~{~~A~~^~A~~}" seperator) (mapcar fn string-list)))

#+END_SRC

** [[/Users/Can/Develop/Lisp/stream.lisp][stream]]
#+BEGIN_SRC lisp 
(in-package :celwk)
(defmacro inspect-file ((var filename &key (byes '(bye end over)) (wait 0.3)) &body body)
  "Keep read a file, will invoke BODY when content added, one line a time.
 End when input keyword in BYES"
  (with-gensyms (bye)
    `(let (,bye)
       (sb-thread:make-thread (^()
                                ;; Wait for the byes keyword to end
                                ;; #.*standard-input* => eval at Compile time:
                                ;; #.(get-universal-time) will not change even inside a defun
                                ;; BUT, only return 1 value, multiple-value-list not work
                                (until (member (read #.*standard-input*) ',byes))                               
                                (setf ,bye t)))
       (with-open-file (fifo ,filename :if-does-not-exist :create)
         (do ((text ,@(repeat 2 '(read-line fifo nil nil))))
           ;; => ((text (read-line fifo nil nil) (read-line fifo nil nil)))
             (,bye)
           (if text 
               (let ((,var text))
                 ,@body)
               (sleep ,wait)))))))

#|
(defmacro keep-reading ((var filename &key (byes '(bye end over)) (wait 0.3)) &body body)
  "Keep read a file, will invoke body when content added"
  (with-gensyms (bye input output)
    `(let (,bye
           (,input *standard-input*)
           (,output *standard-output*))
       (sb-thread:make-thread #'(lambda (standard-input)
                                  (until 
                                   (member (read standard-input) ,byes)) ;; Or use ,input to replace another-input
                                  (setf ,bye t)
                                  (format ,output "Goodbye ~%")
                                  (princ "Bye!!"))
                              :arguments (list *standard-input*))
       (with-open-file (fifo ,filename :if-does-not-exist :create)
         (loop 
            (let ((text (read-line fifo nil nil)))
              (when ,bye
                (format t "~&It's over, guy ~%")
                (return (format nil "Goodbye ~a" (now))))
              (if text
                  (let ((,var text))
                    ,@body)
                  (sleep ,wait))))))))

|#

;; (inspect-file (text "stream.lisp" :byes (bye love)) 
;;              (output "~a: ~a~%" (now) text))

#+END_SRC

** [[/Users/Can/Develop/Lisp/start.lisp][start]]
#+BEGIN_SRC lisp 
(load "package.lisp")

(in-package :celwk)

(defvar *load-once-only* nil)
(defvar *loaded-codes* ())

(defun load-codes (codes &optional (dir "./"))		;; Do it in ASDF ?
  (dolist (code codes)
    (unless (and *load-once-only* (find code *loaded-codes* :test #'string=))
      (load (concatenate 'string dir code))
      (format t "~&~a" code)
      (pushnew code *loaded-codes*))))

(defparameter *codes*
  '("basic" "macro" 	"functional"	"shell"
    "list" 	"string" 	"stream" 		"file"
    "debug" "grammar" 	"tools"))

(load-codes *codes*)

;; To document the codes:
;; (write-to-file "coding.org" (build-orgs :dir "." :deep nil))

#+END_SRC

** [[/Users/Can/Develop/Lisp/shell.lisp][shell]]
#+BEGIN_SRC lisp 
(in-package :celwk)

(defun shell (cmd &key (output *standard-output*))
    #+clisp
        (let ((str (ext:run-shell-command cmd :output:stream)))
            (loop for line = (read-line str nil)
             until (null line)
             do (print line)))
    #+ecl 
        (si:system cmd)
    #+sbcl 
    ;; (sb-ext:run-program "/bin/sh" (list "-c" cmd) :input nil :output *standard-output*)
    (sb-ext:run-program "/bin/sh" (list "-c" cmd) :input nil :output output :search t)
    #+clozure 
        (ccl:run-program "/bin/sh" (list "-c" cmd) :input nil :output *standard-output*))

(defun cmd (cmd &optional (output t))
  "Use uiop:run-program"           
  (uiop:run-program cmd :output output :ignore-error-status t))
;; Set output to '(:string :stripped t) as string


(defun weplant (sql)
    (sb-ext:run-program "/usr/local/mysql/bin/mysql" `("-uroot" "weplant2" "-e" ,sql) :input nil :output *standard-output*))


(defun psql (sql)
    (sb-ext:run-program "/Library/PostgreSQL/11/bin/psql" `("-c" ,sql) :input nil :output *standard-output*))


;; SHELL environment:
;; WHO="Savior Can" sbcl
;; *
;; * (posix-getenv "WHO") => "Savior Can"
;; (sb-ext:posix-environ) . (sb-ext:posix-getenv name)	

(defun program-stream (program &optional args)
  (let ((process (sb-ext:run-program program args
                                     :input :stream
                                     :output :stream
                                     :wait nil
                                     :search t)))
    (when process
      (make-two-way-stream (sb-ext:process-output process)
                           (sb-ext:process-input process)))))

;; CL-USER> (defparameter *stream* (program-stream "bc"))	;; basic calculator
;; *STREAM*
;; CL-USER> (format *stream* "5 * 6 + 9")
;; NIL
;; CL-USER> (finish-output *stream*)       ; will hang without this
;; NIL
;; CL-USER> (read-line *stream*)
;; "39"
;; NIL
;; CL-USER> (close *stream*)
;; T


#+END_SRC

** [[/Users/Can/Develop/Lisp/package.lisp][package]]
#+BEGIN_SRC lisp 
(in-package :cl-user)
(defpackage :celwk
  (:use :cl)
  (:nicknames :can :mine)
  (:export
   :^ :cmd
   :desc :desc-var :mac :alias
   :output :input
   :concat :repeat
   :time-of-universal))

#+END_SRC

** [[/Users/Can/Develop/Lisp/make-notes.lisp][make-notes]]
#+BEGIN_SRC lisp 
(load "start")
(defun suffix-with? (string suffix &key (test 'eql))
  (let ((index (search suffix string :from-end t :test test)))
    (and index
         (= index (- (length string) (length suffix))))))

;; 'remove-if-not = (complement 'remove-if)

(defun files-with-suffix (suffixes &key (dir "mine"))
  (when (atom suffixes)
    (setf suffixes (list suffixes)))
  (unless dir
    (error "Please set :dir"))	; TODO: then read it?
  (mapcan (^(suffix)
            (remove-if (^(path)
                         (position #\. (pathname-name path)))	; (file-namestring path)
                       (directory (concat-string dir "/**/*." suffix))))
          suffixes))

(defun file-size (file)
  (with-open-file (in file :element-type '(unsigned-byte 8))
    (file-length in)))


(defun read-file (file &rest open-args)
  (with-open-stream (stream (apply 'open file open-args))
    (let* ((buffer (make-array (file-length stream)
                               :fill-pointer t
                               :element-type (stream-element-type stream)))
           (position (read-sequence buffer stream)))
      (setf (fill-pointer buffer) position)	;; Remove the end irrelevant chars
      buffer)))

(defun write-to-file (file data &key (readonly t))
  (with-open-file (stream file
                          :direction :output
                          :if-exists :supersede
                          :if-does-not-exist :create)
    (write-sequence data stream))
  (cmd (format nil "chmod a-w ~a" file))
  (values))

(defun org-code (code &key (type "lisp"))
  (format nil "#+BEGIN_SRC ~a ~%~a~%#+END_SRC~%" type code))

(defun last* (lst)
  (car (last lst)))


(defun group-by (fn lst &key (test 'equal))
  (let ((hash (make-hash-table :test test)))
    (mapc (^(item)
            (let ((key (funcall fn item)))
              (unless (gethash key hash)
                (setf (gethash key hash) ()))
              (push item (gethash key hash))))
          lst)
    (loop for k being the hash-keys in hash using (hash-value v)
       collect (cons k v))))

(defun build-orgs (&key (dir "mine") (suffixes '("lisp" "cl")) (type "lisp"))
  (with-output-to-string (stream)
    (let* ((dirs (group-by (compose 'string-capitalize 'last* 'pathname-directory)
                           (files-with-suffix suffixes :dir dir)))
           (paths (sort dirs
                        (^(d1 d2) (string< (car d1) (car d2))))))

      (mapcan (^(folder)
                (let ((folder-name (car folder))
                      (files (cdr folder)))
                  (format stream "~&* ~a~%~{** [[~a][~a]]~%~a~%~}"
                          folder-name
                          (mapcan (^(file) (list file
                                                 (pathname-name file)
                                                 (org-code (read-file file) :type type)))
                                  files))))                        
              paths))))

;; (subseq paths 0 5)

;; (write-to-file "./test.lisp" (build-orgs))
;; (write-to-file "./emacs.org" (build-orgs :dir "~/Emacs/mine" :suffixes '("el") :type "elisp"))
(write-to-file "./recipes.org" (build-orgs :dir "~/Books/LISP Books/Common Lisp Recipes-code"))




#+END_SRC

** [[/Users/Can/Develop/Lisp/macro.lisp][macro]]
#+BEGIN_SRC lisp 
(in-package :celwk)

(defmacro with-gensyms ((&rest syms) &body body)
  "(&rest syms) equals to syms
 Just make it more readable, it should be a list"
  `(let ,(loop for n in syms collect `(,n (gensym)))
     ,@body))

;; (defmacro with-gensyms (syms &body body)
;;   `(let ,(mapcar #'(lambda (s) `(,s (gensym))) syms)
;;      ,@body))

(defmacro until (test &rest body)
  `(do ()
       (,test)
     ,@body))

(defmacro while (test &rest body)
  `(until (not ,test) ,@body))

;; (defmacro while (condition &body body)
;;   `(loop
;;       (unless ,condition (return))
;;       ,@body))

(defun symbol-key (sysb-or-string)
  "(symbol-key \"can\") => :can "
  (read-from-string (input ":~a" sysb-or-string)))
(defun key-symbol (key)
  (read-from-string (subseq (write-to-string key) 1)))


;; Create #'fn & fn at the same time
(defmacro defun+ (fn (&rest args) &body body)
  `(progn
     (defun ,fn (,@args)
       ,@body)
     (defparameter ,fn #',fn)))


(defmacro tif (test then &optional else)
  "Auto save the TEST result to `it'"
  `(let ((it ,test))
     (if it ,then ,else)))
;; (tif (gethash xx yy)
;;      (output it))


(defmacro for (var start stop &body body)
  "(for n 1 10 (output \"Current: ~a~%\" n)) => INCLUDING 1 and 10"
  (with-gensyms (gstop)
    `(do ((,var ,start (1+ ,var))
          (,gstop ,stop))
         ((> ,var ,gstop))
       ,@body)))

(defmacro in (obj &rest choices)
  "So no need to eval every choice, stop as soon as found"
  (let ((insym (gensym)))
    `(let ((,insym ,obj))
       (or ,@(mapcar (^(c) `(eql ,insym ,c))
                     choices)))))

(defmacro random-choice (&rest exprs)
  "Similar as above, no need to eval every one, can't do it with function"
  `(case (random ,(length exprs))
     ,@(let ((key -1))
         (mapcar (^(expr)
                   `(,(incf key) ,expr))
                 exprs))))


(defmacro nil! (var)
  `(setf ,var nil))
(defmacro t! (var)
  `(setf ,var t))

#+END_SRC

** [[/Users/Can/Develop/Lisp/list.lisp][list]]
#+BEGIN_SRC lisp 
(in-package :celwk)
(defun suffix-with? (string suffix &key (test 'eql))
  (let ((index (search suffix string :from-end t :test test)))
    (and index
         (= index (- (length string) (length suffix))))))

(defun last* (lst)
  (car (last lst)))

(defun separate (elt-length lst &aux (count-result (ceiling (/ (length lst) elt-length))) result)
  "(separate 2 '(1 2 3 4 5)) => ((1 2) (3 4) (5))"
  (dotimes (i count-result (nreverse result))
    (push (subseq lst (* i elt-length)
                  (min (* (1+ i) elt-length)
                       (length lst)))         
          result)))
(defun average-list (count lst)
  (separate (ceiling (/ (length lst) count)) lst))



(defun group-by (fn lst &key (test #'equal) (out #'list))
  (let ((hash (make-hash-table :test test)))
    (mapc (^(item)
            (let ((key (funcall fn item)))
              (unless (gethash key hash)
                (setf (gethash key hash) ()))
              (push item (gethash key hash))))
          lst)
    (loop for k being the hash-keys in hash using (hash-value v)
       collect (funcall out k v))))

(defun getf* (lst key &key (test #'equal) from-end)
  (tif (position key lst :test test :from-end from-end)
       (nth (1+ it) lst)))

;; (getf '(xx p1 p2 &rest rest &key k1 k2) '&rest)  => nil
;; (getf* '(xx p1 p2 &rest rest &key k1 k2) '&rest) => rest






(defun general-args (args)
  "(general-args '(xx p1 p2 &rest rest &key k1 k2)) =>(xx p1 p2)"
  (subseq args 0 (count-general-args args)))

(defun arg-list (alist)
  "(arg-list '(a b &rest r &key k1 k2)) => (:general '(a b) :rest 'r :key '(:k1 :k2))"
  (let (total)
    (setf (getf total :general) (general-args alist)
          (getf total :rest) (getf* alist '&rest)
          (getf total :key) (rest (member '&key alist)))
    ;; (mapcar #'symbol-key (rest (member '&key alist))))
    total))




(defmacro defun-rest-without-key (fn params &body code)
  "Define a function whose rest & key don't mixture.
 Disavantage: function specific args won't be should on SLIME mini-buffer"
  (destructuring-bind (&key general rest key) (arg-list params)
    `(defun ,fn (&rest args)
       (destructuring-bind (,@general ,rest &key ,@key)
           (multiple-value-bind (rest keys) (apply #'general-&-keys (subseq args ,(length general)))
             (nconc (subseq args 0 ,(length general)) (list rest) keys))
         ,@code))))

;; (defun-rest-without-key test-fn (a b c &rest o &key k1 k2)
;;   (list a b c :rest o :k1 k1 :k2 k2))
;; (test-fn 1 3 5 8 9 :k1 'kk1 :k2 'kk2 999)
;; => (1 3 5 :rest (8 9 999) :k1 kk1 :k2 kk2)

(defun general-&-keys (&rest rest)
  "(general-&-keys 21 34 'yo :heloo 5 :xx 99 88)
 => (21 34 yo 88)
	(heloo 5 xx 99)"
  (do ((i 0) lst keys)
      ((>= i (length rest))
       (values (nreverse lst) keys))
    (let ((value (elt rest i)))
      (if (keywordp value)
          (progn
            ;; (setf keys (nconc keys (list (key-symbol (nth i rest)) (nth (1+ i) rest))))	;; => (k1 xx k2 cc)
            (setf keys (nconc keys (subseq rest i (+ i 2)))) ;; => (:k1 xx :k2 cc)
            (incf i 2))
          (and (push value lst)
               (incf i))))))

(fn 'a 'b 'c 'd :k1 'kk :k2 'uu 'x) =>
p1 => 'a
p2 => 'b
rest => '(c d x)
k1 => 'kk
k2 => 'uu
k3 => nil

1. Classify first
2. Bind to appropriate args symbol

;; Write example first before implementation!

(defun test-fn (&rest args)
  (destructuring-bind
        (a b c o (&key k1 k2))
      (nconc (subseq args 0 3)
             (multiple-value-list (apply #'general-&-keys (subseq args 3))))
    (list a b c :rest o :k1 k1 :k2 k2)))


#+END_SRC

** [[/Users/Can/Develop/Lisp/grammar.lisp][grammar]]
#+BEGIN_SRC lisp 
(in-package :celwk)

(defun digital-char? (c &aux (int (char-int c)))
  (and (>= int (char-int #\0)) (<= int (char-int #\9))))

(defun symbol-int (symb)
  (let* ((str (string symb))	;; write-to-string is OK
         (from (position-if #'digital-char? str))
         (to (position-if #'digital-char? str :from-end t)))
    (parse-integer (subseq str from (1+ to)))))


(defun series (below &key (from 0))
  (loop :for i :from from :below below
     collect i))

(defun n-times (n fn &aux (c (count-args fn)))
  (mapcar (^(i) (apply fn (when (= c 1) (list i))))
          (series n)))

(defun ntimes (n fn &optional (start 0))
  (loop for i below n
     collect (funcall fn (+ start i))))

(defun parse-to-lambda (body &optional (seperator #\%) &aux (count 0))
  "(funcall $(+ %1 %2) 10 20) => 30
	%0 => Count of args "
  (labels ((parse (symb)
             (if (atom symb)
                 (when (char= seperator (char (write-to-string symb) 0))
                   (setf count (max count (symbol-int symb))))
                 (mapc #'parse symb)))
           (var-name (n)
             (read-from-string (input "~c~s" seperator (1+ n)))))
    (parse body)
    `(lambda ,(append (ntimes count #'var-name)
                      (let ((count-var (var-name -1)))
                        (when (find count-var (flatten body))
                          `(&aux (,count-var ,count)))))	;; &aux (%0 count)
       ,body)))

(set-macro-character #\$ #'(lambda (stream char &aux (code (read stream)))
                             (declare (ignore char))
                             (parse-to-lambda code)))

#+END_SRC

** [[/Users/Can/Develop/Lisp/functional.lisp][functional]]
#+BEGIN_SRC lisp 
(in-package :celwk)

;;   (funcall fn a b c)
;; = (apply fn (list a b c))
;; = (apply fn a b c nil)

(defun count-general-args (args)
  (or (position-if (^(x) (find x lambda-list-keywords)) args)
      (length args)))

(defun count-args (fn)
  (count-general-args (sb-introspect:function-lambda-list fn)))

;; Recursive
(defun flatten (xs)
  "To 1-depth-only list"
  (let (-result-)
    (dolist (x xs -result-)
      (cond ((null x))
            ((atom x) (setf -result- (nconc -result- (list x))))
            (t (setf -result- (append -result- (flatten x))))))))
;; (flatten '(1 (6 7 2) 3 4 (4 (5 6 ) nil (1 ( 3 (5 6)) 9))))
;; => (1 6 7 2 3 4 4 5 6 1 3 5 6 9) 

(defun prune (test tree)
  "Deep remove-if"
  (let (-list-)
    (dolist (x tree (nreverse -list-))
      (if (atom x)
          (unless (funcall test x) (push x -list-))
          (push (prune test x) -list-)))))
;; (prune #'evenp '(1 2 (3 (4 5) 6) 7 8 (((12))) (13) 22 (20) (9)))
;; => (1 (3 (5)) 7 ((nil)) (13) nil (9))

(defun rmapcar (fn &rest args)
  "Deep/Recursive mapcar"
  (if (some #'atom args)
      (apply fn args)
      (apply #'mapcar
             (^(&rest lst) (apply #'rmapcar fn lst))
             args)))
;; (rmapcar #'* '(1 (2 (3) 4)) '(10 (20 (30) 40)))
;; => (10 (40 (90) 160))  

(defun memorize (fn &optional (test #'equal))
  (let ((cache (make-hash-table :test test)))
    (^(&rest args)
      (multiple-value-bind (val win) (gethash args cache)
        (if win
            val
            (setf (gethash args cache) 
                  (apply fn args)))))))

(defun reversed-function (fn)
  (^(&rest args)
    (apply fn (nreverse args))))
;; (defun pipe (fn1 &rest fns)
;;   (^(&rest args)
;;     (reduce (reversed-function #'call) fns
;;             :initial-value (apply fn1 args))))


(defun compose (&rest fns)
  (let ((fn1 (car (last fns)))
        (fns (butlast fns)))
    (^(&rest args)
      (reduce #'funcall fns 
              :from-end t
              :initial-value (apply fn1 args)))))

(defun pipe (&rest fns)
  (apply #'compose (nreverse fns)))

(defun always (x) #'(lambda (&rest args) (declare (ignore args)) x))

(defun bind (fn &rest params)
  "(funcall (bind '+ 6 7) 10) "
  (^(&rest args)
    (apply fn (append params args))))


;; Simple, ONLY once :
;; (defun curry (fn &rest args)
;;   #'(lambda (&rest args2)
;;       (apply fn (append args args2))))

;; (defun rcurry (fn &rest args)	;; right-curry
;;   #'(lambda (&rest args2)
;;       (apply fn (append args2 args))))


(defmacro defconst (name value)
  `(if (constantp ',name)	;; boundp
       ,name
       (defconstant ,name ,value)))
;; (defconst ~ '~)	;; gensym passed to other function will NOT be equal !!

(defmacro defsymbol (symbol)
  `(defconst ,symbol ',symbol))
;; (makunbound '~) to cancel constant bound with warning
(defsymbol ~)	;; Declare in this package ONLY ?!
;; (defconst _ ~)

(defun repeat (n e &aux lst)
  "(repeat 3 ~) => (~ ~ ~)"
  (dotimes (i n lst)
    (push e lst)))

(defun filled-list (list new-values &optional (placeholder ~)
                    &aux (start 0) (lst (copy-list list)))
  "(filled-list '(a b c ~ e ~ g) '(~ f) ~) => (a b c ~ e f g)"
  (dolist (i new-values lst)
    (let ((pos (position placeholder lst :start start)))
      (setf (nth pos lst) i)
      (setf start (1+ pos)))))

(defun curry (fn &rest init)
  "Use ~ for placeholder:
 (funcall (funcall (curry #'< 1 2 ~ 5 ~) ~ 6) 3) => t"
  (let* ((n (max (length init)
                 (count-args fn)))
         (params (filled-list (repeat n ~) init ~)))
    (if (find ~ params)
        (^(&rest rest) (apply #'curry fn (filled-list params rest ~)))
        (apply fn params))))

#+END_SRC

** [[/Users/Can/Develop/Lisp/file.lisp][file]]
#+BEGIN_SRC lisp 
(in-package :celwk)

(defun files-with-suffix (suffixes &key (dir "mine") (deep t))
  (when (atom suffixes)
    (setf suffixes (list suffixes)))
  (unless dir
    (error "Please set :dir"))	; TODO: then read it?
  (mapcan (^(suffix)
            (remove-if (^(path)
                         (position #\. (pathname-name path)))	; (file-namestring path)
                       (directory (concat dir
                                          (if deep "/**/*." "/*.")
                                          suffix))))
          suffixes))

(defun file-size (file)
  (with-open-file (in file :element-type '(unsigned-byte 8))
    (file-length in)))


(defun read-file (file &rest open-args)
  (with-open-stream (stream (apply 'open file open-args))
    (let* ((buffer (make-array (file-length stream)
                               :fill-pointer t
                               :element-type (stream-element-type stream)))
           (position (read-sequence buffer stream)))
      (setf (fill-pointer buffer) position)	;; Remove the end irrelevant chars
      buffer)))

(defun write-to-file (file data &key readonly)
  (with-open-file (stream file
                          :direction :output
                          :if-exists :supersede
                          :if-does-not-exist :create)
    (write-sequence data stream))
  (if readonly (cmd (input "chmod a-w ~a" file)))
  (values))


#+END_SRC

** [[/Users/Can/Develop/Lisp/debug.lisp][debug]]
#+BEGIN_SRC lisp 
(defmacro labeled-time (codes)
  `(progn
    (format *trace-output* "~2&~a" ',codes)
    (time ,codes)))

#+END_SRC

** [[/Users/Can/Develop/Lisp/basic.lisp][basic]]
#+BEGIN_SRC lisp 
(in-package :celwk)

(format t "Welcome!!~%")
(setf *print-case* :downcase)

(defmacro mac (expr)
  `(pprint (macroexpand-1 ',expr)))

(defmacro ^ (&body codes)
  `#'(lambda ,@codes))

(defmacro alias-function (new origin)
  `(setf (symbol-function ',new) #',origin))

(defmacro desc (symbol &optional (type 'function))
  (documentation symbol type))

(defmacro desc-var (symbol)
  (documentation symbol 'variable))

(defmacro alias (new origin &rest init-args)
  `(defmacro ,new (&rest args)
     (append '(,origin) ',init-args args)))
(alias output format t)		;; Only print to *standard-output*
(alias input format nil)		;; Return the string

(defmacro alias-function (new origin)
  `(defun ,new (&rest args)
     (apply #',origin args)))

(defun load-package (package)
  (unless (find-package package)
    (ql:quickload package)))

(defun ends-with? (ends seq &optional (test #'char-equal))
  (unless (listp ends)
    (setf ends (list ends)))
  (find-if (^(end) (equal (search end seq :from-end t :test test)
                          (- (length seq) (length end))))
           ends))


#+END_SRC

* Macro
** [[/Users/Can/Develop/Lisp/mine/macro/functional.lisp][functional]]
#+BEGIN_SRC lisp 
(defun compose (&rest fns)	;; acl
  (destructuring-bind (fn1 . rest) (reverse fns)
    #'(lambda (&rest args)
        (reduce #'(lambda (v f) (funcall f v))
                rest
                :initial-value (apply fn1 args)))))

(defmacro composed-func (func-name &rest fns)	;; define a function
  `(destructuring-bind (fn1 . rest) (reverse ',fns)
     (defun ,func-name (&rest args)
       (reduce #'(lambda (v f) (funcall (symbol-function f) v))
               rest
               :initial-value (apply (symbol-function fn1) args)))))

(defmacro can-compose (&rest fns)				;; return a function(lambda)
  `(destructuring-bind (fn1 . rest) (reverse ',fns)
     #'(lambda (&rest args)
         (reduce #'(lambda (v f) (funcall (symbol-function f) v))
                 rest
                 :initial-value (apply (symbol-function fn1) args)))))
;; TODO: (compose1 (list +) 1 2 3) => (6)
(defmacro compose! ((&rest fns) &rest params)
  (...codes))

(defmacro bind (fn &rest params)
  "(funcall (bind + 6 7) 10) if DEFMACRO, or (funcall (bind '+ 6 7) 10) if DEFUN"
  (^(&rest args)
    (apply fn (append params args))))

(defun compose2 (&rest fns)  ;; On Lisp
  (if fns
      (let ((fn1 (car (last fns)))
            (fns (butlast fns)))
        #'(lambda (&rest args)
            (reduce #'funcall fns
                    :from-end t
                    :initial-value (apply fn1 args))))
      #'identity))

;; Useful: (apropos "http")    (apropos-list "curry")
(char= #\& (elt (write-to-string (first (sb-introspect:function-lambda-list 'compose2))) 0))


(defmacro ^ (&body codes)
  `(lambda ,@codes))
(alias $ ^)

(defun count-args (fn)
  (let ((params (sb-introspect:function-lambda-list fn))) 
    (or (position-if (^(name) (char= #\& (elt (write-to-string name) 0))) params)
        (length params))))
;; (defmacro count-params (fn)  ;; without #'   but unable for lambda
;;   (params-count fn))
(defun series (below &key (from 0))
  (loop :for i :from from :below below
     collect i))

(defun n-times (n fn &aux (c (count-args fn)))
  (mapcar (^(i) (apply fn (when (= c 1) (list i))))
          (series n)))

(defun ntimes (n fn &aux (c (count-args fn)))
  (loop for i below n
     collect (apply fn (when (= c 1) (list i)))))

(defmacro with-syms-list ((alist count) &body body)
  `(let ((,alist ',(ntimes count #'gensym)))
     ,@body))

(defun symbol-key (key)
  ;; (read-from-string (concatenate 'string ":" (write-to-string key))))  (intern string :keyword)
  (read-from-string (format nil ":~a" key)))

;; (defmacro create-defun (fn)
;;   `(defun ,fn (&rest args)
;;      (apply ,fn args)))
;; (defparameter adds (^(a b c) (+ a b c)))
;; (defun+ adds)
;; (adds 5 6 7) => 18
;; Equals to:
(defmacro defun+ (fn)
  (setf (symbol-function fn) (eval fn)))

;; Create #'fn & fn at the same time
(defmacro def+ (fn (&rest args) &body body)
  `(progn
     (defun ,fn (,@args)
       ,@body)
     ;; (setf (symbol-value ',fn) #',fn)))
     (defparameter ,fn #',fn)))

(defun curry-traditional (fn &rest params &aux (n (count-args fn)))
  (labels ((take (&rest args &aux (required (- n (length args))))
             (if (plusp required)
                 (^(&rest args2) (apply #'take (append args args2)))
                 (apply fn args))))
    (apply #'take params)))

(defun 2d-array-to-list (array)
  (map 'list #'identity array))



(defmacro defconst (name value)
  `(if (constantp ',name)	;; boundp
       ,name
       (defconstant ,name ,value)))

;; (defconst ~ '~)	;; gensym passed to other function will NOT be equal !!

(defmacro def-symbol (symbol)
  `(defconstant ,symbol ',symbol))

(def-symbol ~)
(defun repeat-elements (e count &aux lst)
  (dotimes (i count lst)
    (push e lst)))

(defun filled-list (list new-values placeholder
                  &aux (start 0) (lst (copy-list list)))
  (dolist (i new-values lst)
    (let ((pos (position placeholder lst :start start)))
      (setf (nth pos lst) i)
      (setf start (1+ pos)))))

(defun curry (fn &rest init)
  (let* ((n (max (length init)
                 (count-args fn)))
         (params (filled-list (repeat-elements ~ n) init ~)))
    (if (find ~ params)
        (^(&rest rest) (apply #'curry fn (filled-list params rest ~)))
        (apply fn params))))

(defmacro timing (&body forms)
    (let ((real1 (gensym))
	    (real2 (gensym))
	    (run1 (gensym))
	    (run2 (gensym))
	    (result (gensym)))
    `(let* ((,real1 (get-internal-real-time))
	      (,run1 (get-internal-run-time))
	      (,result (progn ,@forms))
	      (,run2 (get-internal-run-time))
	      (,real2 (get-internal-real-time)))
	 (format *debug-io* ";;; Computation took:~%")
	 (format *debug-io* ";;;  ~f seconds of real time~%"
		 (/ (- ,real2 ,real1) internal-time-units-per-second))
	 (format t ";;;  ~f seconds of run time~%"
		 (/ (- ,run2 ,run1) internal-time-units-per-second))
	 ,result)))

#+END_SRC

** [[/Users/Can/Develop/Lisp/mine/macro/call.lisp][call]]
#+BEGIN_SRC lisp 
(defmacro call (function &rest params)
  `(funcall #',function ,@params))
(call + 1 2 3 4) => (funcall #'+ 1 2 3 4)

(defmacro call2 (function params)
  `(funcall #',function ,@params))
(call2 + (1 2 3 4)) => like apply

#+END_SRC

* Music
** [[/Users/Can/Develop/Lisp/others/music/play.lisp][play]]
#+BEGIN_SRC lisp 
(ql:quickload :harmony-simple)
(harmony-simple:initialize)
(harmony-simple:play #p"music/nightingale.mp3" :music :loop T)

#+END_SRC

* Note
** [[/Users/Can/Develop/Lisp/note/sqlite.lisp][sqlite]]
#+BEGIN_SRC lisp 
(defvar *db* (connect "/Users/Can/Develop/Lisp/others/config/instantly.db"))
(alias sql execute-to-list *db*)
(setf notes (sql "
SELECT id, title, body, need_password, modify_time, create_time, (select title from locations where id = location_id) as location,
	(SELECT GROUP_CONCAT(title) FROM tags WHERE id IN (SELECT tag_id FROM note_tag WHERE note_id = n.id)) as tags
FROM notes n
ORDER BY need_password ASC, modify_time DESC
LIMIT 200"))

(defconstant +line-width+ (length (celwk::now)))

(with-open-file (main "/Users/Can/Develop/Lisp/me/instantly.org"
                      :direction :output
                      :if-does-not-exist :create
                      :if-exists :supersede)	;; :append
  (mapcar (^(note) 
            (destructuring-bind (id title body password? time-last-update time-create location tags) note
              (setf tags (uiop:split-string
                          (remove-if (^(char) (position char "🌎&!")) (substitute #\: #\Space tags))
                          :separator ",")) ;; maybe nil
              (when (= 1 password?) (push "hidden" tags))
              (setf tags (if tags (concat ":" (celwk::string-join tags ":") ":") ""))
              (let ((separator (celwk::string-repeat "=" (+ 8 +line-width+))))
                (format main "* ~a~a~a~%~a~2%~a~%Update: ~a ~%Create: ~a~%At ~a [id:~a]~%~a~%"
                        title
                        (if (zerop (length tags)) ""
                            (celwk::string-repeat " " 10))
                        tags
                        body
                        separator
                        (time-of-universal time-last-update :from 1970)
                        (time-of-universal time-create :from 1970)
                        (or location "Nowhere")
                        id
                        separator))))
          notes)
  (values))
;; 0.006 second
;; C-u C-c C-q  to reoganize the tags of Org
;; (ppcre:split "\\* " (read-file "/Users/Can/Develop/Lisp/me/instantly.org"))

#+END_SRC

** [[/Users/Can/Develop/Lisp/note/doing.lisp][doing]]
#+BEGIN_SRC lisp 
All I want to do:

Concatenate my Common Lisp codes to one file:
1. In a whole directory
2. suffix [ .lisp .cl ]
3. Seperate by a new line & fime name
4. Read and merge to an org-mode file, with tag of direcotry

Implement:
1. Get all file paths by direcoty and suffix
2. Read from stream and write to destination for each file
3. Recursive the direcoties!!


Functions:

(pathnames-of-directory DIR) => (directory )
filter => filename => (string-end-with string &rest suffixes)    ;; (string-end-with filename ".lisp" ".cl")
(read-file)

#+END_SRC

* Pcl
** [[/Users/Can/Develop/Lisp/document/pcl/bank-check.cl][bank-check]]
#+BEGIN_SRC lisp 
(defvar *checks* (make-array 100 :adjustable t :fill-pointer 0)
  "A vector of checks.")

(defconstant +first-check-number+ 100
   "The number of the first check.")

(defvar *next-check-number* +first-check-number+
  "The number of the next check.")

(defvar *payees* (make-hash-table :test #'equal)
  "Payees with checks paid to each.")

(defstruct check
  number date amount payee memo)

(defun current-date-string ()
  "Returns current date as a string."
  (multiple-value-bind (sec min hr day mon yr)
	  (get-decoded-time)
	(declare (ignore sec min hr))
	(format nil "~A-~A-~A" yr mon day)))

(defun write-check (amount payee memo)
  "Writes the next check in sequence."
  (let ((new-check (make-check
					:number *next-check-number*
					:date (current-date-string)
					:amount amount
					:payee payee
					:memo memo)))
	(incf *next-check-number*)
	(vector-push-extend new-check *checks*)
	(push new-check (gethash payee *payees*))
	new-check))

(defun get-check (number)
  "Returns a check given its number, or NIL if no such check."
  (when (and (<= +first-check-number+ number) (< number *next-check-number*))
	(aref *checks* (- number +first-check-number+))))

(defun void-check (number)
  "Voids a check and returns T.  Returns NIL if no such check."
  (let ((check (get-check number)))
	(when check
	  (setf (gethash (check-payee check) *payees*)
			(delete check (gethash (check-payee check) *payees*)))
	  (setf (aref *checks* (- number +first-check-number+)) nil)
	  t)))

(defun list-checks (payee)
  "Lists all of the checks written to payee."
  (gethash payee *payees*))

(defun list-all-checks ()
  "Lists all checks written."
  (coerce *checks* 'list))

(defun sum-checks ()
  (let ((sum 0))
	(map nil #'(lambda (check)
				 (when check
				   (incf sum (check-amount check))))
		 *checks*)
	sum))

(defun list-payees ()
  "Lists all payees."
  (let ((payees ()))
	(maphash #'(lambda (key value)
				 (declare (ignore value))
				 (push key payees))
			 *payees*)
	    payees))

#+END_SRC

* Postmodern
** [[/Users/Can/Develop/Lisp/document/postmodern/postmodern/util.lisp][util]]
#+BEGIN_SRC lisp 
(in-package :postmodern)

(defun to-identifier (name)
  "Used to allow both strings and symbols as identifier - converts
symbols to string with the S-SQL rules."
  (if (stringp name)
      name
      (to-sql-name name)))

(defun sequence-next (sequence)
  "Shortcut for getting the next value from a sequence."
  (query (:select (:nextval (to-identifier sequence))) :single))

(defmacro make-list-query (relkind)
  "Helper macro for the functions that list tables, sequences, and
views."
  `(sql (:order-by (:select 'relname :from 'pg-catalog.pg-class
                            :inner-join 'pg-catalog.pg-namespace :on (:= 'relnamespace 'pg-namespace.oid)
                            :where (:and (:= 'relkind ,relkind)
                                         (:not-in 'nspname (:set "pg_catalog" "pg_toast"))
                                         (:pg-catalog.pg-table-is-visible 'pg-class.oid)))
                   'relname)))

(defmacro make-exists-query (relkind name)
  "Helper macro for the functions that check whether an object
exists."
  `(sql (:select (:exists (:select 'relname :from 'pg_catalog.pg_class :inner-join 'pg_catalog.pg_namespace :on
                                   (:= 'pg_class.relnamespace 'pg_namespace.oid)
                                   :where (:and (:= 'pg_class.relkind ,relkind)
                                                (:= 'pg_namespace.nspname (:any* (:current_schemas "true")))
                                                (:= 'pg_class.relname (to-identifier ,name))))))))

(defun split-fully-qualified-tablename (name)
  "Take a tablename of the form database.schema.table or schema.table
and return the tablename and the schema name. The name can be a symbol
or a string. Returns a list of form '(table schema database"
  (destructuring-bind (table &optional schema database)
      (nreverse (split-sequence:split-sequence #\. (to-sql-name name)
                                               :test 'equal))
    (list table schema database)))

(defun list-tables-in-schema (&optional (schema-name "public") lisp-strings-p)
  "Returns a list of tables in a particular schema, defaulting to public."
  (let ((result (alexandria:flatten
                 (query (:order-by
                         (:select 'table-name
                                  :from 'information-schema.tables
                                  :where (:= 'table-schema '$1))
                         'table-name)
                        (to-sql-name schema-name)))))
    (if lisp-strings-p (mapcar 'from-sql-name result) result )))

(defun list-tables (&optional strings-p)
  "Return a list of the tables in a database. Turn them into keywords
if strings-p is not true."
  (let ((result (query (make-list-query "r") :column)))
    (if strings-p result (mapcar 'from-sql-name result))))

(defun table-exists-p (table-name &optional (schema-name nil))
  "Check whether a table exists in a particular schema. Defaults to the search path.
Takes either a string or a symbol for the table name. The table-name can be fully
qualified in the form of schema.table-name or database.schema.table-name. If
the schema is specified either in a qualified table-name or in the optional
schema-name parameter, we look directly to the information schema tables. Otherwise
we use the search path which can be controlled by being within a with-schema form."
  (let* ((destructured-table-name (split-fully-qualified-tablename table-name))
         (schema (or (second destructured-table-name) schema-name))
         (table (or (first destructured-table-name) table-name))
         (result (if schema
                     (member (to-sql-name table)
                             (alexandria:flatten
                              (query (:order-by
                                      (:select 'table-name
                                               :from 'information-schema.tables
                                               :where (:= 'table-schema '$1))
                                      'table-name)
                                     (s-sql::to-sql-name schema)))
                             :test 'equal)
                     (query (make-exists-query "r" table) :single))))
    (if result t nil)))

(defun create-sequence (name &key temp if-not-exists increment min-value max-value start cache)
  "Create a sequence. Available additional key parameters are
:temp :if-not-exists :increment :min-value :max-value :start and :cache. See
https://www.postgresql.org/docs/current/static/sql-createsequence.html for details on usage."
  (let ((query-string
         (concatenate 'string
                      "CREATE "
                      (if temp "TEMP " "")
                      "SEQUENCE "
                      (if if-not-exists "IF NOT EXISTS " "")
                      (to-sql-name name)
                      (if increment (concatenate 'string " INCREMENT BY " (format nil "~a" increment)) "")
                      (if min-value (concatenate 'string " MINVALUE " (format nil "~a" min-value)) "")
                      (if max-value (concatenate 'string " MAXVALUE " (format nil "~a" max-value)) "")
                      (if start (concatenate 'string " START " (format nil "~a" start)) "")
                      (if cache (concatenate 'string " CACHE " (format nil "~a" cache)) ""))))
    (query query-string)))

(defun drop-sequence (name &key if-exists cascade)
  "Drop a sequence. Name should be quoted. Available key parameters are :if-exists and :cascade"
  (let ((query-string
         (concatenate 'string
                      "DROP "
                      "SEQUENCE "
                      (if if-exists "IF EXISTS " "")
                      (to-sql-name name)
                      (if cascade " CASCADE" ""))))
    (query query-string)))

(defun list-sequences (&optional strings-p)
  "Return a list of the sequences in a database. Turn them into
keywords if strings-p is not true."
  (let ((result (query (make-list-query "S") :column)))
    (if strings-p result (mapcar 'from-sql-name result))))

(defun sequence-exists-p (sequence)
  "Check whether a sequence exists. Takes either a string or a symbol
for the sequence name."
  (query (make-exists-query "S" (to-sql-name sequence)) :single))

(defun list-views (&optional strings-p)
  "Return a list of the views in a database. Turn them into keywords
if strings-p is not true."
  (let ((result (query (make-list-query "v") :column)))
    (if strings-p result (mapcar 'from-sql-name result))))

(defun view-exists-p (view)
  "Check whether a view exists. Takes either a string or a symbol for
the view name."
  (query (make-exists-query "v" view) :single))

(defun table-description (table-name &optional schema-name)
  "Return a list of (name type null-allowed) lists for the fields of a
table."
  (setf table-name (to-sql-name table-name))
  (when schema-name (setf schema-name (to-sql-name schema-name)))
  (let ((schema-test (if (and schema-name (schema-exists-p schema-name) (table-exists-p table-name))
                         (sql (:= 'pg-namespace.nspname schema-name))
                         "true")))
    (mapcar #'butlast
            (query (:order-by (:select 'attname 'typname (:not 'attnotnull) 'attnum :distinct
                                       :from 'pg-catalog.pg-attribute
                                       :inner-join 'pg-catalog.pg-type :on (:= 'pg-type.oid 'atttypid)
                                       :inner-join 'pg-catalog.pg-class :on (:and (:= 'pg-class.oid 'attrelid)
                                                                                  (:= 'pg-class.relname (to-identifier table-name)))
                                       :inner-join 'pg-catalog.pg-namespace :on (:= 'pg-namespace.oid 'pg-class.relnamespace)
                                       :where (:and (:> 'attnum 0) (:raw schema-test)))
                              'attnum)))))

(defun coalesce (&rest args)
  "Returns t if any argument is not nil or :null."
  (some (lambda (x) (if (eq x :null) nil x)) args))

(defun database-version ()
  "Returns the version of the current postgresql database."
  (query (:select (:version)) :single))

(defun num-records-in-database ()
  "Returns a list of lists with schema, table name and approximate number of records
in the currently connected database."
  (query (:order-by (:select 'schemaname 'relname 'n_live_tup
			     :from 'pg_stat_user_tables)
		    (:desc 'n_live_tup))))

(defun current-database ()
  "Returns the string name of the current database."
  (query (:select (:current-database)) :single))

(defun database-exists-p (database-name)
  "Determine if a particular database exists. "
  (setf database-name (to-sql-name database-name))
  (if (member database-name (list-databases :size nil) :test 'equal) t nil))

(defun database-size (&optional (name nil))
  "Given the name of a database, will return the name, a pretty-print string of
the size of the database and the size in bytes. If a database name is not provided,
it will return the result for the currently connected database."
  (unless name
    (setf name (current-database)))
  (first (query
          (:select 'datname
                   (:pg-size-pretty
                    (:pg-database-size 'pg-database.oid))
                   (:pg-database-size 'pg-database.oid)
                   :from 'pg-database
                   :where (:= 'datname '$1))
          (to-sql-name name))))

(defun list-databases (&key (order-by-size nil) (size t))
  "Returns a list of lists where each sub-list contains the name of the
database, a pretty-print string of the size of that database and the size in bytes.
The default order is by database name. Pass t as a parameter to :order-by-size for order by size.
Setting size to nil will return just the database names in a single list
ordered by name. This function excludes the template databases."
  (if order-by-size
      (setf order-by-size (sql (:desc (:pg-database-size 'pg-database.oid))))
      (setf order-by-size " datname"))
  (cond (size
         (query
          (:order-by
           (:select 'datname
                    (:pg-size-pretty
                     (:pg-database-size 'pg-database.oid))
                    (:pg-database-size 'pg-database.oid)
                    :from 'pg-database
                    :where (:not (:like 'datname "template%")))
           (:raw order-by-size))))
        (t
         (loop for x in (query
                         (:order-by
                          (:select 'datname
                                   :from 'pg-database
                                   :where (:not (:like 'datname "template%")))
                          (:raw order-by-size)))
            collect (first x)))))


;;;; Schemas
;;;; See namespace.lisp

;;;; Tablespaces
(defun list-tablespaces ()
  "Lists the tablespaces in the currently connected database."
  (loop for x in (query (:order-by (:select (:as 'spcname 'name)
                                            :from 'pg_tablespace)
                                   'spcname))
       collect (first x)))

(defun list-available-types ()
  "List the available types in this postgresql version."
  (query (:select 'oid (:as (:format-type :oid :NULL) 'typename)
                  :from 'pg-type
                  :where (:= 'typtype "b"))))


;;; Tables
;;; create table can only be done either using a deftable approach or s-sql

(defun drop-table (name &key if-exists cascade)
  "Drop a table. Available additional key parameters are :if-exists and :cascade."
  (let ((query-string
         (concatenate 'string
                      "DROP "
                      "TABLE "
                      (if if-exists "IF EXISTS " "")
                      (to-sql-name name)
                      (if cascade " CASCADE" ""))))
    (query query-string)))

(defun list-table-sizes (&key (schema "public") (order-by-size nil) (size t))
  "Returns a list of lists (table-name, size in 8k pages) of tables in the current database.
Providing a name to the schema parameter will return just the information for tables in that schema.
It defaults to just the tables in the public schema. Setting schema to nil will return all tables, indexes etc
in the database in descending order of size. This would include system tables, so there
are a lot more than you would expect. If :size is set to nil, it returns only a flat list of table names.
Setting order-by-size to t will return the result in order of size instead of by table name."
  (setf schema (to-sql-name schema))
  (if order-by-size
      (setf order-by-size (sql (:desc 'relpages)))
      (setf order-by-size " relname"))
  (cond ((and size schema)
         (query (:order-by (:select 'relname 'relpages
                                    :from 'pg_class
                                    :where (:in 'relname
                                                (:set (:select 'table-name
                                                               :from 'information-schema.tables
                                                               :where (:= 'table-schema '$1)))))
                           (:raw order-by-size))
                schema))
         (size (query (:order-by (:select 'relname 'relpages
                                       :from 'pg_class)
                                 (:raw order-by-size))))
         (schema (query (:order-by (:select 'relname
                                    :from 'pg_class
                                    :where (:in 'relname
                                                (:set (:select 'table-name
                                                               :from 'information-schema.tables
                                                               :where (:= 'table-schema '$1)))))
                                   'relname)
                        schema))
         (t (loop for x in (query (:order-by (:select 'relname
                                        :from 'pg_class)
                                             'relname))
               collect (first x)))))


(defun table-size (table-name)
  "Return the size of a postgresql table in k or m. Table-name can be either a string or quoted."
  (query (:select (:pg_size_pretty (:pg_total_relation_size '$1)))
         :single
         (to-sql-name table-name)))

(defun more-table-info (table-name)
  "Returns more table info than table-description. Table can be either a string or quoted.
Specifically returns ordinal-position, column-name, data-type, character-maximum-length,
modifier, whether it is not-null and the default value. "
  (query (:order-by (:select (:as 'a.attnum 'ordinal-position)
                             (:as 'a.attname 'column-name)
                             (:as 'tn.typname 'data-type)
                             (:as 'a.attlen  'character-maximum-length)
                             (:as 'a.atttypmod 'modifier)
                             (:as 'a.attnotnull 'notnull)
                             (:as 'a.atthasdef 'hasdefault)
                             :from (:as 'pg_class 'c)
                             (:as 'pg_attribute 'a)
                             (:as 'pg_type 'tn)
                             :where (:and
                                     (:= 'c.relname '$1)
                                     (:> 'a.attnum 0)
                                     (:= 'a.attrelid 'c.oid)
                                     (:= 'a.atttypid 'tn.oid)))
                    'a.attnum)
         (to-sql-name table-name)))

;; Columns
(defun list-columns (table-name)
  "Returns a list of strings of just the column names in a table.
Pulls info from the postmodern table-description function
rather than directly."
  (when (table-exists-p table-name)
    (loop for x in (table-description table-name)
       collect (first x))))

(defun list-columns-with-types (table-name)
  "Return a list of (name type) lists for the fields of a table. Goes directly to the pg-catalog tables."
  (setf table-name (to-sql-name table-name))
  (when (table-exists-p table-name)
    (query
     (:select (:as 'a.attname 'column)
              (:as (:pg-catalog.format_type 'a.atttypid  'a.atttypmod)
                   'datatype)
              :from (:as 'pg-catalog.pg-attribute 'a)
              :where (:and
                      (:> 'a.attnum 0)
                      (:not 'a.attisdropped)
                      (:= 'a.attrelid
                          (:select
                           'c.oid
                           :from (:as 'pg-catalog.pg-class 'c)
                           :left-join (:as 'pg-catalog.pg-namespace 'n)
                           :on (:= 'n.oid 'c.relnamespace)
                           :where (:and
                                   (:= 'c.relname '$1)
                                   (:pg-catalog.pg-table-is-visible 'c.oid))))))
     table-name)))

(defun column-exists-p (table-name column-name)
  "Determine if a particular column exists. Table name and column-name can be either strings or symbols."
  (query (:select 'attname :from 'pg_attribute
		  :where (:= 'attrelid
			     (:select 'oid :from 'pg-class
				      :where (:and (:= 'relname '$1)
						   (:= 'attname '$2)))))
         (to-sql-name table-name) (to-sql-name column-name)
         :single))

;;; Views
(defun describe-views (&optional (schema "public"))
  "Describe the current views in the specified schema. Takes an optional schema
name but defaults to public schema."
  (setf schema (to-sql-name schema))
  (query
   (:order-by
    (:select 'c.oid 'c.xmin 'c.relname
	     (:as (:pg_get_userbyid 'c.relowner) 'viewowner)
	     'c.relacl 'description
	     (:as (:pg_get-viewdef 'c.oid 't) 'code)
	     :from (:as 'pg_class 'c)
	     :left-join (:as 'pg_description 'des)
	     :on (:and (:= 'des.objoid 'c.oid)
		       (:= 0 'des.objsubid))
	     :left-join (:as 'pg_catalog.pg_namespace 'n)
	     :on (:= 'n.oid 'c.relnamespace)
	     :where
             (:and
              (:or
               (:and 'c.relhasrules
                     (:exists
                      (:select 'r.rulename
                               :from (:as 'pg_rewrite 'r)
                               :where (:and (:= 'r.ev_class 'c.oid)
                                            (:= (:bpchar 'r.ev_type)
                                                (:type "I" bpchar))))))
               (:= 'c.relkind (:type "v" char)))
              (:= 'n.nspname '$1)))
    'relname)
   schema))

;;;; Functions
(defun list-database-functions ()
  "Returns a list of the functions in the database from the information_schema."
  (query (:select 'routine-name :from 'information-schema.routines
                  :where
                  (:and
                   (:not-in 'specific-schema
                            (:set "pg_catalog" "information-schema"))
                   (:!= 'type-udt-name "trigger")))))

;;;; Indices
(defun index-exists-p (index-name)
  "Check whether a index exists. Takes either a string or a symbol for
the index name."
  (query (make-exists-query "i" (to-sql-name index-name)) :single))

(defun create-index (name  &key unique if-not-exists concurrently on using fields)
  "Create an index. Slightly less sophisticated than the query version because
it does not have a where clause capability."
  (let ((query-string
         (concatenate 'string
                      "CREATE "
                      (if unique "UNIQUE " "")
                      "INDEX "
                      (if concurrently "CONCURRENTLY " "")
                      (if if-not-exists "IF NOT EXISTS " "")
                      (to-sql-name name)
                      " ON "
                      (to-sql-name on)
                      " "
                      (if using (to-sql-name using) "")
                      " ("
                      (format nil "~{ ~a~^, ~}" (mapcar #'to-sql-name fields))
                      ") "
                      )))
    (query query-string)))

(defun drop-index (name &key concurrently if-exists cascade)
  "Drop an index. Available keys are :concurrently, :if-exists, and :cascade."
  (let ((query-string
         (concatenate 'string
                      "DROP "
                      "INDEX "
                      (if concurrently "CONCURRENTLY " "")
                      (if if-exists "IF EXISTS " "")
                      (to-sql-name name)
                      (if cascade " CASCADE" ""))))
    (query query-string)))


(defun list-indices (&optional strings-p)
  "Return a list of the indexs in a database. Turn them into keywords if strings-p is not true."
  (let ((result (query (make-list-query "i") :column)))
    (if strings-p result (mapcar 'from-sql-name result))))

(defun list-table-indices (table-name &optional strings-p)
  "List the index names and the related columns in a single table. "
  (when (table-exists-p (to-sql-name table-name))
    (let ((result (alexandria:flatten
                   (query
                    (:order-by
                     (:select
                      (:as 'i.relname 'index-name) (:as 'a.attname 'column-name)
                      :from (:as 'pg-class 't1) (:as 'pg-class 'i) (:as 'pg-index 'ix)
                      (:as 'pg-attribute 'a)
                      :where
                      (:and (:= 't1.oid 'ix.indrelid)
                            (:= 'i.oid 'ix.indexrelid)
                            (:= 'a.attrelid 't1.oid)
                            (:= 'a.attnum (:any* 'ix.indkey))
                            (:= 't1.relkind "r")
                            (:= 't1.relname '$1)))
                     'i.relname)
                    (to-sql-name table-name)))))
      (if strings-p result (mapcar 'from-sql-name result)))))

(defun list-indexed-column-and-attributes (table-name)
  "List the indexed columns and their attributes in a table. Includes primary key."
  (setf table-name (to-sql-name table-name))
  (when (table-exists-p table-name)
   (query
    (:select 'pg_attribute.attname
             (:format_type 'pg_attribute.atttypid 'pg_attribute.atttypmod)
             :from 'pg_index 'pg_class 'pg_attribute
             :where (:and (:= 'pg_class.oid (:type '$1 :regclass))
                          (:= 'indrelid 'pg_class.oid)
                          (:= 'pg_attribute.attrelid 'pg_class.oid)
                          (:= 'pg_attribute.attnum
                              (:any* 'pg_index.indkey))))
    table-name)))

(defun list-index-definitions (table-name)
  "Returns a list of the definitions used to create the current indexes for the table."
  (setf table-name (to-sql-name table-name))
  (when (table-exists-p table-name)
    (query (:select (:pg_get_indexdef 'indexrelid)
                    :from 'pg_index
                    :where (:= 'indrelid (:type '$1 :regclass)))
	   table-name)))

;;;; Keys
(defun find-primary-key-info (table &optional (just-key nil))
  "Returns a list of sublists where the sublist contains two strings.
If a table primary key consists of only one column, such as 'id' there
will be a single sublist where the first string is the name of the column
and the second string is the string name for the datatype for that column.
If the primary key for the table consists of more than one column, there
will be a sublist for each column subpart of the key. The sublists will
be in the order they are used in the key, not in the order they appear
in the table. If just-key is set to t, the list being returned will
contain just the column names in the primary key as string names
with no sublists. If the table is not in the public schema, provide
the fully qualified table name e.g. schema-name.table-name."
  (when (symbolp table) (setf table (s-sql:to-sql-name table)))
  (let ((info (query (:order-by
         (:select
          'a.attname
          (:format-type 'a.atttypid 'a.atttypmod)
          :from
          (:as 'pg-attribute 'a)
          :inner-join (:as (:select '*
                                   (:as (:generate-subscripts 'indkey 1) 'indkey-subscript)
                                   :from 'pg-index)
                          'i)
          :on
          (:and 'i.indisprimary
                (:= 'i.indrelid  'a.attrelid)
                (:= 'a.attnum  (:[] 'i.indkey 'i.indkey-subscript)))
          :where
          (:= 'a.attrelid  (:type '$1 regclass)))
         'i.indkey-subscript)
                     table)))
    (if just-key (loop for x in info collect (first x)) info)))

(defun list-foreign-keys (table schema)
  "Returns a list of sublists of foreign key info in the form of
   '((constraint-name local-table local-table-column
     foreign-table-name foreign-column-name))"
  (setf table (s-sql:to-sql-name table))
  (query
   (:select
    (:as 'conname 'constraint-name)
    table
    (:as 'att2.attname 'local-column)
    (:as 'cl.relname 'foreign-table-name)
    (:as 'att.attname 'foreign-table-column)
    :from
    (:as (:select
          (:as (:unnest 'con1.conkey) 'parent)
          (:as (:unnest 'con1.confkey) 'child)
          'con1.confrelid
          'con1.conrelid
          'con1.conname
          :from
          (:as 'pg-class 'cl)
          :inner-join (:as 'pg-namespace 'ns)
          :on (:= 'cl.relnamespace 'ns.oid)
          :inner-join (:as 'pg-constraint 'con1)
          :on (:= 'con1.conrelid 'cl.oid)
          :where
          (:and (:= 'cl.relname '$1)
                (:= 'ns.nspname '$2)
                (:= 'con1.contype "f")))
         'con)
    :inner-join (:as 'pg-attribute 'att)
    :on
    (:and (:= 'att.attrelid 'con.confrelid)
          (:= 'att.attnum 'con.child))
    :inner-join (:as 'pg-class 'cl)
    :on
    (:= 'cl.oid 'con.confrelid)
    :inner-join (:as 'pg-attribute 'att2)
    :on
    (:and (:= 'att2.attrelid 'con.conrelid)
          (:= 'att2.attnum 'con.parent)))
   table schema))

;;;; Constraints
(defun list-unique-or-primary-constraints (table-name)
  "List constraints on a table."
  (setf table-name (to-sql-name table-name))
  (when (table-exists-p table-name)
    (query (:select
            'relname
            :from 'pg-class
            :where
            (:in 'oid (:select 'indexrelid
                               :from 'pg-index 'pg-class
                               :where (:and
                                       (:= 'pg-class.relname '$1)
                                       (:= 'pg-class.oid 'pg-index.indrelid)
                                       (:or (:= 'indisunique "t")
                                            (:= 'indisprimary "t"))))))
           table-name)))

(defun list-all-constraints (table-name)
  "Uses information_schema to list all the constraints in a table. Table-name
can be either a string or quoted."
  (setf table-name (to-sql-name table-name))
  (when (table-exists-p table-name)
    (query (:select 'constraint-name 'constraint-type
		    :from 'information-schema.table-constraints
		    :where (:= 'table-name '$1))
	   table-name)))

(defun describe-constraint (table-name constraint-name)
  "Return a list of alists of the descriptions a particular constraint given
the table-name and the  constraint name using the information_schema
table."
  (setf table-name (to-sql-name table-name))
  (when (table-exists-p table-name)
    (first
     (query
      (:select 'tc.constraint-name
               'tc.constraint-type
               'tc.table-name
               'kcu.column-name
               'tc.is-deferrable
               'tc.initially-deferred
               (:as 'rc.match-option 'match-type)
               (:as 'rc.update-rule 'on-update)
               (:as 'rc.delete-rule 'on-delete)
               (:as 'ccu.table-name 'references-table)
               (:as 'ccu.column-name 'references-field)
               :from (:as 'information-schema.table-constraints 'tc)
               :left-join (:as 'information-schema.key-column-usage 'kcu)
               :on (:and (:= 'tc.constraint-catalog 'kcu.constraint-catalog)
                         (:= 'tc.constraint-schema 'kcu.constraint-schema)
                         (:= 'tc.constraint-name 'kcu.constraint-name))
               :left-join (:as 'information-schema.referential-constraints
                               'rc)
               :on (:and (:= 'tc.constraint-catalog 'rc.constraint-catalog)
                         (:= 'tc.constraint-schema 'rc.constraint-schema)
                         (:= 'tc.constraint-name 'rc.constraint-name))
               :left-join (:as 'information-schema.constraint-column-usage
                               'ccu)
               :on (:and (:= 'rc.unique-constraint-catalog
                             'ccu.constraint-catalog)
                         (:= 'rc.unique-constraint-schema
                             'ccu.constraint-schema)
                         (:= 'rc.unique-constraint-name 'ccu.constraint-name))
               :where (:and (:= 'tc.table-name '$1)
                            (:= 'tc.constraint-name
                                (to-sql-name constraint-name))))
      table-name :alists))))

(defun describe-foreign-key-constraints ()
  "Generates a list of lists of information on the foreign key constraints"
  (query (:order-by (:select 'conname
                             (:as 'conrelid 'table)
                             (:as 'pgc.relname 'tabname)
                             (:as 'a.attname 'columns)
                             (:as 'confrelid 'foreign-table)
                             (:as 'pgf.relname 'ftabname)
                             (:as 'af.attname 'fcolumn)
                             :from
                             (:as 'pg_attribute 'af)
                             (:as 'pg_attribute 'a)
                             (:as 'pg_class 'pgc)
                             (:as 'pg_class 'pgf)
                             (:as
                              (:select 'conname 'conrelid 'confrelid
                                       (:as (:[] 'conkey 'i) 'conkey)
                                       (:as (:[] 'confkey 'i) 'confkey)
                                       :from (:as
                                              (:select
                                               'conname
                                               'conrelid 'confrelid
                                               'conkey 'confkey
                                               (:as
                                                (:generate-series
                                                 '1
                                                 (:array-upper 'conkey 1))
                                                'i)
                                               :from 'pg_constraint
                                               :where (:= 'contype "f" ))
                                              'ss)
                                       ) 'ss2)
                             :where (:and (:= 'af.attnum 'confkey)
                                          (:= 'af.attrelid 'confrelid)
                                          (:= 'a.attnum 'conkey)
                                          (:= 'a.attrelid 'conrelid)
                                          (:= 'pgf.relfilenode 'confrelid)
                                          (:= 'pgc.relfilenode 'conrelid)))
                    'ftabname 'fcolumn 'tabname 'columns)))


;;;; Triggers
(defun list-triggers (&optional table-name)
  "List distinct trigger names from the information_schema table. Table-name can be either quoted or string."
  (if table-name
      (progn
        (setf table-name (to-sql-name table-name))
        (when (table-exists-p table-name)
          (loop for x in (query
                          (:select (:as 'trg.tgname 'trigger-name)
                                   :from (:as 'pg-trigger 'trg) (:as 'pg-class 'tbl)
                                   :where (:and (:= 'trg.tgrelid 'tbl.oid)
                                                (:= 'tbl.relname '$1)))
                          table-name)
               collect (first x))))
      (loop for x in (query
                      (:select 'trigger-name :distinct
                               :from 'information-schema.triggers
                               :where
                               (:not-in 'trigger-schema
                                        (:set "pg-catalog" "information-schema"))))
           collect (first x))))

(defun list-detailed-triggers ()
  "List detailed information on the triggers from the information_schema table."
  (query
   (:select '*
            :from 'information-schema.triggers
            :where
            (:not-in 'trigger-schema
                     (:set "pg_catalog" "information_schema")))))



;;; Roles
(defun list-database-users ()
  "List database users."
  (loop for x in (query (:order-by
                         (:select 'usename :from 'pg_user)
                         'usename))
     collect (first x)))

;;;; Misc that need to be reorganized

(defun change-toplevel-database (new-database user password host)
  "Just changes the database assuming you are using a toplevel connection.
Recommended only for development work."
  (disconnect-toplevel)
  (connect-toplevel (to-sql-name new-database) user password host)
  (current-database))

(defun list-connections ()
  "Returns info from pg_stat_activity on open connections"
  (query (:select '* :from 'pg-stat-activity)))

(defun list-available-extensions ()
  "Returns available postgresql extensions per pg_available_extensions"
  (loop for x in (query (:order-by (:select 'name :from 'pg-available-extensions)
                                   'name))
     collect (first x)))

(defun list-installed-extensions ()
  "Returns postgresql extensions actually installed in the database per pg_available_extensions"
  (loop for x in (query (:order-by (:select 'extname :from 'pg-extension)
                                   'extname))
       collect (first x)))

#+END_SRC

** [[/Users/Can/Develop/Lisp/document/postmodern/postmodern/transaction.lisp][transaction]]
#+BEGIN_SRC lisp 
(in-package :postmodern)

(defparameter *transaction-level* 0)
(defparameter *current-logical-transaction* nil)
(defparameter *isolation-level* :read-committed-rw)

(defclass transaction-handle ()
  ((open-p :initform t :accessor transaction-open-p)
   (connection :initform *database* :reader transaction-connection)
   (commit-hooks :initform nil :accessor commit-hooks)
   (abort-hooks :initform nil :accessor abort-hooks))
  (:documentation "Simple box type for storing the status and the
associated database connection of a transaction. When open-p is nil,
the transaction has been aborted or committed. commit-hooks and
abort-hooks hold lists of functions (which should require no
arguments) to be executed at commit and abort time, respectively."))

(eval-when (:compile-toplevel :load-toplevel :execute)
     (defun isolation-level-p (item)
       "Checks whether a variable is a valid isolation-level keyword."
       (and item (member item '(:read-committed-rw :read-committed-ro
                                :repeatable-read-rw :repeatable-read-ro
                                :serializable)))))

(defun begin-transaction (&optional (isolation-level *isolation-level*))
  (cond
    ((eq isolation-level :read-committed-rw)
     "BEGIN TRANSACTION ISOLATION LEVEL READ COMMITTED READ WRITE")
    ((eq isolation-level :read-committed-ro)
     "BEGIN TRANSACTION ISOLATION LEVEL READ COMMITTED READ ONLY")
    ((eq isolation-level :repeatable-read-rw)
     "BEGIN TRANSACTION ISOLATION LEVEL REPEATABLE READ READ WRITE")
    ((eq isolation-level :repeatable-read-ro)
     "BEGIN TRANSACTION ISOLATION LEVEL REPEATABLE READ READ ONLY")
    ((eq isolation-level :serializable)
     "BEGIN TRANSACTION ISOLATION LEVEL SERIALIZABLE READ WRITE")
    (t "BEGIN TRANSACTION ISOLATION LEVEL READ COMMITTED READ WRITE")))

(defun call-with-transaction (body &optional (isolation-level *isolation-level*))
  (let ((transaction (make-instance 'transaction-handle)))
    (execute (begin-transaction isolation-level))
    (unwind-protect
         (multiple-value-prog1
             (let ((*transaction-level* (1+ *transaction-level*))
                   (*current-logical-transaction* transaction))
               (funcall body transaction))
           (commit-transaction transaction))
      (abort-transaction transaction))))

(defmacro with-transaction ((&optional name isolation-level) &body body)
  "Execute the body within a database transaction, committing when the
body exits normally, and aborting otherwise. An optional name and/or
isolation-level can be given to the transaction. The name can be used to
force a commit or abort before the body unwinds. The isolation-level
will set the isolation-level used by the transaction."
  (let ((transaction-name (or (when (not (isolation-level-p name))
                                  name)
                              (gensym "anonymous-transaction"))))
    (when (and name (isolation-level-p name))
      (setf isolation-level name))
    `(call-with-transaction (lambda (,transaction-name)
                              (declare (ignorable ,transaction-name)) ,@body)
                            ,isolation-level)))

(defun abort-transaction (transaction)
  "Immediately abort an open transaction."
  (when (transaction-open-p transaction)
    (let ((*database* (transaction-connection transaction)))
      (execute "ABORT"))
    (setf (transaction-open-p transaction) nil)
    (mapc #'funcall (abort-hooks transaction))))

(defun commit-transaction (transaction)
  "Immediately commit an open transaction."
  (when (transaction-open-p transaction)
    (let ((*database* (transaction-connection transaction)))
      (execute "COMMIT"))
    (setf (transaction-open-p transaction) nil)
    (mapc #'funcall (commit-hooks transaction))))


(defclass savepoint-handle (transaction-handle)
  ((name :initform (error "Savepoint name is not provided.")
         :initarg :name :reader savepoint-name)
   (open-p :initform t :accessor savepoint-open-p)
   (connection :initform *database* :reader savepoint-connection))
  (:documentation "Simple box type for storing the state and the
associated database connection of a savepoint."))

(defun call-with-savepoint (name body)
  (let ((savepoint (make-instance 'savepoint-handle :name (to-sql-name name))))
    (execute (format nil "SAVEPOINT ~A" (savepoint-name savepoint)))
    (unwind-protect
         (multiple-value-prog1
             (let ((*transaction-level* (1+ *transaction-level*))
                   (*current-logical-transaction* savepoint))
               (funcall body savepoint))
           (release-savepoint savepoint))
      (rollback-savepoint savepoint))))

(defmacro with-savepoint (name &body body)
  "Execute the body within a savepoint, releasing savepoint when the
body exits normally, and rolling back otherwise. NAME is both the
variable that can be used to release or rolled back before the body
unwinds, and the SQL name of the savepoint."
  `(call-with-savepoint ',name (lambda (,name) (declare (ignorable ,name)) ,@body)))

(defun rollback-savepoint (savepoint)
  "Immediately roll back a savepoint, aborting it results."
  (when (savepoint-open-p savepoint)
    (let ((*database* (savepoint-connection savepoint)))
      (execute (format nil "ROLLBACK TO SAVEPOINT ~A"
                       (savepoint-name savepoint))))
    (setf (savepoint-open-p savepoint) nil)
    (mapc #'funcall (abort-hooks savepoint))))

(defun release-savepoint (savepoint)
  "Immediately release a savepoint, commiting its results."
  (when (savepoint-open-p savepoint)
    (let ((*database* (savepoint-connection savepoint)))
      (execute (format nil "RELEASE SAVEPOINT ~A"
                       (savepoint-name savepoint))))
    (setf (transaction-open-p savepoint) nil)
    (mapc #'funcall (commit-hooks savepoint))))

(defun call-with-logical-transaction (name body &optional (isolation-level *isolation-level*))
  (if (zerop *transaction-level*)
      (call-with-transaction body isolation-level)
      (call-with-savepoint name body)))

(defmacro with-logical-transaction ((&optional (name nil name-p)
                                       (isolation-level *isolation-level* isolation-level-p))
                                    &body body)
  "Executes the body within a with-transaction (if no transaction is
already in progress) or a with-savepoint (if one is), binding the
transaction or savepoint to NAME (if supplied)"
  (let* ((effective-name (if (and name-p (not (isolation-level-p name)))
                             name
                             (gensym)))
         (effective-body (if (and name-p (not (isolation-level-p name)))
                             `(lambda (,name) ,@body)
                             `(lambda (,effective-name)
                                (declare (ignore ,effective-name))
                                ,@body)))
         (effective-isolation-level (cond ((and isolation-level-p (isolation-level-p isolation-level))
                                           isolation-level)
                                          ((and name-p (isolation-level-p name))
                                           name)
                                          (t isolation-level))))
    `(call-with-logical-transaction ',effective-name ,effective-body ,effective-isolation-level)))

(defmethod abort-logical-transaction ((savepoint savepoint-handle))
  (rollback-savepoint savepoint))

(defmethod abort-logical-transaction ((transaction transaction-handle))
  (abort-transaction transaction))

(defmethod commit-logical-transaction ((savepoint savepoint-handle))
  (release-savepoint savepoint))

(defmethod commit-logical-transaction ((transaction transaction-handle))
  (commit-transaction transaction))

(defun call-with-ensured-transaction (thunk &optional (isolation-level *isolation-level*))
  (if (zerop *transaction-level*)
      (with-transaction (nil isolation-level) (funcall thunk))
      (funcall thunk)))

(defmacro ensure-transaction (&body body)
  "Executes body within a with-transaction form if and only if no
transaction is already in progress."
  `(call-with-ensured-transaction (lambda () ,@body)))

(defmacro ensure-transaction-with-isolation-level (isolation-level &body body)
  "Executes body within a with-transaction form if and only if no
transaction is already in progress. This adds the ability to specify an isolatin
level other than the current default"
  `(call-with-ensured-transaction (lambda () ,@body) ,isolation-level))

#+END_SRC

** [[/Users/Can/Develop/Lisp/document/postmodern/postmodern/table.lisp][table]]
#+BEGIN_SRC lisp 
(in-package :postmodern)

(defclass dao-class (standard-class)
  ((direct-keys :initarg :keys :initform nil :reader direct-keys)
   (effective-keys :reader dao-keys)
   (table-name)
   (column-map :reader dao-column-map))
  (:documentation "Metaclass for database-access-object classes."))

(defgeneric dao-keys (class)
  (:documentation "Returns list of slot names that are the primary key of DAO
class. This is likely interesting if you have primary keys which are composed
of more than one slot. Pay careful attention to situations where the primary
key not only has more than one column, but they are actually in a different
order than they are in the database table itself. You can check this with the
find-primary-key-info function."))

(defmethod dao-keys :before ((class dao-class))
  (unless (class-finalized-p class)
               #+postmodern-thread-safe
               (unless (class-finalized-p class)
                 (bordeaux-threads:with-lock-held (*class-finalize-lock*)
                   (unless (class-finalized-p class)
                     (finalize-inheritance class))))
                 #-postmodern-thread-safe
                 (finalize-inheritance class)))

(defmethod validate-superclass ((class dao-class) (super-class standard-class))
  t)

(defmethod dao-keys ((class-name symbol))
  (dao-keys (find-class class-name)))

(defmethod dao-keys (dao)
  (mapcar #'(lambda (slot)
              (slot-value dao slot))
          (dao-keys (class-of dao))))

(defun dao-column-slots (class)
  "Enumerate the slots in a class that refer to table rows."
  (mapcar 'slot-column
          (remove-if-not (lambda (x) (typep x 'effective-column-slot))
                         (class-slots class))))
(defun dao-column-fields (class)
  (mapcar 'slot-definition-name (dao-column-slots class)))

(defun dao-table-name (class)
  (when (symbolp class)
    (setf class (find-class class)))
  (if (slot-boundp class 'table-name)
      (slot-value class 'table-name)
      (class-name class)))

(defmethod shared-initialize :before ((class dao-class) slot-names
                                      &key table-name &allow-other-keys)
  (declare (ignore slot-names))
  (setf (slot-value class 'direct-keys) nil)
  (if table-name
      (setf (slot-value class 'table-name)
            (if (symbolp (car table-name)) (car table-name) (intern (car table-name))))
      (slot-makunbound class 'table-name)))

(defun dao-superclasses (class)
  "Build a list of superclasses of a given class that are DAO
  classes."
  (let ((found ()))
    (labels ((explore (class)
               (when (typep class 'dao-class)
                 (pushnew class found))
               (mapc #'explore (class-direct-superclasses class))))
      (explore class)
      found)))

(defmethod finalize-inheritance :after ((class dao-class))
  "Building a row reader and a set of methods can only be done after
  inheritance has been finalised."
  ;; The effective set of keys of a class is the union of its keys and
  ;; the keys of all its superclasses.
  (setf (slot-value class 'effective-keys)
        (reduce 'union (mapcar 'direct-keys (dao-superclasses class))))
  (unless (every (lambda (x) (member x (dao-column-fields class))) (dao-keys class))
    (error "Class ~A has a key that is not also a slot." (class-name class)))
  (build-dao-methods class))


(defclass direct-column-slot (standard-direct-slot-definition)
  ((col-type :initarg :col-type :reader column-type)
   (col-default :initarg :col-default :reader column-default)
   (ghost :initform nil :initarg :ghost :reader ghost)
   (sql-name :reader slot-sql-name))
  (:documentation "Type of slots that refer to database columns."))

(defmethod shared-initialize :after ((slot direct-column-slot) slot-names
                                     &key col-type col-default (col-name nil col-name-p) &allow-other-keys)
  (declare (ignore slot-names))
  (setf (slot-value slot 'sql-name) (to-sql-name
                                     (if col-name-p
                                         col-name
                                         (slot-definition-name slot))
                                     s-sql:*escape-sql-names-p* t))
  ;; The default for nullable columns defaults to :null.
  (when (and (null col-default) (consp col-type) (eq (car col-type) 'or)
             (member 'db-null col-type) (= (length col-type) 3))
    (setf (slot-value slot 'col-default) :null)))

(defmethod direct-slot-definition-class ((class dao-class) &key column col-type &allow-other-keys)
  "Slots that have a :col-type option are column-slots."
  (if (or column col-type)
      (find-class 'direct-column-slot)
      (call-next-method)))

(defparameter *direct-column-slot* nil
  "This is used to communicate the fact that a slot is a column to
  effective-slot-definition-class.")

(defclass effective-column-slot (standard-effective-slot-definition)
  ((direct-slot :initform *direct-column-slot* :reader slot-column)))

(defmethod compute-effective-slot-definition ((class dao-class) name direct-slot-definitions)
  (declare (ignore name))
  (flet ((is-column (slot) (typep slot 'direct-column-slot)))
    (let ((*direct-column-slot* (find-if #'is-column direct-slot-definitions)))
      #+(or) ;; Things seem to work without this check. Removed for now.
      (when (and *direct-column-slot*
                 (not (every #'is-column direct-slot-definitions)))
        (error "Slot ~a in class ~a is both a column slot and a regular slot." name class))
      (call-next-method))))

(defmethod effective-slot-definition-class ((class dao-class) &rest initargs)
  (declare (ignore initargs))
  (if *direct-column-slot*
      (find-class 'effective-column-slot)
      (call-next-method)))

(defgeneric dao-exists-p (dao)
  (:documentation "Return a boolean indicating whether the given dao
  exists in the database."))
(defgeneric insert-dao (dao)
  (:documentation "Insert the given object into the database."))
(defgeneric update-dao (dao)
  (:documentation "Update the object's representation in the database
  with the values in the given instance."))
(defgeneric delete-dao (dao)
  (:documentation "Delete the given dao from the database."))
(defgeneric upsert-dao (dao)
  (:documentation "Update or insert the given dao.  If its primary key
  is already in the database and all slots are bound, an update will
  occur.  Otherwise it tries to insert it."))
(defgeneric get-dao (type &rest args)
  (:method ((class-name symbol) &rest args)
    (let ((class (find-class class-name)))
      (unless (class-finalized-p class)
               #+postmodern-thread-safe
               (unless (class-finalized-p class)
                 (bordeaux-threads:with-lock-held (*class-finalize-lock*)
                   (unless (class-finalized-p class)
                     (finalize-inheritance class))))
                 #-postmodern-thread-safe
                 (finalize-inheritance class-name))
      (when (not (dao-keys class)) (error "Class ~a has no key slots." (class-name class)))
      (apply 'get-dao class-name args)))
  (:documentation "Get the object corresponding to the given primary
  key, or return nil if it does not exist."))
(defgeneric make-dao (type &rest args &key &allow-other-keys)
  (:method ((class-name symbol) &rest args &key &allow-other-keys)
    (let ((class (find-class class-name)))
      (apply 'make-dao class args)))
  (:method ((class dao-class) &rest args &key &allow-other-keys)
    (unless (class-finalized-p class)
               #+postmodern-thread-safe
               (unless (class-finalized-p class)
                 (bordeaux-threads:with-lock-held (*class-finalize-lock*)
                   (unless (class-finalized-p class)
                     (finalize-inheritance class))))
                 #-postmodern-thread-safe
                 (finalize-inheritance class))
    (let ((instance (apply #'make-instance class args)))
      (insert-dao instance)))
  (:documentation "Make the instance of the given class and insert it into the database"))

(defmacro define-dao-finalization (((dao-name class) &rest keyword-args) &body body)
  (let ((args-name (gensym)))
    `(defmethod make-dao :around ((class (eql ',class))
				  &rest ,args-name
				  &key ,@keyword-args &allow-other-keys)
       (declare (ignorable ,args-name))
       (let ((,dao-name (call-next-method)))
	 ,@body
	 (update-dao ,dao-name)))))

(defgeneric fetch-defaults (object)
  (:documentation "Used to fetch the default values of an object on
  creation."))

(defun %eval (code)
  (funcall (compile nil `(lambda () ,code))))

(defun build-dao-methods (class)
  "Synthesise a number of methods for a newly defined DAO class.
\(Done this way because some of them are not defined in every
situation, and each of them needs to close over some pre-computed
values. Notes for future maintenance: Fields are the slot names
in a dao class. Field-sql-name returns the col-name for the
postgresql table, which may or may not be the same as the slot
names in the class and also may have no relation to the initarg
or accessor or reader.)"

  (setf (slot-value class 'column-map)
        (mapcar (lambda (s) (cons (slot-sql-name s) (slot-definition-name s))) (dao-column-slots class)))

  (%eval
    `(let* ((fields (dao-column-fields ,class))
            (key-fields (dao-keys ,class))
            (ghost-slots (remove-if-not 'ghost (dao-column-slots ,class)))
            (ghost-fields (mapcar 'slot-definition-name ghost-slots))
            (value-fields (remove-if (lambda (x) (or (member x key-fields) (member x ghost-fields))) fields))
            (table-name (dao-table-name ,class)))
       (labels ((field-sql-name (field)
                  (make-symbol (car (find field (slot-value ,class 'column-map) :key #'cdr :test #'eql))))
                (test-fields (fields)
                  `(:and ,@(loop :for field :in fields :collect (list := (field-sql-name field) '$$))))
                (set-fields (fields)
                  (loop :for field :in fields :append (list (field-sql-name field) '$$)))
                (slot-values (object &rest slots)
                  (loop :for slot :in (apply 'append slots) :collect (slot-value object slot))))

         ;; When there is no primary key, a lot of methods make no sense.
         (when key-fields
           (let ((tmpl (sql-template `(:select (:exists (:select t :from ,table-name
                                                                 :where ,(test-fields key-fields)))))))
             (defmethod dao-exists-p ((object ,class))
               (and (every (lambda (s) (slot-boundp object s)) key-fields)
                    (query (apply tmpl (slot-values object key-fields)) :single))))

           ;; When all values are primary keys, updating makes no sense.
           (when value-fields
             (let ((tmpl (sql-template `(:update ,table-name :set ,@(set-fields value-fields)
                                         :where ,(test-fields key-fields)))))
               (defmethod update-dao ((object ,class))
                 (when (zerop (execute (apply tmpl (slot-values object value-fields key-fields))))
                   (error "Updated row does not exist."))
                 object)

               (defmethod upsert-dao ((object ,class))
                 (handler-case
                     (if (zerop (execute (apply tmpl (slot-values object value-fields key-fields))))
                         (values (insert-dao object) t)
                         (values object nil))
                   (unbound-slot ()
                     (values (insert-dao object) t))))))

           (let ((tmpl (sql-template `(:delete-from ,table-name :where ,(test-fields key-fields)))))
             (defmethod delete-dao ((object ,class))
               (execute (apply tmpl (slot-values object key-fields)))))

           (let ((tmpl (sql-template `(:select * :from ,table-name :where ,(test-fields key-fields)))))
             (defmethod get-dao ((type (eql (class-name ,class))) &rest keys)
               (car (exec-query *database* (apply tmpl keys) (dao-row-reader ,class))))))

         (defmethod insert-dao ((object ,class))
           (let (bound unbound)
             (loop :for field :in fields
                :do (if (slot-boundp object field)
                        (push field bound)
                        (push field unbound)))
             (let* ((values (mapcan (lambda (x) (list (field-sql-name x) (slot-value object x)))
                                    (remove-if (lambda (x) (member x ghost-fields)) bound) ))
                    (returned (query (sql-compile `(:insert-into ,table-name
                                                                 :set ,@values
                                                                 ,@(when unbound (cons :returning unbound))))
                                     :row)))
               (when unbound
                 (loop :for value :in returned
                    :for field :in unbound
                    :do (setf (slot-value object field) value)))))
           object)


         (let* ((defaulted-slots (remove-if-not (lambda (x) (slot-boundp x 'col-default))
                                                (dao-column-slots ,class)))
                (defaulted-names (mapcar 'slot-definition-name defaulted-slots))
                (default-values (mapcar 'column-default defaulted-slots)))
           (if defaulted-slots
               (defmethod fetch-defaults ((object ,class))
                 (let (names defaults)
                   ;; Gather unbound slots and their default expressions.
                   (loop :for slot-name :in defaulted-names
                      :for default :in default-values
                      :do (unless (slot-boundp object slot-name)
                            (push slot-name names)
                            (push default defaults)))
                   ;; If there are any unbound, defaulted slots, fetch their content.
                   (when names
                     (loop :for value :in (query (sql-compile (cons :select defaults)) :list)
                        :for slot-name :in names
                        :do (setf (slot-value object slot-name) value)))))
               (defmethod fetch-defaults ((object ,class))
                 nil)))

         (defmethod shared-initialize :after ((object ,class) slot-names
                                              &key (fetch-defaults nil) &allow-other-keys)
           (declare (ignore slot-names))
           (when fetch-defaults
             (fetch-defaults object)))))))

(defparameter *custom-column-writers* nil
  "A hook for locally overriding/adding behaviour to DAO row readers.
Should be an alist mapping strings (column names) to symbols or
functions. Symbols are interpreted as slot names that values should be
written to, functions are called with the new object and the value as
arguments.")

(defmacro with-column-writers ((&rest defs) &body body)
  `(let ((*custom-column-writers* (append (list ,@(loop :for (field writer) :on defs :by #'cddr
                                                        :collect `(cons (to-sql-name ,field nil) ,writer)))
                                          *custom-column-writers*)))
    ,@body))

(defparameter *ignore-unknown-columns* nil)

(defun dao-from-fields (class column-map query-fields result-next-field-generator-fn)
  (let ((instance (allocate-instance class)))
    (loop :for field :across query-fields
         :for writer := (cdr (assoc (field-name field) column-map :test #'string=))
         :do (etypecase writer
               (null (if *ignore-unknown-columns*
                         (funcall result-next-field-generator-fn field)
                         (error "No slot named ~a in class ~a. DAO out of sync with table, or incorrect query used."
                                (field-name field) (class-name class))))
               (symbol (setf (slot-value instance writer) (funcall result-next-field-generator-fn field)))
               (function (funcall writer instance (funcall result-next-field-generator-fn field)))))
    (initialize-instance instance)
    instance))

(defun dao-row-reader (class)
  "Defines a row-reader for objects of a given class."
  (row-reader (query-fields)
    (let ((column-map (append *custom-column-writers* (dao-column-map class))))
      (loop :while (next-row)
            :collect (dao-from-fields class column-map query-fields #'next-field)))))

(defun save-dao (dao)
  "Try to insert the content of a DAO. If this leads to a unique key
violation, update it instead."
  (handler-case (progn (insert-dao dao) t)
    (cl-postgres-error:unique-violation ()
      (update-dao dao)
      nil)
    (cl-postgres-error:columns-error ()
      (update-dao dao)
      nil)))

(defun save-dao/transaction (dao)
  (handler-case (with-savepoint save-dao/transaction (insert-dao dao) t)
    (cl-postgres-error:unique-violation ()
      (update-dao dao)
      nil)
    (cl-postgres-error:columns-error ()
      (update-dao dao)
      nil)))

(defun query-dao% (type query row-reader &rest args)
  (let ((class (find-class type)))
    (unless (class-finalized-p class)
      #+postmodern-thread-safe
      (unless (class-finalized-p class)
        (bordeaux-threads:with-lock-held (*class-finalize-lock*)
          (unless (class-finalized-p class)
            (finalize-inheritance class))))
      #-postmodern-thread-safe
      (finalize-inheritance class))
    (if args
	(progn
	  (prepare-query *database* "" query)
	  (exec-prepared *database* "" args row-reader))
	(exec-query *database* query row-reader))))

(defmacro query-dao (type query &rest args)
  "Execute a query and return the result as daos of the given type.
The fields returned by the query must match the slots of the dao, both
by type and by name."
  `(query-dao% ,type ,(real-query query) (dao-row-reader (find-class ,type)) ,@args))

(defmacro dao-row-reader-with-body ((type type-var) &body body)
  (let ((fields (gensym))
        (column-map (gensym)))
    `(row-reader (,fields)
       (let ((,column-map (append *custom-column-writers* (dao-column-map (find-class ,type)))))
         (loop :while (next-row)
            :do (let ((,type-var (dao-from-fields (find-class ,type) ,column-map ,fields #'next-field)))
                  ,@body))))))

(defmacro do-query-dao (((type type-var) query) &body body)
  "Like query-dao, but rather than returning a list of results,
executes BODY once for each result, with TYPE-VAR bound to the DAO
representing that result."
  (let (args)
    (when (and (consp query) (not (keywordp (first query))))
      (setf args (cdr query) query (car query)))
    `(query-dao% ,type ,(real-query query)
                 (dao-row-reader-with-body (,type ,type-var)
                   ,@body)
                 ,@args)))

(defun generate-dao-query (type &optional (test t) ordering)
  (flet ((check-string (x)
           (if (stringp x) `(:raw ,x) x)))
    (let ((query `(:select '* :from (dao-table-name (find-class ,type))
                   :where ,(check-string test))))
      (when ordering
        (setf query `(:order-by ,query ,@(mapcar #'check-string ordering))))
      query)))

(defmacro select-dao (type &optional (test t) &rest ordering)
  "Select daos for the rows in its table for which the given test
holds, order them by the given criteria."
  `(query-dao% ,type (sql ,(generate-dao-query type test ordering)) (dao-row-reader (find-class ,type))))

(defmacro do-select-dao (((type type-var) &optional (test t) &rest ordering) &body body)
  "Like select-dao, but rather than returning a list of results,
executes BODY once for each result, with TYPE-VAR bound to the DAO
representing that result."
  `(query-dao% ,type (sql ,(generate-dao-query type test ordering))
               (dao-row-reader-with-body (,type ,type-var)
                 ,@body)))

(defun dao-table-definition (table)
  "Generate the appropriate CREATE TABLE query for this class."
  (unless (typep table 'dao-class)
    (setf table (find-class table)))
      (unless (class-finalized-p table)
      #+postmodern-thread-safe
      (unless (class-finalized-p table)
        (bordeaux-threads:with-lock-held (*class-finalize-lock*)
          (unless (class-finalized-p table)
            (finalize-inheritance table))))
      #-postmodern-thread-safe
      (finalize-inheritance table))
  (sql-compile
   `(:create-table ,(dao-table-name table)
                   ,(loop :for slot :in (dao-column-slots table)
                          :unless (ghost slot)
                          :collect `(,(slot-definition-name slot) :type ,(column-type slot)
                                     ,@(when (slot-boundp slot 'col-default)
                                             `(:default ,(column-default slot)))))
                   ,@(when (dao-keys table)
                       `((:primary-key ,@(dao-keys table)))))))

#+END_SRC

** [[/Users/Can/Develop/Lisp/document/postmodern/postmodern/query.lisp][query]]
#+BEGIN_SRC lisp 
(in-package :postmodern)

;; Like alist-row-reader from cl-postgres, but converts the field
;; names to keywords (with underscores converted to dashes).
(def-row-reader symbol-alist-row-reader (fields)
  (let ((symbols (map 'list (lambda (desc) (from-sql-name (field-name desc))) fields)))
    (loop :while (next-row)
          :collect (loop :for field :across fields
                         :for symbol :in symbols
                         :collect (cons symbol (next-field field))))))

;; Like symbol-alist-row-reader, but return plist
(def-row-reader symbol-plist-row-reader (fields)
  (let ((symbols (map 'list (lambda (desc) (from-sql-name (field-name desc))) fields)))
    (loop :while (next-row)
          :collect (loop :for field :across fields
                         :for symbol :in symbols
                         :collect symbol :collect (next-field field)))))

;; Converts field names to hash table keys and returns an array of rows
(def-row-reader array-hash-row-reader (fields)
  (loop :while (next-row)
     :collect (loop :for field :across fields
                 with hash = (make-hash-table :test 'equal)
                 do  (setf (gethash  (field-name field) hash)
                           (next-field field))
                 finally (return hash)) into result
     :finally (return (make-array (length result)
                                  :initial-contents result))))

;; A row-reader for reading only a single column, and returning a list
;; of single values.
(def-row-reader column-row-reader (fields)
  (assert (= (length fields) 1))
  (loop :while (next-row)
        :collect (next-field (elt fields 0))))

(defvar *class-finalize-lock* (bt:make-lock))

(defparameter *result-styles*
  '((:none ignore-row-reader all-rows)
    (:lists list-row-reader all-rows)
    (:list list-row-reader single-row)
    (:rows list-row-reader all-rows)
    (:row list-row-reader single-row)
    (:alists symbol-alist-row-reader all-rows)
    (:alist symbol-alist-row-reader single-row)
    (:str-alists alist-row-reader all-rows)
    (:str-alist alist-row-reader single-row)
    (:plists symbol-plist-row-reader all-rows)
    (:plist symbol-plist-row-reader single-row)
    (:array-hash array-hash-row-reader all-rows)
    (:column column-row-reader all-rows)
    (:single column-row-reader single-row)
    (:single! column-row-reader single-row!))
  "Mapping from keywords identifying result styles to the row-reader
that should be used and whether all values or only one value should be
returned.")

(defun dao-spec-for-format (format)
  (if (and (consp format)
	   (eq :dao (car format)))
      (cdr format)))

(defun reader-for-format (format)
  (let ((format-spec (cdr (assoc format *result-styles*))))
    (if format-spec
	`(',(car format-spec) ,@(cdr format-spec))
	(destructuring-bind (class-name &optional result)
	    (dao-spec-for-format format)
	  (unless class-name
	    (error "~S is not a valid result style." format))
	  (let ((class (gensym)))
	    (list `(let ((,class (find-class ',class-name)))
		     (unless (class-finalized-p ,class)
		       #+postmodern-thread-safe
		       (bordeaux-threads:with-lock-held (*class-finalize-lock*)
			 (unless (class-finalized-p ,class)
			   (finalize-inheritance ,class)))
		       #-postmodern-thread-safe
		       (finalize-inheritance ,class))
		     (dao-row-reader ,class))
		  (if (eq result :single)
		      'single-row
		      'all-rows)))))))

(defmacro all-rows (form)
  form)

(defmacro single-row (form)
  `(multiple-value-bind (rows affected) ,form
    (if affected (values (car rows) affected) (car rows))))

(defmacro single-row! (form)
  `(multiple-value-bind (rows affected) ,form
    (unless (= (length rows) 1)
      (error 'database-error :message (format nil "Query for a single row returned ~a rows." (length rows))))
    (if affected (values (car rows) affected) (car rows))))

(defun real-query (query)
  "Used for supporting both plain string queries and S-SQL constructs.
Looks at the argument at compile-time and wraps it in (sql ...) if it
looks like an S-SQL query."
  (if (and (consp query) (keywordp (first query)))
      `(sql ,query)
      query))

(defmacro query (query &rest args/format)
  "Execute a query, optionally with arguments to put in the place of
$X elements. If one of the arguments is a known result style or a class name,
it specifies the format in which the results should be returned."
  (let* ((format :rows)
         (args (loop :for arg :in args/format
		              :if (or (dao-spec-for-format arg)
			                    (assoc arg *result-styles*)) :do (setf format arg)
                  :else :collect arg)))
    (destructuring-bind (reader result-form) (reader-for-format format)
      (let ((base (if args
		                  (let ((vars (loop :for x :in args :collect (gensym))))
			                  `(let ,(loop :for v :in vars :for a :in args :collect `(,v ,a))
			                     (prepare-query *database* "" ,(real-query query))
			                     (exec-prepared *database* "" (list ,@vars) ,reader)))
		                  `(exec-query *database* ,(real-query query) ,reader))))
        `(,result-form ,base)))))

(defmacro execute (query &rest args)
  "Execute a query, ignore the results."
  `(let ((rows (nth-value 1 (query ,query ,@args :none))))
     (if rows (values rows rows) 0)))

(defmacro doquery (query (&rest names) &body body)
 "Iterate over the rows in the result of a query, binding the given
names to the results and executing body for every row. Query can be a
string, an s-sql query, or a list starting with one of those, followed
by the arguments to parameterize the query with."
 (let* ((fields (gensym))
        (query-name (gensym))
        args
        (reader-expr
          `(row-reader (,fields)
             (unless (= ,(length names) (length ,fields))
               (error "Number of field names does not match number of selected fields in query ~A." ,query-name))
             (loop :while (next-row)
                   :do (let ,(loop :for i :from 0
                                   :for name :in names
                                   :collect `(,name (next-field (elt ,fields ,i))))
                         ,@body)))))
   (when (and (consp query) (not (keywordp (first query))))
     (setf args (cdr query) query (car query)))
   (if args
       `(let ((,query-name ,(real-query query)))
          (prepare-query *database* "" ,query-name)
          (exec-prepared *database* "" (list ,@args) ,reader-expr))
       `(let ((,query-name ,(real-query query)))
          (exec-query *database* ,query-name ,reader-expr)))))

#+END_SRC

** [[/Users/Can/Develop/Lisp/document/postmodern/postmodern/prepare.lisp][prepare]]
#+BEGIN_SRC lisp 
(in-package :postmodern)

(defparameter *allow-overwriting-prepared-statements* t
  "When set to t, ensured-prepared will overwrite prepared statements having
the same name if the query statement itself in the postmodern meta connection
is different than the query statement provided to ensure-prepared.")

(defun ensure-prepared (connection id query &optional (overwrite nil))
  "Make sure a statement has been prepared for this connection. If overwrite is
set to t (not the default), it will overwrite the existing query of the same
name."
  (let ((meta (connection-meta connection)))
    (unless (and (gethash id meta)
                 (if overwrite
                     (equal (gethash id meta) query)
                     t))
      (setf (gethash id meta) query)
      (prepare-query connection id query))))

(let ((next-id 0))
  (defun next-statement-id ()
    "Provide unique statement names."
    (incf next-id)
    (with-standard-io-syntax (format nil "STATEMENT_~A" next-id))))

(defun generate-prepared (function-form name query format)
  "Helper function for the following two macros. Note that it will attempt to
automatically reconnect if database-connection-error, or admin-shutdown. It
will reset any prepared statements triggering an invalid-sql-statement-name
error. The generated function will overwrite old prepared statements triggering
a duplicate-prepared-statement error and will pre-emptively overwrite an existing
prepared statement of the same name the first time generate-prepared is called
for this function name. Subsequent calls to the generated function will not
overwrite unless postgresql throws a duplicate-prepared-statement error."
  (destructuring-bind (reader result-form) (reader-for-format format)
    (let ((base `(exec-prepared *database* statement-id params ,reader)))
      `(let ((statement-id ,(string name))
             (query ,(real-query query)))
         (,@function-form (&rest params)
                          (handler-bind
                              ((postmodern:database-connection-error
                                (lambda (msg1)
                                  (format *error-output* "~%Database-connection-error ~a~%" msg1)
                                  (invoke-restart :reconnect))))
                            (handler-bind ((cl-postgres-error:admin-shutdown
                                            (lambda (msg2)
                                              (declare (ignore msg2))
                                              (invoke-restart :reconnect))))
                              (cl-postgres::with-reconnect-restart *database*
                                (handler-bind
                                    ((cl-postgres-error:invalid-sql-statement-name #'pomo:reset-prepared-statement)
                                     (cl-postgres-error:duplicate-prepared-statement #'pomo:reset-prepared-statement))
                                  (if overwrite
                                      (progn
                                        (setf overwrite nil)
                                        (ensure-prepared *database* statement-id query t))
                                    (ensure-prepared *database* statement-id query overwrite))
                                  (,result-form ,base))))))))))

(defmacro prepare (query &optional (format :rows))
  "Wraps a query into a function that will prepare it once for a
connection, and then execute it with the given parameters. The query
should contain a placeholder \($1, $2, etc) for every parameter."
  `(let ((overwrite t))
     ,(generate-prepared '(lambda) (next-statement-id) query format)))

(defmacro defprepared (name query &optional (format :rows))
  "Like prepare, but gives the function a name instead of returning
it. The name should not be a string but may be quoted."
  (when (consp name) (setf name (s-sql::dequote name)))
  `(let ((overwrite t))
     ,(generate-prepared `(defun ,name) name query format)))

(defmacro defprepared-with-names (name (&rest args)
				  (query &rest query-args)
				  &optional (format :rows))
  "Like defprepared, but with lambda list for statement arguments."
  (let ((prepared-name (gensym "PREPARED")))
    `(let ((,prepared-name (prepare ,query ,format)))
       (declare (type function ,prepared-name))
       (defun ,name ,args
	       (funcall ,prepared-name ,@query-args)))))

(defun prepared-statement-exists-p (name)
  "Returns t if the prepared statement exists in the current postgresql
session, otherwise nil."
  (if (query (:select 'name
                   :from 'pg-prepared-statements
                   :where (:= 'name (string-upcase name)))
             :single)
      t
      nil))

(defun list-prepared-statements (&optional (names-only nil))
  "Syntactic sugar. A query that lists the prepared statements
in the session in which the function is run. If the optional
names-only parameter is set to t, it will only return a list
of the names of the prepared statements."
  (if names-only
      (alexandria:flatten (query "select name from pg_prepared_statements"))
      (query "select * from pg_prepared_statements" :alists)))

(defun drop-prepared-statement (name &key (location :both) (database *database*) (remove-function t))
  "Prepared statements are stored both in the meta slot in the postmodern
connection and in postgresql session information. In the case of prepared
statements generated with defprepared, there is also a lisp function with
the same name.

If you know the prepared statement name, you can delete the prepared statement
from both locations (the default behavior), just from postmodern by passing
:postmodern to the location key parameter or just from postgresql by passing
:postgresql to the location key parameter.

If you pass the name 'All' as the statement name, it will
delete all prepared statements.

The default behavior is to also remove any lisp function of the same name.
This behavior is controlled by the remove-function key parameter."
  (when (symbolp name) (setf name (string name)))
  (check-type name string)
  (check-type location keyword)
  (setf name (string-upcase name))
  (when database
    (cond ((eq location :both)
           (cond ((equal name "ALL")
                  (maphash #'(lambda (x y)
                               (declare (ignore y))
                               (remhash x (connection-meta database))
                               (when (and remove-function (find-symbol (string-upcase x))
                                 (fmakunbound (find-symbol (string-upcase x))))))
                           (connection-meta database))
                 (clrhash (connection-meta database))
                 (query "deallocate ALL"))
                (t
                 (remhash name (connection-meta database))
                 (handler-case
                     (query (format nil "deallocate ~:@(~S~)" name))
                   (cl-postgres-error:invalid-sql-statement-name ()
                     (format t "Statement does not exist ~a~%" name)))
                 (when (and remove-function (find-symbol (string-upcase name)))
                   (fmakunbound (find-symbol (string-upcase name)))))))
         ((eq location :postmodern)
          (if (equal name "ALL")
              (maphash #'(lambda (x y)
                           (declare (ignore y))
                               (remhash x (connection-meta database))
                               (when (and remove-function (find-symbol (string-upcase x)))
                                 (fmakunbound (find-symbol (string-upcase x)))))
                           (connection-meta database))
            (progn
              (remhash (string-upcase name)
                       (connection-meta database))
              (when (and remove-function (find-symbol (string-upcase name)))
                   (fmakunbound (find-symbol (string-upcase name)))))))
         ((eq location :postgresql)
          (cond ((equal name "ALL")
                 (query "deallocate ALL"))
                (t (handler-case
                       (query (format nil "deallocate ~:@(~S~)" name))
                     (cl-postgres-error:invalid-sql-statement-name ()
                       (format t "Statement does not exist ~a~%" name)))))))))

(defun list-postmodern-prepared-statements (&optional (names-only nil))
  "List the prepared statements that postmodern has put in the meta slot in
the connection. It will return a list of alists of form:
  ((:NAME . \"SNY24\")
  (:STATEMENT . \"(SELECT name, salary FROM employee WHERE (city = $1))\")
  (:PREPARE-TIME . #<TIMESTAMP 25-11-2018T15:36:43,385>)
  (:PARAMETER-TYPES . \"{text}\") (:FROM-SQL).

If the names-only parameter is set to t, it will only return a list of
the names of the prepared statements."
  (if names-only
      (alexandria:hash-table-keys (postmodern::connection-meta *database*))
      (alexandria:hash-table-alist (postmodern::connection-meta *database*))))

(defun find-postgresql-prepared-statement (name)
  "Returns the specified named prepared statement (if any) that postgresql
has for this session."
  (query (:select 'statement
                  :from 'pg-prepared-statements
                  :where (:= 'name (string-upcase name)))
         :single))

(defun find-postmodern-prepared-statement (name)
  "Returns the specified named prepared statement (if any) that postmodern has put in
the meta slot in the connection."
  (gethash (string-upcase name) (postmodern::connection-meta *database*)))

(defun reset-prepared-statement (condition)
  "If you have received an invalid-prepared-statement error or a prepared-statement
already exists error but the prepared statement is still in the meta slot in
the postmodern connection, try to regenerate the prepared statement at the
database connection level and restart the connection."
  (let* ((name (pomo:database-error-extract-name condition))
         (statement (find-postmodern-prepared-statement name))
         (pid (write-to-string (first (cl-postgres::connection-pid *database*)))))
    (setf (cl-postgres::connection-available *database*) t)
    (when statement
      (cl-postgres::with-reconnect-restart *database*
        (terminate-backend pid))
      (cl-postgres:prepare-query *database* name statement)
      (invoke-restart 'reset-prepared-statement))))

(defun get-pid ()
  "Get the process id used by postgresql for this connection."
  (query "select pg_backend_pid()" :single))

(defun get-pid-from-postmodern ()
  "Get the process id used by postgresql for this connection,
but get it from the postmodern connection parameters."
  (gethash "pid" (pomo::connection-parameters *database*)))

(defun cancel-backend (pid &optional (database *database*))
  "Polite way of terminating a query at the database (as opposed to calling close-database).
Slower than (terminate-backend pid) and does not always work."
    (let ((database-name (cl-postgres::connection-db database))
        (user (cl-postgres::connection-user database))
        (password (cl-postgres::connection-password database))
        (host (cl-postgres::connection-host database)))
    (with-connection `(,database-name ,user ,password ,host)
      (query "select pg_cancel_backend($1);" pid))))

(defun terminate-backend (pid &optional (database *database*))
  "Less polite way of terminating at the database (as opposed to calling close-database).
Faster than (cancel-backend pid) and more reliable."
  (let ((database-name (cl-postgres::connection-db database))
        (user (cl-postgres::connection-user database))
        (password (cl-postgres::connection-password database))
        (host (cl-postgres::connection-host database)))
    (with-connection `(,database-name ,user ,password ,host)
      (query "select pg_terminate_backend($1);" pid))))

#+END_SRC

** [[/Users/Can/Develop/Lisp/document/postmodern/postmodern/package.lisp][package]]
#+BEGIN_SRC lisp 
(defpackage :postmodern
  (:use #-postmodern-use-mop :common-lisp
        #+postmodern-use-mop :closer-common-lisp
        :s-sql :cl-postgres)
  (:nicknames :pomo)

  #+postmodern-use-mop
  (:export
   #:dao-class #:dao-exists-p #:dao-keys #:query-dao #:select-dao #:get-dao #:do-query-dao #:do-select-dao
   #:with-column-writers
   #:insert-dao #:update-dao #:save-dao #:save-dao/transaction #:upsert-dao #:delete-dao #:make-dao
   #:define-dao-finalization
   #:dao-table-name #:dao-table-definition
   #:\!dao-def #:*ignore-unknown-columns*)

  (:export
   #:connect #:disconnect #:reconnect
   #:call-with-connection #:with-connection
   #:*database* #:connected-p #:database-connection
   #:connect-toplevel #:disconnect-toplevel
   #:clear-connection-pool #:*max-pool-size* #:*default-use-ssl*
   #:list-connections
   #:query #:execute #:doquery
   #:prepare #:defprepared #:defprepared-with-names
   #:sequence-next #:list-sequences #:sequence-exists-p
   #:create-sequence #:drop-sequence
   #:list-tables #:table-exists-p #:table-description
   #:list-views #:view-exists-p
   #:*current-logical-transaction* #:*isolation-level* #:with-transaction
   #:commit-transaction #:abort-transaction
   #:with-savepoint #:rollback-savepoint #:release-savepoint
   #:with-logical-transaction #:ensure-transaction
   #:ensure-transaction-with-isolation-level
   #:abort-hooks #:commit-hooks
   #:db-null #:coalesce
   #:database-version #:num-records-in-database #:current-database
   #:database-exists-p #:database-size #:list-databases
   #:list-schemas #:list-tablespaces #:list-available-types
   #:list-table-sizes #:table-size #:more-table-info
   #:list-columns #:list-columns-with-types #:column-exists-p
   #:describe-views #:list-database-functions #:list-indices
   #:index-exists-p #:create-index #:drop-index
   #:list-table-indices #:list-indexed-column-and-attributes
   #:list-index-definitions #:list-foreign-keys #:list-unique-or-primary-constraints
   #:list-all-constraints #:describe-constraint #:describe-foreign-key-constraints
   #:list-triggers #:list-detailed-triggers #:list-database-users
   #:find-primary-key-info
   #:change-toplevel-database
   #:list-available-extensions

   #:deftable #:*table-name* #:*table-symbol*
   #:create-table #:create-all-tables #:create-package-tables
   #:\!index #:\!unique-index #:\!foreign #:\!unique
   #:create-schema #:drop-schema #:list-schemata
   #:with-schema #:schema-exists-p #:set-search-path #:get-search-path
   #:list-tables-in-schema
   #:split-fully-qualified-tablename

   ;; Prepared Statement Functions
   #:*allow-overwriting-prepared-statements*
   #:prepared-statement-exists-p #:list-prepared-statements
   #:drop-prepared-statement #:list-postmodern-prepared-statements
   #:find-postmodern-prepared-statement
   #:find-postgresql-prepared-statement
   #:reset-prepared-statement
   #:get-pid #:cancel-backend #:terminate-backend
   #:get-pid-from-postmodern

   ;; Reduced S-SQL interface
   #:sql #:sql-compile
   #:smallint #:bigint #:numeric #:real #:double-precision
   #:bytea #:text #:varchar
   #:*escape-sql-names-p* #:sql-escape-string #:sql-escape #:register-sql-operators
   #:sql-error

   ;; Condition type from cl-postgres
   #:database-error #:database-error-message #:database-error-code
   #:database-error-detail #:database-error-query #:database-error-cause
   #:database-connection-error #:database-error-constraint-name
   #:database-error-extract-name))

(in-package :postmodern)

#+END_SRC

** [[/Users/Can/Develop/Lisp/document/postmodern/postmodern/namespace.lisp][namespace]]
#+BEGIN_SRC lisp 
(in-package :postmodern)

(defmacro with-schema ((schema &key (strict t) (if-not-exist :create) (drop-after nil))
                       &body form)
  "A macro to set the schema search path of the postgresql
   database to include as first entry a specified schema.

   calling with strict 't only the specified schema is set as current
   search path. All other schema are then not searched any more.

   calling with if-not-exist set to :create the schema is created if
   this schema did not exist.

   calling with drop-after set to 't the schema is removed after the
   execution of the body form.

   example :
     (with-schema (:schema-name :strict nil :drop-after nil :if-not-exist :error)
            (foo 1)
            (foo 2))"
  `(do-with-schema ,schema (lambda () ,@form)
     :strict ,strict :if-not-exist ,if-not-exist :drop-after ,drop-after))

(defun do-with-schema (schema thunk &key strict if-not-exist drop-after)
  (let ((old-search-path (get-search-path)))
    (unwind-protect
         (progn
           (unless (schema-exists-p schema)
             (if (eq if-not-exist :create)
                 (create-schema schema)
                 (error 'database-error :message (format nil "Schema '~a' does not exist." schema))))
           (set-search-path (if strict (to-sql-name schema t) (concatenate 'string (to-sql-name schema t) "," old-search-path)))
           (funcall thunk))
      (set-search-path old-search-path)
      (when drop-after (drop-schema schema :cascade 't)))))

(defun get-search-path ()
  "Returns the default schema search path for the current session."
  (query "SHOW search_path" :single))

(defun set-search-path (path)
  "This changes the postgresql runtime parameter controlling what order
schemas are searched. You can always use fully qualified names [schema.table].
By default, this function only changes the search path for the current session."
  (execute (format nil "SET search_path TO ~a" path)))

(defun list-schemata ()
  "List all existing user defined schemata.

  Note: The query uses the portable information_schema relations instead of pg_tables relations
  SELECT schema_name FROM information_schema.schemata where schema_name !~ '(pg_*)|information_schema' ORDER BY schema_name ;"
  (query (:select 'schema_name
          :from 'information_schema.schemata
          :where (:!~ 'schema_name "pg_.*|information_schema"))
         :column))

(defun list-schemas ()
  "List schemas in the current database, excluding the pg_* system schemas."
  (loop for x in (query (:select 'nspname
                                 :from 'pg_namespace
                                 :where (:!~* 'nspname "^pg_.*")))
       collect (first x)))


(defun schema-exists-p (name)
  "Predicate for schema existence. More consistent with naming scheme for other functions."
  (query (:select (:exists (:select 'schema_name
                            :from 'information_schema.schemata
                            :where (:= 'schema_name '$1))))
         (to-sql-name name)
         :single))

(defun create-schema (schema)
  "Creating a non existing schema.
   If the schema exists an error is raised."
  ;;(format t "creating schema: ~a" schema)
  (execute (format nil "CREATE SCHEMA ~a" (s-sql:to-sql-name schema t))))

(defun drop-schema (schema &key (cascade nil))
  "Drops an existing database schema 'schema'"
  (execute (format nil "DROP SCHEMA ~a ~:[~;CASCADE~]" (s-sql:to-sql-name schema t) cascade)))

#+END_SRC

** [[/Users/Can/Develop/Lisp/document/postmodern/postmodern/deftable.lisp][deftable]]
#+BEGIN_SRC lisp 
(in-package :postmodern)

(defvar *table-name*)
(setf (documentation '*table-name* 'variable)
      "Used inside deftable to find the name of the table being defined.")
(defvar *table-symbol*)
(setf (documentation '*table-symbol* 'variable)
      "Used inside deftable to find the symbol naming the table being defined.")

(defvar *tables* ()
  "Unexported ordered list containing the known table definitions.")

(defun add-table-definition (symbol func)
  (let (last-cons)
    (loop :for cons :on *tables* :do
       (when (eq (caar cons) symbol)
         (setf (cdar cons) func)
         (return-from add-table-definition (values)))
       (setf last-cons cons))
    (if last-cons
        (setf (cdr last-cons) (list (cons symbol func)))
        (setf *tables* (list (cons symbol func)))))
  (values))

(defmacro deftable (name &body definitions)
  "Define a table. name can be either a symbol or a (symbol string)
list. In the first case, the table name is derived from the symbol by
S-SQL's rules, in the second case, the name is given explicitly. The
body of definitions can contain anything that evaluates to a string,
as well as S-SQL expressions. In this body, the variables *table-name*
and *table-symbol* are bound to the relevant values."
  (multiple-value-bind (symbol name)
      (if (consp name) (values-list name) (values name (to-sql-name name nil)))
    (flet ((check-s-sql (form)
             (if (and (consp form) (keywordp (car form))) (list 'sql form) form)))
      `(add-table-definition
        ',symbol
        (lambda ()
          (let ((*table-name* ,name) (*table-symbol* ',symbol))
            (dolist (stat (list ,@(mapcar #'check-s-sql definitions)))
              (execute stat))))))))

(defun create-table (name)
  "Create a defined table."
  (with-transaction ()
    (funcall (or (cdr (assoc name *tables*))
		 (error "No table '~a' defined." name)))
    (values)))

(defun create-all-tables ()
  "Create all defined tables."
  (loop :for (nil . def) :in *tables* :do (funcall def)))

(defun create-package-tables (package)
  "Create all tables whose identifying symbol is interned in the given
package."
  (let ((package (find-package package)))
    (loop :for (sym . def) :in *tables* :do
       (when (eq (symbol-package sym) package) (funcall def)))))

(defun flat-table-name (&optional (table *table-name*))
  (when (symbolp table)
    (setf table (string-downcase (string table))))
  (let ((dotpos (position #\. table)))
    (if dotpos
        (subseq table (1+ dotpos))
        table)))

(labels ((index-name (fields)
           (make-symbol (format nil "~a-~{~a~^-~}-index" (flat-table-name) fields)))
         (make-index (type fields)
           (sql-compile `(,type ,(index-name fields) :on ,*table-name* :fields ,@fields))))
  (defun \!index (&rest fields)
    "Used inside a deftable form. Define an index on the defined table."
    (make-index :create-index fields))
  (defun \!unique-index (&rest fields)
    "Used inside a deftable form. Define a unique index on the defined table."
    (make-index :create-unique-index fields)))

#+postmodern-use-mop
(defun \!dao-def ()
  "Used inside a deftable form. Define this table using the
corresponding DAO class' slots."
  (dao-table-definition *table-symbol*))

(defun \!foreign (target fields &rest target-fields/on-delete/on-update/deferrable/initially-deferred)
  "Used inside a deftable form. Define a foreign key on this table.
Pass a table the index refers to, a list of fields or single field in
*this* table, and, if the fields have different names in the table
referred to, another field or list of fields for the target table, or
:primary-key to indicate that the other table's primary key should be
referenced."
  (let* ((args target-fields/on-delete/on-update/deferrable/initially-deferred)
         (target-fields (and args (or (not (keywordp (car args)))
                                      (eq (car args) :primary-key))
                             (pop args))))
    (labels ((fkey-name (target fields)
               (to-sql-name (format nil "~a_~a_~{~a~^_~}_foreign" (flat-table-name) (flat-table-name target) fields))))
      (unless (listp fields) (setf fields (list fields)))
      (unless (listp target-fields) (setf target-fields (list target-fields)))
      (let* ((target-name (to-sql-name target))
             (field-names (mapcar #'to-sql-name fields))
             (target-names (cond
                             ((equal target-fields '(:primary-key)) nil)
                             ((null target-fields) field-names)
                             (t (mapcar #'to-sql-name target-fields)))))
        (format nil "ALTER TABLE ~a ADD CONSTRAINT ~a FOREIGN KEY (~{~a~^, ~}) REFERENCES ~a~@[ (~{~a~^, ~})~] ~@[ON DELETE ~a~] ~@[ON UPDATE ~a~] ~:[NOT DEFERRABLE~;DEFERRABLE INITIALLY ~:[IMMEDIATE~;DEFERRED~]~]"
                (to-sql-name *table-name*) (fkey-name target fields) field-names target-name target-names
                (s-sql::expand-foreign-on* (getf args :on-delete :restrict))
                (s-sql::expand-foreign-on* (getf args :on-update :restrict))
                (getf args :deferrable nil)
                (getf args :initially-deferred nil))))))

(defun \!unique (target-fields &key deferrable initially-deferred)
  (unless (listp target-fields) (setf target-fields (list target-fields)))
  (format nil "ALTER TABLE ~A ADD CONSTRAINT ~A UNIQUE (~{~A~^, ~}) ~:[NOT DEFERRABLE~;DEFERRABLE INITIALLY ~:[IMMEDIATE~;DEFERRED~]~]"
          (to-sql-name *table-name*)
          (to-sql-name (format nil "~A_~{~A~^_~}_unique" *table-name* target-fields))
          (mapcar #'pomo::to-sql-name target-fields)
          deferrable
          initially-deferred))

#+END_SRC

** [[/Users/Can/Develop/Lisp/document/postmodern/postmodern/connect.lisp][connect]]
#+BEGIN_SRC lisp 
(in-package :postmodern)

(defclass pooled-database-connection (database-connection)
  ((pool-type :initarg :pool-type :accessor connection-pool-type))
  (:documentation "Type for database connections that are pooled.
Stores the arguments used to create it, so different pools can be
distinguished."))

(defparameter *database* nil
  "Special holding the current database. Most functions and macros
operating on a database assume this contains a connected database.")

(defparameter *default-use-ssl* :no)

(defun connect (database user password host &key (port 5432) pooled-p (use-ssl *default-use-ssl*) (service "postgres"))
  "Create and return a database connection."
  (cond (pooled-p
         (let ((type (list database user password host port use-ssl)))
           (or (get-from-pool type)
               (let ((connection (open-database database user password host port use-ssl)))
		 #-genera (change-class connection 'pooled-database-connection :pool-type type)
		 #+genera (progn
			      (change-class connection 'pooled-database-connection)
			      (setf (slot-value connection 'pool-type) type))
                 connection))))
        (t (open-database database user password host port use-ssl service))))

(defun connected-p (database)
  "Test whether a database connection is still connected."
  (database-open-p database))

(defun connect-toplevel (database user password host &key (port 5432) (use-ssl *default-use-ssl*))
  "Set *database* to a new connection. Use this if you only need one
connection, or if you want a connection for debugging from the REPL."
  (when (and *database* (connected-p *database*))
    (restart-case (error "Top-level database already connected.")
      (replace () :report "Replace it with a new connection." (disconnect-toplevel))
      (leave () :report "Leave it." (return-from connect-toplevel nil))))
  (setf *database* (connect database user password host :port port :use-ssl use-ssl))
  (values))

(defgeneric disconnect (database)
  (:method ((connection database-connection))
    (close-database connection))
  (:documentation "Close a database connection. Returns it to a pool
if it is a pooled connection."))

(defgeneric reconnect (database)
  (:method ((database database-connection))
    (reopen-database database))
  (:method ((connection pooled-database-connection))
    (error "Can not reconnect a pooled database."))
  (:documentation "Reconnect a database connection."))

(defun disconnect-toplevel ()
  "Disconnect *database*."
  (when (and *database* (connected-p *database*))
    (disconnect *database*))
  (setf *database* nil))

(defun call-with-connection (spec thunk)
  "Binds *database* to a new connection, as specified by the spec
argument, which should be a list of arguments that can be passed to
connect, and runs the function given as a second argument with that
database."
  (let ((*database* (apply #'connect spec)))
    (unwind-protect (funcall thunk)
      (disconnect *database*))))

(defmacro with-connection (spec &body body)
  "Locally establish a database connection, and bind *database* to it."
  `(let ((*database* (apply #'connect ,spec)))
    (unwind-protect (progn ,@body)
      (disconnect *database*))))

(defvar *max-pool-size* nil
  "The maximum amount of connection that will be kept in a single
pool, or NIL for no maximum.")

(defvar *connection-pools* (make-hash-table :test 'equal)
  "Maps pool specifiers to lists of pooled connections.")

#+postmodern-thread-safe
(defvar *pool-lock*
  (bordeaux-threads:make-lock "connection-pool-lock")
  "A lock to prevent multiple threads from messing with the connection
pool at the same time.")

(defmacro with-pool-lock (&body body)
  "Aquire a lock for the pool when evaluating body \(if thread support
is present)."
  #+postmodern-thread-safe
  `(bordeaux-threads:with-lock-held (*pool-lock*) ,@body)
  #-postmodern-thread-safe
  `(progn ,@body))

(defun get-from-pool (type)
  "Get a database connection from the specified pool, returns nil if
no connection was available."
  (with-pool-lock
    (pop (gethash type *connection-pools*))))

(defmethod disconnect ((connection pooled-database-connection))
  "Add the connection to the corresponding pool, or drop it when the
pool is full."
  (macrolet ((the-pool ()
               '(gethash (connection-pool-type connection) *connection-pools* ())))
    (when (database-open-p connection)
      (with-pool-lock
        (if (or (not *max-pool-size*) (< (length (the-pool)) *max-pool-size*))
            (push connection (the-pool))
            (call-next-method))))
    (values)))

(defun clear-connection-pool ()
  "Disconnect and remove all connections in the connection pool."
  (with-pool-lock
    (maphash
     (lambda (type connections)
       (declare (ignore type))
       (dolist (conn connections)
         (close-database conn)))
     *connection-pools*)
    (setf *connection-pools* (make-hash-table :test 'equal))
    (values)))

#+END_SRC

* S-Sql
** [[/Users/Can/Develop/Lisp/document/postmodern/s-sql/s-sql.lisp][s-sql]]
#+BEGIN_SRC lisp 
;;; -*- Mode: Lisp; Base: 10; Package: CL-USER -*-
(defpackage :s-sql
  (:use :common-lisp)
  (:export #:smallint
           #:bigint
           #:numeric
           #:real
           #:double-precision
           #:bytea
           #:text
           #:varchar
           #:db-null
           #:sql-type-name
           #:*standard-sql-strings*
           #:*downcase-symbols*
           #:sql-escape-string
           #:sql-escape
           #:from-sql-name
           #:to-sql-name
           #:*escape-sql-names-p*
           #:sql
           #:sql-compile
           #:sql-template
           #:$$
           #:register-sql-operators
           #:enable-s-sql-syntax
           #:sql-error))

(in-package :s-sql)

;; Utils

(define-condition sql-error (simple-error) ())
(defun sql-error (control &rest args)
  (error 'sql-error :format-control control :format-arguments args))

(defun strcat (args)
  "Concatenate a list of strings into a single one."
  (let ((result (make-string (reduce #'+ args :initial-value 0 :key 'length))))
    (loop :for pos = 0 :then (+ pos (length arg))
          :for arg :in args
          :do (replace result arg :start1 pos))
    result))

(defun implode (sep list)
  "Reduce a list of strings to a single string, inserting a separator
between them."
  (strcat (loop :for element :on list
                :collect (car element)
                :if (cdr element)
                :collect sep)))

(defun split-on-keywords% (shape list)
  "Helper function for split-on-keywords. Extracts the values
associated with the keywords from an argument list, and checks for
errors."
  (let ((result ()))
    (labels ((next-word (words values)
               (if words
                   (let* ((me (intern (symbol-name (caar words)) :keyword))
                          (optional (member '? (car words)))
                          (multi (member '* (car words)))
                          (no-args (member '- (car words)))
                          (found (position me values)))
                     (cond (found
                            (let ((after-me (nthcdr (1+ found) values)))
                              (unless (or after-me no-args)
                                (sql-error "Keyword ~A encountered at end of arguments." me))
                              (let ((next (next-word (cdr words) after-me)))
                                (cond
                                  (no-args (unless (zerop next) (sql-error "Keyword ~A does not take any arguments." me)))
                                  (multi (unless (>= next 1) (sql-error "Not enough arguments to keyword ~A." me)))
                                  (t (unless (= next 1) (sql-error "Keyword ~A takes exactly one argument." me))))
                                (push (cons (caar words) (if no-args t (subseq after-me 0 next))) result)
                                found)))
                           (optional
                            (next-word (cdr words) values))
                           (t (sql-error "Required keyword ~A not found." me))))
                   (length values))))
      (unless (= (next-word shape list) 0)
        (sql-error "Arguments do not start with a valid keyword."))
      result)))

(defmacro split-on-keywords (words form &body body)
  "Handles arguments to some complex SQL operations. Arguments
are divided by keywords, which are interned with the name of the
non-keyword symbols in words, and bound to these symbols. After the
naming symbols, a ? can be used to indicate this argument group is
optional, an * to indicate it can consist of more than one element,
and a - to indicate it does not take any elements. When used, keywords
must appear in the order defined."
  (let ((alist (gensym)))
    `(let* ((,alist (split-on-keywords% ',words ,form))
            ,@(mapcar (lambda (word)
                        `(,(first word) (cdr (assoc ',(first word) ,alist))))
                      words))
        ,@body)))

;; Converting between symbols and SQL strings.

(defparameter *postgres-reserved-words*
  (let ((words (make-hash-table :test 'equal)))
    (dolist (word '("all" "analyse" "analyze" "and" "any" "array" "as" "asc" "asymmetric" "authorization"
                    "between" "binary" "both" "case" "cast" "check" "collate" "column" "concurrently"
                    "constraint" "create" "cross" "current-catalog" "current-date" "current-role" "current-schema"
                    "current-time" "current-timestamp" "current-user" "default" "deferrable"
                    "desc" "distinct" "do" "else" "end" "except" "false" "fetch" "filter"
                    "for" "foreign" "freeze" "from" "full" "grant" "group" "having" "ilike" "in" "initially"
                    "inner" "intersect" "into" "is" "isnull" "join" "lateral" "leading" "left" "like" "limit"
                    "localtime" "localtimestamp" "natural" "new" "not" "notnull" "null" "off" "offset" "old"
                    "on" "only" "or" "order" "outer" "overlaps" "placing" "primary" "references" "returning"
                    "right" "select" "session-user" "similar" "some" "symmetric" "table" "then" "to" "trailing" "true"
                    "union" "unique" "user" "using" "variadic" "verbose" "when" "where" "window" "with"
                    "for" "nowait" "share"))
      (setf (gethash word words) t))
    words)
  "A set of all PostgreSQL's reserved words, for automatic escaping.")

(defparameter *escape-sql-names-p* :auto
  "Setting this to T will make S-SQL add double quotes around
identifiers in queries. Setting it :auto will turn on this behaviour
only for reserved words. Setting it to :literal will cause to-sql-name to
escape reserved words,but will not make other changes such as changing
forward slash to underscore.")

(defvar *downcase-symbols* t)

(defun to-sql-name (name &optional (escape-p *escape-sql-names-p*) (ignore-reserved-words nil))
  "Convert a symbol or string into a name that can be a sql table,
column, or operation name. Add quotes when escape-p is true, or
escape-p is :auto and the name contains reserved words.
Quoted or delimited identifiers can be used by passing :literal as
the value of escape-p. If escape-p is :literal, and the name is a string then
the string is still escaped but the symbol or string is not downcased,
regardless of the setting for *downcase-symbols* and the hyphen
and forward slash characters are not replaced with underscores.

Ignore-reserved-words is only used internally for column names which are allowed
to be reserved words, but it is not recommended."
  (declare (optimize (speed 3) (debug 0)))
  (let ((*print-pretty* nil)
        (name (if (and (consp name) (eq (car name) 'quote) (equal (length name) 2))
                  (string (cadr name))
                  (string name))))
    (with-output-to-string (*standard-output*)
      (flet ((subseq-downcase (str from to)
               (let ((result (make-string (- to from))))
                 (loop :for i :from from :below to
                       :for p :from 0
                       :do (setf (char result p) (if (and *downcase-symbols*
                                                          (not (eq escape-p :literal)))
                                                     (char-downcase (char str i))
                                                     (char str i))))
                 result))
             (write-element (str)
               (declare (type string str))
               (let ((escape-p (cond ((and (eq escape-p :auto) (not ignore-reserved-words))
                                      (gethash str *postgres-reserved-words*))
                                     (ignore-reserved-words nil)
                                     (t escape-p))))
                 (when escape-p
                   (write-char #\"))
                 (if (and (> (length str) 1) ;; Placeholders like $2
                          (char= (char str 0) #\$)
                          (every #'digit-char-p (the string (subseq str 1))))
                     (princ str)
                     (loop :for ch :of-type character :across str
                           :do (if (or (eq ch #\*)
                                       (alphanumericp ch)
                                       (eq escape-p :literal))
                                   (write-char ch)
                                   (write-char #\_))))
                 (when escape-p
                   (write-char #\")))))

        (loop :for start := 0 :then (1+ dot)
              :for dot := (position #\. name) :then (position #\. name :start start)
              :do (write-element (subseq-downcase name start (or dot (length name))))
              :if dot :do (princ #\.)
              :else :do (return))))))

(defun from-sql-name (str)
  "Convert a string to something that might have been its original
lisp name. Does not work if this name contains non-alphanumeric
characters other than #\-"
  (intern (map 'string (lambda (x) (if (eq x #\_) #\- x))
               (if (eq (readtable-case *readtable*) :upcase) (string-upcase str) str))
          (find-package :keyword)))

;; Writing out SQL type identifiers.

;; Aliases for some types that can be expressed in SQL.
(deftype smallint ()
  '(signed-byte 16))
(deftype bigint ()
  `(signed-byte 64))
(deftype numeric (&optional precision/scale scale)
  (declare (ignore precision/scale scale))
  'number)
(deftype double-precision ()
  'double-float)
(deftype bytea ()
  '(array (unsigned-byte 8)))
(deftype text ()
  'string)
(deftype varchar (length)
  (declare (ignore length))
  `string)
(deftype serial () 'integer)
(deftype serial8 () 'integer)

(deftype db-null ()
  "Type for representing NULL values. Use like (or integer db-null)
for declaring a type to be an integer that may be null."
  '(eql :null))

;; For types integer and real, the Lisp type isn't quite the same as
;; the SQL type. Close enough though.

(defgeneric sql-type-name (lisp-type &rest args)
  (:documentation "Transform a lisp type into a string containing
something SQL understands. Default is to just use the type symbol's
name.")
  (:method ((lisp-type symbol) &rest args)
    (declare (ignore args))
    (substitute #\Space #\- (symbol-name lisp-type) :test #'char=))
  (:method ((lisp-type (eql 'string)) &rest args)
    (cond (args (format nil "CHAR(~A)" (car args)))
          (t "TEXT")))
  (:method ((lisp-type (eql 'varchar)) &rest args)
    (cond (args (format nil "VARCHAR(~A)" (car args)))
          (t "VARCHAR")))
  (:method ((lisp-type (eql 'numeric)) &rest args)
    (cond ((cdr args)
           (destructuring-bind (precision scale) args
             (format nil "NUMERIC(~d, ~d)" precision scale)))
          (args (format nil "NUMERIC(~d)" (car args)))
          (t "NUMERIC")))
  (:method ((lisp-type (eql 'float)) &rest args)
    (declare (ignore args))
    "REAL")
  (:method ((lisp-type (eql 'double-float)) &rest args)
    (declare (ignore args))
    "DOUBLE PRECISION")
  (:method ((lisp-type (eql 'double-precision)) &rest args)
    (declare (ignore args))
    "DOUBLE PRECISION")
  (:method ((lisp-type (eql 'serial)) &rest args)
    (declare (ignore args))
    "SERIAL")
  (:method ((lisp-type (eql 'serial8)) &rest args)
    (declare (ignore args))
    "SERIAL8")
  (:method ((lisp-type (eql 'array)) &rest args)
    (format nil "~a[]" (to-type-name (car args))))
  (:method ((lisp-type (eql 'db-null)) &rest args)
    (declare (ignore args))
    (sql-error "Bad use of ~s." 'db-null)))

(defun to-type-name (type)
  "Turn a Lisp type expression into a SQL typename."
  (if (listp type)
      (apply 'sql-type-name type)
      (sql-type-name type)))

;; Turning lisp values into SQL strings.

(defparameter *standard-sql-strings* nil
  "Indicate whether S-SQL will use standard SQL strings (just use ''
  for #\'), or backslash-style escaping. Setting this to NIL is always
  safe, but when the server is configured to allow standard
  strings (parameter 'standard_conforming_strings' is 'on'), the noise
  in queries can be reduced by setting this to T.")

(defun sql-escape-string (string &optional prefix)
  "Escape string data so it can be used in a query."
  (let ((*print-pretty* nil))
    (with-output-to-string (*standard-output*)
      (when prefix
        (princ prefix)
        (princ #\space))
      (unless *standard-sql-strings*
        (princ #\E))
      (princ #\')
      (if *standard-sql-strings*
          (loop :for char :across string :do (princ (if (char= char #\') "''" char)))
          (loop :for char :across string
                :do (princ (case char
                             (#\' "''")
                             (#\\ "\\\\")
                             (otherwise char)))))
      (princ #\'))))

(defgeneric sql-escape (arg)
  (:documentation "Get the representation of a Lisp value so that it
can be used in a query.")
  (:method ((arg symbol))
    (if (or (typep arg 'boolean) (eq arg :null))
        (call-next-method)
        (to-sql-name arg)))
  (:method ((arg vector))
    (if (or (typep arg '(vector (unsigned-byte 8)))
            (stringp arg))
        (call-next-method)
        (format nil "~:['{}'~;ARRAY[~:*~{~A~^, ~}]~]" (map 'list 'sql-escape arg))))
  (:method ((arg t))
    (multiple-value-bind (string escape) (cl-postgres:to-sql-string arg)
      (if escape
          (sql-escape-string string (and (not (eq escape t)) escape))
          string))))

(defparameter *expand-runtime* nil)

(defun sql-expand (arg)
  "Compile-time expansion of forms into lists of stuff that evaluate
to strings (which will form a SQL query when concatenated)."
  (cond ((and (consp arg) (keywordp (first arg)))
         (expand-sql-op (car arg) (cdr arg)))
        ((and (consp arg) (eq (first arg) 'quote))
         (list (sql-escape (second arg))))
        ((and (consp arg) *expand-runtime*)
         (expand-sql-op (intern (symbol-name (car arg)) :keyword) (cdr arg)))
        ((and (eq arg '$$) *expand-runtime*) '($$))
        (*expand-runtime*
         (list (sql-escape arg)))
        ((or (consp arg)
             (and (symbolp arg)
                  (not (or (keywordp arg) (eq arg t) (eq arg nil)))))
         (list `(sql-escape ,arg)))
        (t (list (sql-escape arg)))))

(defun sql-expand-list (elts &optional (sep ", "))
  "Expand a list of elements, adding a separator between them."
  (loop :for (elt . rest) :on elts
        :append (sql-expand elt)
        :if rest :collect sep))

(defun sql-expand-names (names &optional (sep ", "))
  "Takes a list of elements (symbols or strings) and returns a separated list of strings.
If the element is a cons, then "
  (loop :for (name . rest) :on names
        :if (consp name) :append (let ((*expand-runtime* t))
                                   (sql-expand name))
        :else :collect (to-sql-name name)
        :if rest :collect sep))

(defun reduce-strings (list)
  "Join adjacent strings in a list; leave other values intact."
  (let ((accum ())
        (span ""))
    (dolist (part list)
      (cond ((stringp part) (setf span (concatenate 'string span part)))
            (t (when (not (string= "" span))
                 (push span accum)
                 (setf span ""))
               (push part accum))))
    (if (not (string= "" span))
        (push span accum))
    (nreverse accum)))

(defmacro sql (form)
  "Compile form to a sql expression as far as possible."
  (let ((list (reduce-strings (sql-expand form))))
    (if (= 1 (length list))
        (car list)
        `(strcat (list ,@list)))))

(defun sql-compile (form)
  (let ((*expand-runtime* t))
    (strcat (sql-expand form))))

(defun sql-template (form)
  (let* ((*expand-runtime* t)
         (compiled (reduce-strings (sql-expand form)))
         (*print-pretty* nil))
    (lambda (&rest args)
      (with-output-to-string (*standard-output*)
        (dolist (element compiled)
          (princ (if (eq element '$$) (sql-escape (pop args)) element)))))))

;; The reader syntax.

(defun s-sql-reader (stream char min-args)
  (declare (ignore char min-args))
  (list 'sql (read stream)))

(defun enable-s-sql-syntax (&optional (char #\Q))
  "Enable a syntactic shortcut #Q(...) for (sql \(...)). Optionally
takes a character to use instead of #\\Q."
  (set-dispatch-macro-character #\# char 's-sql-reader))

;; Definitions of sql operators

(defgeneric expand-sql-op (op args)
  (:documentation "Override expansion of operators. Default is to just
place operator name in front, arguments between parentheses and
nothing behind it.")
  (:method ((op t) args)
    `(,(to-sql-name op) "(" ,@(sql-expand-list args) ")")))

(defmacro def-sql-op (name arglist &body body)
  "Macro to make defining syntax a bit more straightforward. Name
should be the keyword identifying the operator, arglist a lambda list
to apply to the arguments, and body something that produces a list of
strings and forms that evaluate to strings."
  (alexandria:with-unique-names (args-name op)
    (multiple-value-bind (body decls docstring)
        (alexandria:parse-body body :documentation t)
      `(defmethod expand-sql-op ((,op (eql ,name)) ,args-name)
         ,@(when docstring
             (list docstring))
         ,@decls
         (destructuring-bind ,arglist ,args-name
           ,@body)))))

(defun make-expander (arity name)
  "Generates an appropriate expander function for a given operator
with a given arity."
  (let ((with-spaces (strcat (list " " name " "))))
    (flet ((check-unary (args)
             (when (or (not args) (cdr args))
               (sql-error "SQL operator ~A is unary." name)))
           (expand-n-ary (args)
             `("(" ,@(sql-expand-list args with-spaces) ")")))
      (ecase arity
        (:unary (lambda (args)
                  (check-unary args)
                  `("(" ,name " " ,@(sql-expand (car args)) ")")))
        (:unary-postfix (lambda (args)
                          (check-unary args)
                          `("(" ,@(sql-expand (car args)) " " ,name ")")))
        (:n-ary (lambda (args)
                  (if (cdr args)
                      (expand-n-ary args)
                      (sql-expand (car args)))))
        (:2+-ary (lambda (args)
                   (unless (cdr args)
                     (sql-error "SQL operator ~A takes at least two arguments." name))
                   (expand-n-ary args)))
        (:n-or-unary (lambda (args)
                       (if (cdr args)
                           (expand-n-ary args)
                           `("(" ,name " " ,@(sql-expand (car args)) ")"))))))))

(defmacro register-sql-operators (arity &rest names)
  "Define simple operators. Arity is one of :unary (like
'not'), :unary-postfix (the operator comes after the operand),
:n-ary (like '+': the operator falls away when there is only one
operand), :2+-ary (like '=', which is meaningless for one operand),
or :n-or-unary (like '-', where the operator is kept in the unary
case). After the arity follow any number of operators, either just a
keyword, in which case the downcased symbol name is used as the
operator, or a two-element list containing a keyword and a name
string."
  (declare (type (member :unary :unary-postfix :n-ary :n-or-unary :2+-ary) arity))
  (flet ((define-op (name)
           (let ((name (if (listp name)
                           (second name)
                           (string-downcase (symbol-name name))))
                 (symbol (if (listp name) (first name) name)))
             `(let ((expander (make-expander ,arity ,name)))
                (defmethod expand-sql-op ((op (eql ,symbol)) args)
                  (funcall expander args))))))
    `(progn ,@(mapcar #'define-op names))))

(register-sql-operators :unary :not)
(register-sql-operators :n-ary :+ :* :% :& :|\|| :|\|\|| :and :or :union (:union-all "union all"))
(register-sql-operators :n-or-unary :- :~)
(register-sql-operators :2+-ary  := :/ :!= :<> :< :> :<= :>= :^ :~* :!~ :!~* :like :ilike :->> :|#>| :|#>>|
                        :intersect (:intersect-all "intersect all")
                        :except (:except-all "except all"))
;; PostGIS operators
(register-sql-operators :2+-ary :&& :&< :|&<\|| :&> :<< :|<<\|| :>> :|@| :|\|&>| :|\|>>| :~= :|@>| :|@<|)

;; hstore operators
(register-sql-operators :2+-ary :-> :=> :? :?& :?\| :|<@| :|#=| :unary :%% :%#)

(def-sql-op :|| (&rest args)
  `("(" ,@(sql-expand-list args " || ") ")"))

(def-sql-op :asc (arg)
  `(,@(sql-expand arg) " ASC"))

(def-sql-op :desc (arg)
  `(,@(sql-expand arg) " DESC"))

(def-sql-op :nulls-first (arg)
  `(,@(sql-expand arg) " NULLS FIRST"))

(def-sql-op :nulls-last (arg)
  `(,@(sql-expand arg) " NULLS LAST"))

(def-sql-op :as (form name &rest fields)
  `(,@(sql-expand form) " AS " ,@(sql-expand name)
    ,@(when fields
        `("(" ,@(loop :for field :in fields
                      :for (name type) := (if (and (consp field) (not (eq (first field) 'quote)))
                                              field
                                              (list field nil))
                      :for first := t :then nil
                      :unless first :collect ", "
                      :append (sql-expand name)
                      :when type :append (list " " (to-type-name type)))
          ")"))))

(def-sql-op :|@@| (op1 op2)
  `("(" ,@(sql-expand op1) " @@ " ,@(sql-expand op2) ")"))

(def-sql-op :distinct (&rest forms)
  `("DISTINCT(" ,@(sql-expand-list forms) ")"))

(def-sql-op :any* (query)
  `("ANY(" ,@(sql-expand query) ")"))

(def-sql-op :any (query)
  `("ANY " ,@(sql-expand query)))

(def-sql-op :all (query)
  `("ALL " ,@(sql-expand query)))

(def-sql-op :array (query)
  "This is used when calling a select query into an array. See sample usage."
  `("ARRAY(" ,@(sql-expand query) ")"))

(def-sql-op :array[] (&rest args)
  "This handles statements that include functions in the query such as (:+ 1 2), (:pi) in the array whereas just
passing an array as #(1.0 2.4) does not and you are not selecting into an array, so do not use :array."
  `("ARRAY[" ,@(sql-expand-list args) "]"))

(def-sql-op :[] (form start &optional end)
  "This slices arrays. Sample usage would be:
   (query (:select (:[] 'provinces 1) :from 'array-provinces :where (:= 'name \"Germany\"))
"
  (if end
      `("(" ,@(sql-expand form) ")[" ,@(sql-expand start) ":" ,@(sql-expand end) "]")
      `("(" ,@(sql-expand form) ")[" ,@(sql-expand start) "]")))

(def-sql-op :interval (arg  &optional precision)
  "Interval takes a string.
See https://www.postgresql.org/docs/current/static/datatype-datetime.html#DATATYPE-INTERVAL-INPUT-EXAMPLES.
It optionally take a precision parameter, which causes the result to be rounded
to that many fractional digits in the seconds field. Without a precision
+parameter, the result is given to the full available precision. Precision
only applies to seconds."
  (if precision
      `("INTERVAL  " ,@(sql-expand arg) "(" ,@(sql-expand precision) ")")
      `("INTERVAL  " ,@(sql-expand arg))))

(def-sql-op :current-date ()
  "Provides the current time. The default is universal time. If you want
a more human readable approach, you can use :to-char. As an example:
  (query (:select (:current-date) (:to-char (:current-date) \"YYYY-MM-DD\")))
  ((3751488000 \"2018-11-18\"))"

  `("current_date"))

(def-sql-op :current-timestamp (&optional precision)
    "Current-time and Current-timestamp deliver values with time zones. They
optionally take a precision parameter, which causes the result to be rounded
to that many fractional digits in the seconds field. Without a precision
parameter, the result is given to the full available precision. Precision
only applies to seconds."
  (if precision
      `("current_timestamp (" ,@(sql-expand precision) ")")
      '("current_timestamp")))

(def-sql-op :current-time (&optional precision)
  "Current-time and Current-timestamp deliver values with time zones. They
optionally take a precision parameter, which causes the result to be rounded
to that many fractional digits in the seconds field. Without a precision
parameter, the result is given to the full available precision. Precision
only applies to seconds."
  (if precision
      `("current_time (" ,@(sql-expand precision) ")")
      '("current_time")))

(def-sql-op :local-timestamp (&optional precision)
  "LOCALTIME and LOCALTIMESTAMP deliver values without time zone. They optionally
take a precision parameter, which causes the result to be rounded to that many
fractional digits in the seconds field. Without a precision parameter, the
result is given to the full available precision. Precision
only applies to seconds."
  (if precision
      `("localtimestamp (" ,@(sql-expand precision) ")")
      '("localtimestamp")))

(def-sql-op :local-time (&optional precision)
  "LOCALTIME and LOCALTIMESTAMP deliver values without time zone. They optionally
take a precision parameter, which causes the result to be rounded to that many
fractional digits in the seconds field. Without a precision parameter, the
result is given to the full available precision."
  (if precision
      `("localtime (" ,@(sql-expand precision) ")")
      '("localtime")))

(def-sql-op :timestamp (arg)
  `("timestamp " ,@(sql-expand arg)))

(def-sql-op :make-interval (&rest args)
  "Takes lists of (time-unit value) and returns an interval type.
e.g. (make-interval (\"days\" 10)(\"hours\" 4))."
  `("make_interval("
    ,@(loop for ((x . y) . rest) on args
         :append `(,x " := " ,(cond ((numberp y) (write-to-string y))
                                  ((listp y)
                                   (cond ((numberp (car y)) (write-to-string (car y)))
                                         ((stringp (car y))
                                          (strcat `("'" ,(car y) "'")))
                                         (t (car y))))))
         :if rest :collect ", ")
    ")"))

(def-sql-op :make-timestamp (&rest args)
  "Takes lists of (time-unit value) and returns a timestamp type.
e.g. (make-interval (\"days\" 10)(\"hours\" 4))."
  `("make_timestamp("
    ,@(loop for ((x . y) . rest) on args
         :append `(,x " := " ,(cond ((numberp y) (write-to-string y))
                                  ((listp y)
                                   (cond ((numberp (car y)) (write-to-string (car y)))
                                         ((stringp (car y))
                                          (strcat `("'" ,(car y) "'")))
                                         (t (car y))))))
         :if rest :collect ", ")
    ")"))

(def-sql-op :make-timestamptz (&rest args)
  "Takes lists of (time-unit value) and returns a timestamptz type.
e.g. (make-interval (\"days\" 10)(\"hours\" 4))."
  `("make_timestamptz("
    ,@(loop for ((x . y) . rest) on args
         :append `(,x " := " ,(cond ((numberp y) (write-to-string y))
                                  ((listp y)
                                   (cond ((numberp (car y)) (write-to-string (car y)))
                                         ((stringp (car y))
                                          (strcat `("'" ,(car y) "'")))
                                         (t (car y))))))
         :if rest :collect ", ")
    ")"))


(def-sql-op :age (&rest args)
  `("AGE (" ,@(sql-expand-list args) ")"))

(def-sql-op :date (arg)
  `("date " ,@(sql-expand arg)))

(def-sql-op :integer (arg)
  `("integer " ,@(sql-expand arg)))

(def-sql-op :cast (query)
 "Cast is one of two functions that help convert one type of data to another.
 The other function is type. An example use of cast is:

 (query (:select (:as (:cast (:as (:* 50 (:random)) 'int)) 'x)
                 :from (:generate-series 1 3)))

 One syntactic difference between cast and type is that the cast function
 requires that the datatype be quoted. "
   `("CAST(" ,@(sql-expand query) ")" ))

(def-sql-op :exists (query)
  `("(EXISTS " ,@(sql-expand query) ")"))

(def-sql-op :is-null (arg)
  `("(" ,@(sql-expand arg) " IS NULL)"))

(def-sql-op :not-null (arg)
  `("(" ,@(sql-expand arg) " IS NOT NULL)"))

(def-sql-op :in (form set)
  `("(" ,@(sql-expand form) " IN " ,@(sql-expand set) ")"))

(def-sql-op :not-in (form set)
  `("(" ,@(sql-expand form) " NOT IN " ,@(sql-expand set) ")"))

(def-sql-op :extract (unit form)
  `("EXTRACT(" ,@(sql-expand unit) " FROM " ,@(sql-expand form) ")"))

(def-sql-op :values (&rest args) "values statement"
   (split-on-keywords ((vars *) (order-by * ?)) (cons :vars args)
     `("(VALUES "
       ,@(sql-expand-list vars)
       ,@(when order-by `(" ORDER BY " ,@(sql-expand-list order-by) ")"))
       ")")))

(define-condition malformed-composite-type-error (error)
  ((text :initarg :text :reader text)))

(defun cons-to-sql-name-strings (item)
  "Takes a list of two items and returns a single string separated by a space.
The items will be converted to sql compatible namestrings."
  (if (= 2 (length item))
      (implode " " (mapcar #'to-sql-name item))
      (error 'malformed-composite-type-error :text item)))

(def-sql-op :count (&rest args)
    "Count returns the number of rows. It can be the number of rows collected by the select statement as in

  (query (:select (:count '*) :from 'table1 :where (:= 'price 100)))

or it can be a smaller number of rows based on the allowed keyword parameters :distinct and :filter as in

  (query (:select (:count 'memid :distinct) :from 'cd.bookings))

  or

  (query (:select (:as (:count '* :distinct) 'unfiltered)
                (:as (:count '* :filter (:= 1 'bid)) 'filtered)
                :from 'testtable))

Note that if used, the filter must be last in the count args. If distinct is used, it must come before filter.
Unlike standard sql, the word 'where' is not used inside the filter clause.
E.g. (sql (:select (:count '*) (:count '* :filter (:= 1 'bid)) 'id :from 'pbbench-history))
See tests.lisp for examples."
  (split-on-keywords ((vars *) (distinct - ?)  (filter * ?)) (cons :vars args)
    `("COUNT("
      ,@(when distinct '("DISTINCT "))
      ,@(sql-expand-list vars)
      ,@(when filter `(") FILTER (WHERE " ,@(sql-expand (car filter))))
    ")")))

(def-sql-op :avg (&rest args)
    "Avg calculates the average value of a list of values. Allowed keyword parameters are distinct and filter.
Note that if the filter keyword is used,
the filter must be last in the avg args. If distinct is used, it must come before filter.
Unlike standard sql, the word 'where' is not used inside the filter clause (s-sql will properly expand it).
E.g. (query (:select (:avg '*) (:avg '* :filter (:= 1 'bid)) 'id :from 'pbbench-history))
See tests.lisp for examples."
  (split-on-keywords ((vars *) (distinct - ?)  (filter * ?)) (cons :vars args)
    `("AVG("
      ,@(when distinct '("DISTINCT "))
      ,@(sql-expand-list vars)
      ,@(when filter `(") FILTER (WHERE " ,@(sql-expand (car filter))))")")))

(def-sql-op :sum (&rest args)
    "Sum calculates the total of a list of values.  Allowed keyword parameters are distinct and filter.
Note that if the keyword filter is used,
the filter must be last in the sum args. If distinct is used, it must come before filter.
Unlike standard sql, the word 'where' is not used inside the filter clause (s-sql will properly expand it).
E.g. (query (:select (:sum '*) (:sum '* :filter (:= 1 'bid)) 'id :from 'pbbench-history))
See tests.lisp for examples."
  (split-on-keywords ((vars *) (distinct - ?)  (filter * ?)) (cons :vars args)
    `("SUM("
      ,@(when distinct '("DISTINCT "))
      ,@(sql-expand-list vars)
      ,@(when filter `(") FILTER (WHERE " ,@(sql-expand (car filter))))")")))

(def-sql-op :max (&rest args)
    "Max returns the maximum value of a set of values.  Allowed keyword parameters are distinct and filter.
Note that if the filter keyword is used,
the filter must be last in the max args. If distinct is used, it must come before filter.
Unlike standard sql, the word 'where' is not used inside the filter clause (s-sql will properly expand it).
E.g. (query (:select (:max '*) (:max '* :filter (:= 1 'bid)) 'id :from 'pbbench-history))
See tests.lisp for more examples."
  (split-on-keywords ((vars *) (distinct - ?)  (filter * ?)) (cons :vars args)
    `("MAX("
      ,@(when distinct '("DISTINCT "))
      ,@(sql-expand-list vars)
      ,@(when filter `(") FILTER (WHERE " ,@(sql-expand (car filter))))")")))

(def-sql-op :min (&rest args)
    "Returns the minimum value of a set of values.  Allowed keyword parameters are distinct and filter.
Note that if the filter keyword is used, the filter must be last in the min args.
If distinct is used, it must come before filter.
Unlike standard sql, the word 'where' is not used inside the filter clause (s-sql will properly expand it).
E.g. (query (:select (:min '*) (:min '* :filter (:= 1 'bid)) 'id :from 'pbbench-history))
See tests.lisp for more examples."
  (split-on-keywords ((vars *) (distinct - ?)  (filter * ?)) (cons :vars args)
    `("MIN("
      ,@(when distinct '("DISTINCT "))
      ,@(sql-expand-list vars)
      ,@(when filter `(") FILTER (WHERE " ,@(sql-expand (car filter))))")")))

(def-sql-op :every (&rest args)
    "Returns true if all input values are true, otherwise false.  Allowed keyword parameters are distinct and filter.
Note that if the filter keyword used, the filter must be last in the every args.
If distinct is used, it must come before filter.
Unlike standard sql, the word 'where' is not used inside the filter clause (s-sql will properly expand it).
E.g. (query (:select '* (:every (:like 'studname \"%h\"))
             :from 'tbl-students
             :group-by 'studname 'studid 'studgrades))
See tests.lisp for examples."
  (split-on-keywords ((vars *) (distinct - ?)  (filter * ?)) (cons :vars args)
    `("EVERY("
      ,@(when distinct '("DISTINCT "))
      ,@(sql-expand-list vars)
      ,@(when filter `(") FILTER (WHERE " ,@(sql-expand (car filter))))")")))

(def-sql-op :percentile-cont (&rest args)
  "Requires Postgresql 9.4 or higher. Percentile-cont returns a value corresponding to the specified fraction in the ordering,
interpolating between adjacent input items if needed.
There are two required keyword parameters :fraction and :order-by. If the fraction value is an array,
then it returns an array of results matching the shape of the fractions parameter, with each non-null
element replaced by the value corresponding to that percentile.

Examples:

    (query (:select (:percentile-cont :fraction 0.5 :order-by 'number-of-staff)
                    :from 'schools))
    (query (:select (:percentile-cont :fraction array[0.25 0.5 0.75 1] :order-by 'number-of-staff)
                    :from  'schools))
"
  (split-on-keywords ((fraction *) (order-by * )) args
    `("PERCENTILE_CONT"
      ,@(when fraction `(,(format nil "~a" fraction)))
      ,@(when order-by `(" WITHIN GROUP (ORDER BY " ,@(sql-expand-list order-by) ")")))))

(def-sql-op :percentile-dist (&rest args)
  "Requires Postgresql 9.4 or higher. There are two required keyword parameters :fraction and :order-by.
Percentile-dist returns the first input value whose position in the ordering equals or exceeds
the specified fraction. If the fraction parameter is an array eturns an array of results matching
the shape of the fractions parameter, with each non-null element replaced by the input value
corresponding to that percentile.

Examples:

   (query (:select (:percentile-dist :fraction 0.5 :order-by 'number-of-staff)
                    :from 'schools))
    (query (:select (:percentile-dist :fraction array[0.25 0.5 0.75 1] :order-by 'number-of-staff)
                    :from  'schools))"

  (split-on-keywords ((fraction *)  (order-by * )) args
    `("PERCENTILE_DIST"
      ,@(when fraction `(,(format nil "~a" fraction)))
      ,@(when order-by `(" WITHIN GROUP (ORDER BY " ,@(sql-expand-list order-by) ")")))))

(def-sql-op :corr (y x)
  "The corr function returns the correlation coefficient between a set of dependent and independent variables.

Example:

    (query (:select (:corr 'height 'weight) :from 'people))"

  `("CORR(" ,@ (sql-expand y) " , " ,@ (sql-expand x) ")"))

(def-sql-op :covar-pop (y x)
  "The covar-pop function returns the population covariance between a set of dependent and independent variables.

Example:

    (query (:select (:covar-pop 'height 'weight) :from 'people))"

  `("COVAR_POP(" ,@(sql-expand y) " , " ,@(sql-expand x) ")"))

(def-sql-op :covar-samp (y x)
  "The covar-samp function returns the sample covariance between a set of dependent and independent variables.

Example:

    (query (:select (:covar-samp 'height 'weight) :from 'people))"

  `("COVAR_SAMP(" ,@(sql-expand y) " , " ,@(sql-expand x) ")"))




(def-sql-op :between (n start end)
  `("(" ,@(sql-expand n) " BETWEEN " ,@(sql-expand start) " AND " ,@(sql-expand end) ")"))

(def-sql-op :between-symmetric (n start end)
  `("(" ,@(sql-expand n) " BETWEEN SYMMETRIC " ,@(sql-expand start) " AND " ,@(sql-expand end) ")"))

(def-sql-op :case (&rest clauses)
  `("CASE"
    ,@(loop :for (test expr) :in clauses
            :if (eql test :else)
              :append `(" ELSE " ,@(sql-expand expr))
            :else
              :append `(" WHEN " ,@(sql-expand test) " THEN " ,@(sql-expand expr))
            :end)
    " END"))

;; This one has two interfaces. When the elements are known at
;; compile-time, they can be given as multiple arguments to the
;; operator. When they are not, a single argument that evaulates to a
;; list should be used.
(def-sql-op :set (&rest elements)
  (if (not elements)
      '("(NULL)")
      (let ((expanded (sql-expand-list elements)))
        ;; Ugly way to check if everything was expanded
        (if (stringp (car expanded))
            `("(" ,@expanded ")")
            `("(" (let ((elements ,(car elements)))
                    (if (null elements) "NULL"
                        (implode ", " (mapcar 'sql-escape elements)))) ")")))))

(def-sql-op :empty-set ()
  "Returns a list containing a string of two parentheses as an empty set."
  `("()"))

(def-sql-op :dot (&rest args)
  (sql-expand-list args "."))

(def-sql-op :type (value type)
  "Type will specify the datatype for a value. It uses the normal sql :: syntax.
The type can be quoted but does not need to be quoted. As an example:

  (query (:select (:type \"2018-01-01\" 'date)) :single)
  (query (:select (:type \"2018-01-01\" date)) :single)"

  `(,@(sql-expand value) "::" ,(to-type-name (dequote type))))

(def-sql-op :raw (sql)
  (list sql))

;; Selecting and manipulating

(defun expand-joins (args)
  "Helper for the select operator. Turns the part following :from into
the proper SQL syntax for joining tables."
  (labels ((expand-join (natural-p)
             (let ((type (first args)) (table (second args)) kind param)
               (unless table (sql-error "Incomplete join clause in select."))
               (setf args (cddr args))
               (unless (or natural-p (eq type :cross-join))
                 (setf kind (pop args))
                 (unless (and (or (eq kind :on) (eq kind :using)) args)
                   (sql-error "Incorrect join form in select."))
                 (setf param (pop args)))
               `(" " ,@(when natural-p '("NATURAL "))
                 ,(ecase type
                    (:left-join "LEFT") (:right-join "RIGHT")
                    (:inner-join "INNER") (:outer-join "FULL OUTER")
                    (:cross-join "CROSS")) " JOIN " ,@(sql-expand table)
                 ,@(unless (or natural-p (eq type :cross-join))
                     (ecase kind
                       (:on `(" ON " . ,(sql-expand param)))
                       (:using `(" USING (" ,@(sql-expand-list param) ")")))))))
           (is-join (x)
             (member x '(:left-join :right-join :inner-join :outer-join :cross-join))))
    (when (null args)
      (sql-error "Empty :from clause in select"))
    (loop :for first = t :then nil :while args
          :append (cond ((is-join (car args))
                         (when first (sql-error ":from clause starts with a join."))
                         (expand-join nil))
                        ((eq (car args) :natural)
                         (when first (sql-error ":from clause starts with a join."))
                         (pop args)
                         (expand-join t))
                        (t `(,@(if first () '(", ")) ,@(sql-expand (pop args))))))))

(def-sql-op :select (&rest args)
  (split-on-keywords ((vars *) (distinct - ?) (distinct-on * ?) (from * ?) (where ?) (group-by * ?)
                      (having ?) (window ?)) (cons :vars args)
    `("(SELECT "
      ,@(if distinct '("DISTINCT "))
      ,@(if distinct-on `("DISTINCT ON (" ,@(sql-expand-list distinct-on) ") "))
      ,@(sql-expand-list vars)
      ,@(if from (cons " FROM " (expand-joins from)))
      ,@(if where (cons " WHERE " (sql-expand (car where))))
      ,@(if group-by (cons " GROUP BY " (sql-expand-list group-by)))
      ,@(if having (cons " HAVING " (sql-expand (car having))))
      ,@(if window (cons " WINDOW " (sql-expand-list window)))
      ")")))

(def-sql-op :grouping-sets (&rest args)
  "Grouping-sets allows multiple group-by in a single query

Examples:
    (query (:select 'c1 'c2 'c3 (:sum 'c3)
            :from 'table-name
            :group-by (:grouping-sets (:set 'c1 'c2) (:set 'c1) (:set 'c2) (:set))))
Note that this requires postgresql 9.5 or later."

  `("GROUPING SETS ",@(sql-expand-list args) ))

(def-sql-op :string-agg (&rest args)
  "String-agg allows you to concatenate strings using different types of delimiter symbols.
Allowable optional keyword parameters are :distinct, :order-by and :filter

Examples:

    (query (:select (:as (:string-agg 'bp.step-type \",\" ) 'step-summary) :from 'business-process))

    (query (:select 'mid (:as (:string-agg  'y \",\" :distinct :order-by (:desc 'y) ) 'words) :from 'moves))

    (query (:select (:string-agg  'name \",\" :order-by (:desc 'name) :filter (:< 'id 4)) :from 'employee))

Note that order-by in string-agg requires postgresql 9.0 or later. Filter requires postgresql 9.4 or later.
See tests.lisp for examples."
  (split-on-keywords ((vars *) (distinct - ?)  (order-by * ?)(filter * ?)) (cons :vars args)
    `("STRING_AGG("
      ,@(when distinct '("DISTINCT "))
      ,@(sql-expand-list vars)
      ,@(when order-by `(" ORDER BY " ,@(sql-expand-list order-by)))
      ,@(when filter `(") FILTER (WHERE " ,@(sql-expand (car filter))))
      ")")))

(def-sql-op :array-agg (&rest args)
  "Array-agg returns a list of values concatenated into an array.
Allowable optional keyword parameters are :distinct, :order-by and :filter.

Example:
  (query (:select 'g.id
                  (:as (:array-agg 'g.users :filter (:= 'g.canonical \"Y\")) 'canonical-users)
                  (:as (:array-agg 'g.users :filter (:= 'g.canonical \"N\")) 'non-canonical-users)
                  :from (:as 'groups 'g)
                  :group-by 'g.id)

Note that order-by in array-agg requires postgresql 9.0 or later.
Filter requires postgresql 9.4 or later. See tests.lisp for examples.

"
  (split-on-keywords ((vars *) (distinct - ?)(order-by * ?) (filter * ?)) (cons :vars args)
    `("ARRAY_AGG("
      ,@(when distinct '("DISTINCT "))
      ,@(sql-expand-list vars)
      ,@(when order-by `(" ORDER BY " ,@(sql-expand-list order-by)))
      ,@(when filter `(") FILTER (WHERE " ,@(sql-expand (car filter))))
      ")")))

(def-sql-op :mode (&rest args)
  "Mode is used to find the most frequent input value in a group. See e.g. https://www.postgresql.org/docs/10/static/functions-aggregate.html#FUNCTIONS-ORDEREDSET-TABLE
and article at https://tapoueh.org/blog/2017/11/the-mode-ordered-set-aggregate-function/."
  (split-on-keywords ((vars *)) (cons :vars args)
    `("mode() within group (order by " ,@(sql-expand-list vars) ")")))


(def-sql-op :regr-avgx (y x)
  "The regr-avgx function returns the average of the independent variable (sum(X)/N)

Example:

    (query (:select (:regr-avgx 'height 'weight) :from 'people))"

  `("REGR_AVGX(",@(sql-expand y) " , " ,@(sql-expand x) ")"))

(def-sql-op :regr-avgy (y x)
  "The regr-avgy function returns the average of the dependent variable (sum(Y)/N).

Example:

    (query (:select (:regr-avgy 'height 'weight) :from 'people))"
  `("REGR_AVGY(" ,@(sql-expand y) " , " ,@(sql-expand x) ")"))

(def-sql-op :regr-count (y x)
  "The regr-count function returns the 	number of input rows in which both expressions are nonnull.

Example:

    (query (:select (:regr-count 'height 'weight) :from 'people))"

  `("REGR_COUNT(",@(sql-expand y) " , " ,@(sql-expand x) ")"))

(def-sql-op :regr-intercept (y x)
  "The regr-intercept function returns the y-intercept of the least-squares-fit linear equation determined by the (X, Y) pairs.

Example:

    (query (:select (:regr-intercept 'height 'weight) :from 'people))"

  `("REGR_INTERCEPT(",@(sql-expand y) " , " ,@(sql-expand x) ")"))

(def-sql-op :regr-r2 (y x)
  "The regr-r2 function returns the square of the correlation coefficient.

Example:

    (query (:select (:regr-r2 'height 'weight) :from 'people))"

  `("REGR_R2(",@(sql-expand y) " , " ,@(sql-expand x) ")"))

(def-sql-op :regr-slope (y x)
  "The regr-slope function returns the slope of the least-squares-fit linear equation determined by the (X, Y) pairs.

Example:

    (query (:select (:regr-slope 'height 'weight) :from 'people))"

  `("REGR_SLOPE(",@(sql-expand y) " , " ,@(sql-expand x) ")"))

(def-sql-op :regr-sxx (y x)
  "The regr-sxx function returns the sum(X^2) - sum(X)^2/N (“sum of squares” of the independent variable).

Example:

    (query (:select (:regr-sxx 'height 'weight) :from 'people))"

  `("REGR_SXX(",@(sql-expand y) " , " ,@(sql-expand x) ")"))

(def-sql-op :regr-sxy (y x)
  "The regr-sxy function returns the sum(X*Y) - sum(X) * sum(Y)/N (“sum of products” of independent times dependent variable).

Example:

    (query (:select (:regr-sxy 'height 'weight) :from 'people))"

  `("REGR_SXY(",@(sql-expand y) " , " ,@(sql-expand x) ")"))

(def-sql-op :regr-syy (y x)
  "The regr-syy function returns the sum(Y^2) - sum(Y)^2/N (“sum of squares” of the dependent variable).

Example:

    (query (:select (:regr-syy 'height 'weight) :from 'people))"

  `("REGR_SYY(",@(sql-expand y) " , " ,@(sql-expand x) ")"))

(def-sql-op :stddev (&rest args)
  "The stddev function returns the the sample standard deviation of the input values. It is a historical alias
for stddev-samp.

Example:

    (query (:select (:stddev 'salary) :from 'people))"

  (split-on-keywords ((vars *)) (cons :vars args)
                     `("STDDEV(",@(sql-expand-list vars) ")")))

(def-sql-op :stddev-pop (&rest args)
  "The stddev-pop function returns the population standard deviation of the input values.

Example:

    (query (:select (:stddev-pop 'salary) :from 'people))"

  (split-on-keywords ((vars *)) (cons :vars args)
                     `("STDDEV_POP(",@(sql-expand-list vars) ")")))

(def-sql-op :stddev-samp (&rest args)
  "The stddev-samp function returns the sample standard deviation of the input values.

Example:

    (query (:select (:stddev-samp 'salary) :from 'people))"

  (split-on-keywords ((vars *)) (cons :vars args)
                     `("STDDEV_SAMP(",@(sql-expand-list vars) ")")))

(def-sql-op :variance (&rest args)
  "Variance is a historical alias for var_samp. The variance function returns the sample
variance of the input values (square of the sample standard deviation).

Example:

    (query (:select (:variance 'salary) :from 'people))"

  (split-on-keywords ((vars *)) (cons :vars args)
                     `("VARIANCE(",@(sql-expand-list vars) ")")))

(def-sql-op :var-pop (&rest args)
  "The var-pop function returns the population variance of the input values (square of the population standard deviation).

Example:

    (query (:select (:var-pop 'salary) :from 'people))"

  (split-on-keywords ((vars *)) (cons :vars args)
                     `("VAR_POP(",@(sql-expand-list vars) ")")))

(def-sql-op :var-samp (&rest args)
  "The var-samp function returns the sample variance of the input values (square of the sample standard deviation).

Example:

    (query (:select (:var-samp 'salary) :from 'people))"

  (split-on-keywords ((vars *)) (cons :vars args)
                     `("VAR_SAMP(",@(sql-expand-list vars) ")")))



(def-sql-op :limit (form amount &optional offset)
  `("(" ,@(sql-expand form) " LIMIT " ,@(if amount (sql-expand amount) (list "ALL")) ,@(if offset (cons " OFFSET " (sql-expand offset)) ()) ")"))

(def-sql-op :order-by (form &rest fields)
  (if fields
      `("(" ,@(sql-expand form) " ORDER BY " ,@(sql-expand-list fields) ")")
      `("( ORDER BY " ,@(sql-expand form) ")")))

(def-sql-op :set-constraints (state &rest constraints)
  `("SET CONSTRAINTS " ,@(if constraints
                             (sql-expand-list constraints)
                             '("ALL"))
                       ,(ecase state
                          (:deferred " DEFERRED")
                          (:immediate " IMMEDIATE"))))

(defun for-update/share (share-or-update form &rest args)
  (let* ((of-position (position :of args))
         (no-wait-position (position :nowait args))
         (of-tables (when of-position (subseq args (1+ of-position) no-wait-position))))
    `("(" ,@(sql-expand form) ,(format nil " FOR ~:@(~A~)" share-or-update)
          ,@(when of-tables (list (format nil " OF ~{~A~^, ~}" (mapcar #'sql-compile of-tables))))
          ,@(when no-wait-position (list " NOWAIT"))
          ")")))

(def-sql-op :for-update (form &rest args)
  (apply #'for-update/share "UPDATE" form args))

(def-sql-op :for-share (form &rest args)
  (apply #'for-update/share "SHARE" form args))

(defun escape-sql-expression (expr)
  "Try to escape an expression at compile-time, if not possible, delay
to runtime. Used to create stored procedures."
  (let ((expanded (append (sql-expand expr) '(";"))))
    (if (every 'stringp expanded)
        (sql-escape-string (apply 'concatenate 'string expanded))
        `(sql-escape-string (concatenate 'string ,@(reduce-strings expanded))))))

(def-sql-op :function (name (&rest args) return-type stability body)
  (assert (member stability '(:immutable :stable :volatile)))
  `("CREATE OR REPLACE FUNCTION " ,@(sql-expand name) " (" ,(implode ", " (mapcar 'to-type-name args))
    ") RETURNS " ,(to-type-name return-type) " LANGUAGE SQL " ,(symbol-name stability) " AS " ,(escape-sql-expression body)))

(def-sql-op :insert-into (table &rest rest)
  (split-on-keywords ((method *)
                      (overriding-system-value ? -)
                      (overriding-user-value ? -)
                      (on-conflict-do-nothing ? -)
                      (on-conflict-update ? *)
                      (update-set ? *)
                       (from * ?)
                      (where ?) (returning ? *)) (cons :method rest)

  `("INSERT INTO " ,@(sql-expand table) " "
    ,@(cond ((eq (car method) :set)
             (cond ((oddp (length (cdr method)))
                    (sql-error "Invalid amount of :set arguments passed to insert-into sql operator"))
                   ((null (cdr method)) '("DEFAULT VALUES"))
                   (t `("(" ,@(sql-expand-list (loop :for (field nil) :on (cdr method) :by #'cddr
                                                     :collect field))
                            ") "
                            ,@(cond (overriding-system-value '(" OVERRIDING SYSTEM VALUE "))
                                    (overriding-user-value '(" OVERRIDING USER VALUE ")))
                            " VALUES (" ,@(sql-expand-list (loop :for (nil value) :on (cdr method) :by #'cddr
                                                              :collect value)) ")"))))
            ((and (not (cdr method)) (consp (car method)) (keywordp (caar method)))
             (sql-expand (car method)))
            (t (sql-error "No :set arguments or select operator passed to insert-into sql operator")))
    ,@(when on-conflict-do-nothing
        `(" ON CONFLICT DO NOTHING"))
    ,@(when on-conflict-update
        `(" ON CONFLICT (" ,@(sql-expand-list on-conflict-update) ") DO UPDATE SET "
                                ,@(loop :for (field value) :on update-set :by #'cddr
                                        :for first = t :then nil
                                        :append `(,@(if first () '(", ")) ,@(sql-expand field) " = " ,@(sql-expand value)))
                                ,@(if from (cons " FROM " (expand-joins from)))
                                ,@(if where (cons " WHERE " (sql-expand (car where))) ())))
    ,@(when returning
        `(" RETURNING " ,@(sql-expand-list returning))))))

(def-sql-op :listen (channel)
  `("LISTEN " ,@(sql-expand channel)))

(def-sql-op :unlisten (channel)
  `("UNLISTEN " ,@(sql-expand channel)))

(def-sql-op :notify (channel &optional payload)
  `("NOTIFY " ,@(sql-expand channel)
              ,@(when payload
                  (list ", " (sql-escape-string payload)))))

(defun expand-rows (rows length)
  (unless rows (sql-error "Running :insert-rows-into without data."))
  (unless length (setf length (length (car rows))))
  (let ((*expand-runtime* t))
    (strcat
     (loop :for row :in rows :for first := t :then nil
           :when (/= (length row) length)
           :do (sql-error "Found rows of unequal length in :insert-rows-into.")
           :append `(,@(unless first '(", ")) "(" ,@(sql-expand-list row) ")")))))

(def-sql-op :insert-rows-into (table &rest rest)
  (split-on-keywords ((columns ? *) (values) (returning ? *)) rest
    `("INSERT INTO "
      ,@(sql-expand table) " "
      ,@(when columns `("(" ,@(sql-expand-list columns) ") "))
      "VALUES "
      ,(if *expand-runtime*
           (expand-rows (car values) (and columns (length columns)))
           `(expand-rows ,(car values) ,(and columns (length columns))))
      ,@(when returning `(" RETURNING " ,@(sql-expand-list returning))))))

(def-sql-op :update (table &rest args)
  (split-on-keywords ((set *) (from * ?) (where ?) (returning ? *)) args
    (when (oddp (length set))
      (sql-error "Invalid amount of :set arguments passed to update sql operator"))
    `("UPDATE " ,@(sql-expand table) " SET "
      ,@(loop :for (field value) :on set :by #'cddr
              :for first = t :then nil
              :append `(,@(if first () '(", ")) ,@(sql-expand field) " = " ,@(sql-expand value)))
      ,@(if from (cons " FROM " (expand-joins from)))
      ,@(if where (cons " WHERE " (sql-expand (car where))) ())
      ,@(when returning
          (cons " RETURNING " (sql-expand-list returning))))))

(def-sql-op :delete-from (table &rest args)
  (split-on-keywords ((where ?) (returning ? *)) args
    `("DELETE FROM " ,@(sql-expand table)
                     ,@(when where (cons " WHERE " (sql-expand (car where))))
                     ,@(when returning (cons " RETURNING " (sql-expand-list returning))))))

(def-sql-op :over (form &rest args)
  (if args `("(" ,@(sql-expand form) " OVER " ,@(sql-expand-list args) ")")
          `("(" ,@(sql-expand form) " OVER ()) ")))

(def-sql-op :partition-by (&rest args)
  (split-on-keywords ((partition-by *) (order-by ? *)) (cons :partition-by args)
                     `("(PARTITION BY " ,@(sql-expand-list partition-by)
                                        ,@(when order-by (cons " ORDER BY " (sql-expand-list order-by)))
                                            ")")))

(def-sql-op :parens (op) `(" (" ,@(sql-expand op) ") "))

(def-sql-op :with (&rest args)
  (let ((x (butlast args)) (y (last args)))
    `("WITH " ,@(sql-expand-list x) ,@(sql-expand (car y)))))

(def-sql-op :with-recursive (form1 form2)
  `("WITH RECURSIVE " ,@(sql-expand form1) ,@(sql-expand form2)))

(def-sql-op :window (form)
  `("WINDOW " ,@(sql-expand form)))


;; Data definition

(defun dissect-type (type)
  "Return the type and whether it may be NULL. TYPE may be a list
starting with 'or' containing two, and only two, potential types to
test. "
  (if (and (consp type) (eq (car type) 'or))
      (if (and (member 'db-null type) (= (length type) 3))
          (if (eq (second type) 'db-null)
              (values (third type) t)
              (values (second type) t))
          (sql-error "Invalid type: ~a. 'or' types must have two alternatives, one of which is ~s."
                     type 'db-null))
      (values type nil)))

(defun expand-interval (option)
  "Provide interval limit options"
  (case option
    (:year '("YEAR"))
    (:month '("MONTH"))
    (:day '("DAY"))
    (:hour '("HOUR"))
    (:minute '("MINUTE"))
    (:second '("SECOND"))
    (:year-to-month '("YEAR TO MONTH"))
    (:day-to-hour '("DAY TO HOUR"))
    (:day-to-minute '("DAY TO MINUTE"))
    (:day-to-second '("DAY TO SECOND"))
    (:hour-to-minute '("HOUR TO MINUTE"))
    (:hour-to-second '("HOUR TO SECOND"))
    (:minute-to-second '("MINUTE TO SECOND"))))

(defun expand-foreign-on* (action)
  (case action
    (:restrict "RESTRICT")
    (:set-null "SET NULL")
    (:set-default "SET DEFAULT")
    (:cascade "CASCADE")
    (:no-action "NO ACTION")
    (t (sql-error "Unsupported action for foreign key: ~A" action))))

(defun %build-foreign-reference (target on-delete on-update match)
  `(" REFERENCES "
    ,@(if (consp target)
          `(,(to-sql-name (car target)) "(" ,@(sql-expand-names (cdr target)) ")")
          `(,(to-sql-name target)))
    ,(when match (case match
                   (:match-simple " MATCH SIMPLE")
                   (:match-full " MATCH FULL")
                   (:match-partial " MATCH PARTIAL")))
    " ON DELETE " ,(expand-foreign-on* on-delete)
    " ON UPDATE " ,(expand-foreign-on* on-update)))

(defun expand-table-constraint (option args)
  "Process table constraints that precede the closing parentheses in the table definition for the base level create table.
 The difference between this and the expand-table-constraint-sok function is the parameter list
signature. This expects to receive no sublists. The expand-table-constraint-sok function expects to list of sublists.
This is done to maintain backwards compatibility and most general users do not need the extended version.

Foreign keys have defaults  on-delete restrict, on-update restrict, and match simple. If you want
to change those defaults, you need to specify them in that order.

Per the postgresql documentation at https://www.postgresql.org/docs/10/static/sql-createtable.html

A value inserted into the referencing column(s) is matched against the values of the referenced table and referenced columns using the given match type. There are three match types: MATCH FULL, MATCH PARTIAL, and MATCH SIMPLE (which is the default). MATCH FULL will not allow one column of a multicolumn foreign key to be null unless all foreign key columns are null; if they are all null, the row is not required to have a match in the referenced table. MATCH SIMPLE allows any of the foreign key columns to be null; if any of them are null, the row is not required to have a match in the referenced table. MATCH PARTIAL is not yet implemented. (Of course, NOT NULL constraints can be applied to the referencing column(s) to prevent these cases from arising.)"
  (case option
    (:constraint `("CONSTRAINT " ,(to-sql-name (car args)) " " ,@(expand-table-constraint (cadr args) (cddr args))))
    (:check `("CHECK " ,@(sql-expand (car args))))
    (:primary-key `("PRIMARY KEY (" ,@(sql-expand-names args) ")"))
    (:unique `("UNIQUE (" ,@(sql-expand-names args) ")"))
    (:with `(" WITH " ,@(sql-expand (car args))))
    (:deferrable `("DEFERRABLE "))
    (:not-deferrable `("NOT DEFERRABLE "))
    (:initially-deferred `("INITIALLY DEFERRED "))
    (:initially-immediate `("INITIALLY IMMEDIATE "))
    (:foreign-key
     (destructuring-bind (columns target &optional (on-delete :restrict) (on-update :restrict) (match :match-simple)) args
       `("FOREIGN KEY (" ,@(sql-expand-names columns) ")"
                         ,@(%build-foreign-reference target on-delete on-update match))))))

(defun expand-table-constraint-sok (args)
  "Expand-table-constraint for the create-extended-table sql-op. The difference between the two is the parameter list
signature. This expects a list of sublists. The regular expand-table-constraint expects to receive no sublists.
DOES NOT IMPLEMENT POSTGRESQL FUNCTION EXCLUDE."
  (split-on-keywords ((constraint ? *) (check ? *) (unique ? *) (with ? *)
                      (deferrable ? -) (primary-key ? *) (not-deferrable ? -)
                      (initially-deferred ? -)(initially-immediate ? -)
                      (foreign-key ? *))
           args
    `(,@(when args '(", "))
      ,@(when constraint `("CONSTRAINT " ,(to-sql-name (car constraint)) " "))
        ,@(when check `("CHECK " ,@(sql-expand (car check))))
        ,@(when unique `("UNIQUE (" ,@(sql-expand-names unique) ")"))
        ,@(when with `(" WITH " ,@(sql-expand (car with))))
        ,@(when deferrable `("DEFERRABLE "))
        ,@(when primary-key `("PRIMARY KEY (" ,@(sql-expand-names primary-key) ") "))
        ,@(when not-deferrable `("NOT DEFERRABLE "))
        ,@(when initially-deferred `("INITIALLY DEFERRED "))
        ,@(when initially-immediate `("INITIALLY IMMEDIATE "))
        ,@(when foreign-key
            (destructuring-bind (columns target &optional (on-delete :restrict) (on-update :restrict) (match :match-simple))
                foreign-key
              `("FOREIGN KEY (" ,@(sql-expand-names columns) ")"
                         ,@(%build-foreign-reference target on-delete on-update match)))))))

(defun expand-extended-table-constraint (option args)
  "Process table constraints that follow the closing parentheses in the table definition."
  (case option
    (:distributed-by `(" DISTRIBUTED BY (" ,@(sql-expand-names (car args))") "))
    (:distributed-randomly `(" DISTRIBUTED RANDOMLY "))
    (:with `(" WITH " ,@(sql-expand (car args))))
    (:tablespace `(" TABLESPACE " ,(to-sql-name (car args))))
    (:exclude `(" EXCLUDE USING" ,@(sql-expand (car args)) ,@(sql-expand (cdr args))))
    (:partition-by-range `(" PARTITION BY RANGE (" ,@(sql-expand (car args)) ,(when (cadr args) ", ")
                                                   ,@(when (cadr args) (sql-expand (cadr args)))
                                                   ")"))
    (:partition-of `(" PARTITION OF " ,(to-sql-name (car args)) " DEFAULT "))  ;postgresql version 11 required
    (:partition-by-list `(" PARTITION BY RANGE (" ,@(sql-expand (car args)) ")"))))

(defun expand-identity (keywd)
  (cond ((eq keywd :identity-by-default)
         '(" GENERATED BY DEFAULT AS IDENTITY "))
        ((eq keywd :generated-as-identity-by-default)
         '(" GENERATED BY DEFAULT AS IDENTITY "))
        ((eq keywd :identity-always)
         '(" GENERATED ALWAYS AS IDENTITY "))
        ((eq keywd :generated-as-identity-always)
         '(" GENERATED ALWAYS AS IDENTITY "))
        ((eq keywd :set-identity-always)
         '(" GENERATED ALWAYS AS IDENTITY "))
        ((eq keywd :add-identity-by-default)
         '(" ADD GENERATED BY DEFAULT AS IDENTITY "))
        ((eq keywd :add-identity-always)
         '(" ADD GENERATED ALWAYS AS IDENTITY "))
        ((eq keywd :set-identity-by-default)
         '(" SET GENERATED BY DEFAULT "))
        ((eq keywd :set-identity-always)
         '(" SET GENERATED ALWAYS "))
        (t "")))

(defun expand-table-column (column-name args)
  `(,(to-sql-name column-name) " "
     ,@(let ((type (or (getf args :type)
                       (sql-error "No type specified for column ~A." column-name))))
         (multiple-value-bind (type null) (dissect-type type)
           `(,(to-type-name type) ,@(when (not null) '(" NOT NULL")))))
     ,@(loop :for (option value) :on args :by #'cddr
             :append (case option
                       (:default `(" DEFAULT " ,@(sql-expand value)))
                       (:interval `(" " ,@(expand-interval value)))
                       (:identity-by-default (when (eq value t) '(" GENERATED BY DEFAULT AS IDENTITY ")))
                       (:identity-always (when (eq value t) '(" GENERATED ALWAYS AS IDENTITY ")))
                       (:generated-as-identity-by-default (when (eq value t) '(" GENERATED BY DEFAULT AS IDENTITY ")))
                       (:generated-as-identity-always (when (eq value t) '(" GENERATED ALWAYS AS IDENTITY ")))
                       (:primary-key (cond ((and value (stringp value)) `(" PRIMARY KEY " ,value))
                                           ((and value (keywordp value)) `(" PRIMARY KEY " ,@(expand-identity value)))
                                           (t '(" PRIMARY KEY "))))
                       (:constraint (when value `(" CONSTRAINT " ,@(sql-expand value))))
                       (:collate (when value `(" COLLATE \"" ,value "\"")))
                       (:unique (cond ((and value (stringp value))
                                       `(" UNIQUE " ,@(sql-expand value)))
                                      (value '(" UNIQUE "))
                                      (t nil)))
                       (:check `(" CHECK " ,@(sql-expand value)))
                       (:references
                        (destructuring-bind (target &optional (on-delete :restrict)
                                                    (on-update :restrict) (match :match-simple))
                            value
                          (%build-foreign-reference target on-delete on-update match)))
                       (:type ())
                       (:deferrable (when (eq value t) '(" DEFERRABLE ")))
                       (:not-deferrable (when (eq value t) '(" NOT DEFERRABLE ")))
                       (:initially-deferred (when (eq value t) '(" INITIALLY DEFERRED ")))
                       (:initially-immediate (when (eq value t) '(" INITIALLY IMMEDIATE ")))
                       (t (sql-error "Unknown column option: ~A." option))))))

(defun expand-composite-table-name (frm)
  "Helper function for building a composite table name"
  (strcat (list (to-sql-name (second frm)) " OF " (to-sql-name (third frm)))))

(defun expand-table-name (name &optional (tableset nil))
  (cond ((and name (stringp name))
         (concatenate 'string (unless tableset  "TABLE ") (to-sql-name name)))
        ((and name (symbolp name))
         (concatenate 'string (unless tableset  "TABLE ") (to-sql-name name)))
        ((and name (listp name))
         (case (car name)
           (quote (concatenate 'string (unless tableset  "TABLE ") (to-sql-name (cadr name))))
           (:temp (concatenate 'string "TEMP TABLE " (expand-table-name (cadr name) t)))
           (:unlogged (concatenate 'string "UNLOGGED TABLE " (expand-table-name (cadr name) t)))
           (:if-not-exists (concatenate 'string (unless tableset  "TABLE ") "IF NOT EXISTS "
                                        (expand-table-name (cadr name) t)))
           (:of (concatenate 'string (unless tableset  "TABLE ") (expand-composite-table-name name)))
           (t (concatenate 'string (unless tableset  "TABLE ") (to-sql-name (car name))))))
        (t (sql-error "Unknown table option: ~A" name))))

(def-sql-op :create-composite-type (type-name &rest args)
  "Creates a composite type with a type-name and two or more
columns. Sample call would be:
   (sql (:create-composite-type 'fullname (first-name text) (last-name text)))"
  `("(CREATE TYPE " ,(cond ((and type-name (stringp type-name))
                            (to-sql-name type-name))
                           ((and type-name (symbolp type-name) (boundp type-name))
                            (format t "Boundp ~a" type-name)
                            (to-sql-name type-name))
                           ((and type-name (symbolp type-name))
                            (format t "Symbolp ~a" type-name)
                            (to-sql-name type-name))
                           ((and type-name (consp type-name) (eq (car type-name) 'quote))
                            (to-sql-name (cadr type-name)))
                           (t "ERROR in create-composite-type type-name"))
                           " AS ("
     ,(implode ", "
       (loop for x in args
         collect (cons-to-sql-name-strings x)))
     ")"))

(def-sql-op :create-table (name (&rest columns) &rest options)
  (let ((typed-table (and (listp name) (eq (car name) :of))))
    (when (and (null columns) (not typed-table))
      (sql-error "No columns defined for table ~A." name))
  `("CREATE " ,@(list (expand-table-name name)) " ("
                    ,@(loop :for ((column-name . args) . rest) :on columns
                         :append (expand-table-column column-name args)
                         :if rest :collect ", ")
                    ,@(when (and columns options) '(", "))
                    ,@(loop :for ((option . args) . rest) :on options
                         :append (expand-table-constraint option args)
                         :if rest :collect ", ")
                    ")")))

(def-sql-op :create-extended-table (name (&rest columns) &optional
                                         table-constraints
                                         extended-table-constraints)
  "Create a table with more complete syntax where table-constraints and extended-table-constraints are lists.
Note that with extended tables you can have tables without columns that are inherited or partitioned."
  `("CREATE " ,@(list (expand-table-name name)) " ("
                    ,@(loop :for ((column-name . args) . rest) :on columns
                         :append (expand-table-column column-name args)
                         :if rest :collect ", ")
                    ,@(loop for constraint in table-constraints
                         :for i from (length table-constraints) downto 0
                         :append (expand-table-constraint-sok constraint)
                           ;if (> i 0) collect ", "
                           )
                     ")"
                    ,@(loop :for ((constraint . args)) :on extended-table-constraints
                         :append (expand-extended-table-constraint constraint args))))

(defun alter-table-column (column-name args)
  "Generates the sql string for the portion of altering a column."
  `(,(to-sql-name column-name *escape-sql-names-p* t) " "
     ,@(loop :for (option value) :on args :by #'cddr
          :append (case option
                    (:default `(" DEFAULT " ,@(sql-expand value)))
                    (:add-identity-by-default (cond  ((stringp value) `(" ADD GENERATED BY DEFAULT AS IDENTITY (" ,value ")"))
                                                     (t '(" ADD GENERATED BY DEFAULT AS IDENTITY "))))
                    (:add-identity-always (cond  ((stringp value) `(" ADD GENERATED ALWAYS AS IDENTITY (" ,value ")"))
                                                 (t '(" ADD GENERATED ALWAYS AS IDENTITY "))))
                    (:set-identity-by-default (cond  ((stringp value)  `(" SET GENERATED BY DEFAULT (" ,value ")"))
                                                     (t '(" SET GENERATED BY DEFAULT "))))
                    (:set-identity-always (cond  ((stringp value) `(" SET GENERATED ALWAYS (" ,value ")"))
                                                 (t '(" SET GENERATED ALWAYS "))))
                    (:set-statistics (when (integerp value) `("SET STATISTICS " ,(write-to-string value) " ")))
                    (:collate (when (and value (stringp value))
                                `(" COLLATE \"" ,value "\"")))
                    (:type (multiple-value-bind (type null) (dissect-type value)
                             `(" TYPE " ,(to-type-name type) ,@(when (not null) '(" NOT NULL")))))
                    (:primary-key (cond ((and value (stringp value)) `(" PRIMARY KEY " ,value))
                                        ((and value (keywordp value)) `(" PRIMARY KEY " ,@(expand-identity value)))
                                        (t '(" PRIMARY KEY "))))
                    (:unique (cond ((and value (stringp value))
                                    `(" UNIQUE " ,@(sql-expand value)))
                                   (value '(" UNIQUE "))
                                   (t nil)))
                    (:references
                     (destructuring-bind (target &optional (on-delete :restrict)
                                                 (on-update :restrict) (match :match-simple))
                         value
                       (%build-foreign-reference target on-delete on-update match)))
                    (:drop-default `(" DROP DEFAULT "))
                    (:drop-not-null '(" DROP NOT NULL "))
                    (:set-default `(" SET DEFAULT " ,@ (sql-expand value)))
                    (:set-not-null '(" SET NOT NULL "))
                    (:drop-identity (when value `(" DROP IDENTITY " ,@(sql-expand value))))
                    (:check `(" CHECK " ,@(sql-expand value)))
                    (t (sql-error "Unknown alter column option: ~A." option))))))

(def-sql-op :create-table-full (name (&rest columns) (&rest table-constraints) (&rest extended-table-constraints))
  "Create a table with more complete syntax."
  (when (null columns)
    (sql-error "No columns defined for table ~A." name))
  `("CREATE " ,@ (list (expand-table-name name)) " ("
                    ,@(loop :for ((column-name . args) . rest) :on columns
                            :append (expand-table-column column-name args)
                            :if rest :collect ", ")
                    ,@(loop :for ((constraint . args)) :on table-constraints
			    :collect ", "
                            :append (expand-table-constraint constraint args))
                    ")"
                    ,@(loop :for ((constraint . args)) :on extended-table-constraints
                         :append (expand-extended-table-constraint constraint args))))

(def-sql-op :alter-table (name action &rest args)
  (labels
      ((drop-action (action)
         (case action
           (:restrict " RESTRICT")
           (:cascade " CASCADE")
           (t (sql-error "Unknown DROP action ~A." action))))
       (base-action (action args)
         (case action
           (:add (cons "ADD " (expand-table-constraint (first args) (rest args))))
           (:add-column (cons "ADD COLUMN "
                              (expand-table-column (first args) (rest args))))
           (:alter-column (cons "ALTER COLUMN "
                              (alter-table-column (first args) (rest args))))
           (:drop-column (list "DROP COLUMN "
                               (to-sql-name (first args) *escape-sql-names-p* t)
                               (if (rest args)
                                       (drop-action (second args))
                                       "")))
           (:add-constraint (append (list "ADD CONSTRAINT ")
                                    (list (to-sql-name (first args) *escape-sql-names-p* t) " ")
                                    (expand-table-constraint (second args)
                                                             (cddr args))))
           (:drop-constraint (list "DROP CONSTRAINT "
                                   (to-sql-name (first args))
                                   (if (rest args)
                                       (drop-action (second args))
                                       "")))
           (:rename (list "RENAME TO " (to-sql-name (first args))))
           (:rename-column (list "RENAME COLUMN " (to-sql-name (first args)) " TO " (to-sql-name (second args))))
           (:rename-constraint (list "RENAME CONSTRAINT " (to-sql-name (first args)) " TO " (to-sql-name (second args))))
           (t (sql-error "Unknown ALTER TABLE action ~A" action)))))
    `("ALTER TABLE "
      ,(to-sql-name name) " "
      ,@(if (listp action)
            (loop :for (item . rest) on action
               :append (base-action (car item) (cdr item))
               :if rest :collect ", ")
          (base-action action args)))))


(def-sql-op :alter-sequence (name action &optional argument)
  `("ALTER SEQUENCE "
    ,(to-sql-name name)
    ,@(case action
        (:increment `(" INCREMENT BY " ,(write-to-string argument)))
        (:min-value `(" MINVALUE " ,(write-to-string argument)))
        (:max-value `(" MAXVALUE " ,(write-to-string argument)))
        (:no-min `(" NO MINVALUE"))
        (:no-max `(" NO MAXVALUE"))
        (:start `(" START " ,(write-to-string argument)))
        (:restart `(" RESTART " ,(write-to-string argument)))
        (:cache `(" CACHE " ,(write-to-string argument)))
        (:cycle `(" CYCLE"))
        (:no-cycle `(" NO CYCLE"))
        (:owned-by `(" OWNED BY " ,(to-sql-name  argument)))
        (t (sql-error "Unknown ALTER SEQUENCE action ~A" action)))))

(defun expand-create-index (name args)
  "Available parameters - in order after name - are :concurrently, :on, :using, :fields
and :where.The advantage to using the keyword :concurrently is that writes to the table
from other sessions are not locked out while the index is is built. The disadvantage is
that the table will need to be scanned twice. Everything is a trade-off."
  (split-on-keywords ((unique ? -) (concurrently ? -)  (on) (using ?) (fields *) (where ?)) args
    `(,@(when unique '("UNIQUE "))
        "INDEX "
        ,@(when concurrently '("CONCURRENTLY "))
        ,@(if (and (listp name) (eq (car name) :if-not-exists))
              (list "IF NOT EXISTS " (car (sql-expand (cadr name))))
              (sql-expand name))
        " ON "
        ,(to-sql-name (cond ((stringp (car on))
                             (car on))
                            ((consp (car on))
                             (cadar on))
                            (t (car on)))
                      *escape-sql-names-p* t)
      ,@(when using `(" USING " ,(cond ((stringp (car using))
                                        (to-sql-name (car using)))
                                       ((consp (car using))
                                        (to-sql-name (cadar using)))
                                       (t (to-sql-name (car using))))))
      " (" ,@(sql-expand-names fields) ")"
      ,@(when where `(" WHERE " ,@(sql-expand (first where)))))))

(def-sql-op :create-index (name &rest args)
  (cons "CREATE " (expand-create-index name args)))

(def-sql-op :create-unique-index (name &rest args)
  (cons "CREATE UNIQUE " (expand-create-index name args)))

(def-sql-op :cascade (op)
  `(,@(sql-expand op) " CASCADE"))

(defmacro def-drop-op (op-name word)
  `(def-sql-op ,op-name (&rest args)
     (let ((concurrently (if (eq (car args) :concurrently)
                          (pop args)
                          nil))
           (if-exists (if (eq (car args) :if-exists)
                          (pop args)
                          nil))
           (name (pop args))
           (cascade (if (or (eq (car args) :cascade)
                            (eq (cadr args) :cascade))
                        t
                        nil)))
       `("DROP " ,,word " "
                 ,@(when concurrently '("CONCURRENTLY "))
                 ,@(when if-exists '("IF EXISTS "))
                 ,@(if (and (consp name) (eq :if-exists (car name)))
                       `("IF EXISTS " ,(car (sql-expand (cadr name))))
                         (sql-expand name))
         ,@(when cascade '(" CASCADE"))))))

(def-drop-op :drop-table "TABLE")
(def-drop-op :drop-index "INDEX")
(def-drop-op :drop-sequence "SEQUENCE")
(def-drop-op :drop-view "VIEW")
(def-drop-op :drop-type "TYPE")
(def-drop-op :drop-rule "RULE")

(def-sql-op :truncate (&rest args)
  "This query sql-op takes one or more table names and will truncate
  those tables (deleting all the rows. The following keyword parameters
  are optionally allowed and must be in this order.
    :only will truncate only this table and not descendent tables.
    :restart-identity will restart any sequences owned by the table.
    :continue-identity will continue sequences owned by the table.
    :cascade will cascade the truncation through tables using foreign keys."
  (split-on-keywords ((vars *) (only - ?) (restart-identity - ?) (continue-identity - ?)(cascade - ? ))
      (cons :vars args)
    `("TRUNCATE "
      ,@(when only '(" ONLY "))
      ,@(sql-expand-list vars)
      ,@(cond (restart-identity '(" RESTART IDENTITY "))
              (continue-identity `(" CONTINUE IDENTITY "))
              (t '("")))
      ,@(when cascade '(" CASCADE ")))))

(defun quoted-name-p (name)
  "Helper function which may be useful for certain macros.
Takes what might be a string, a symbol or a quoted-name in the form
 '(quote name) and returns the string version of the name."
  (cond ((and (consp name) (eq (car name) 'quote) (equal (length name) 2))
         (string (cadr name)))
        ((symbolp name)
         (string name))
        ((stringp name)
         name)
        (t nil)))

(defun dequote (val)
  "Helper function for macros which look for 'something but that
has been converted to (quote something)."
  (if (and (consp val) (eq (car val) 'quote)) (cadr val) val))

(def-sql-op :nextval (name)
  `("nextval(" ,(if *expand-runtime*
                    (sql-escape-string (to-sql-name (dequote name)))
                    `(sql-escape-string (to-sql-name ,name))) ")"))

(def-sql-op :currval (name)
  `("currval(" ,(if *expand-runtime*
                    (sql-escape-string (to-sql-name (dequote name)))
                    `(sql-escape-string (to-sql-name ,name))) ")"))

(def-sql-op :create-sequence (name &key increment min-value max-value start cache cycle)
  `("CREATE SEQUENCE " ,@(sql-expand name)
    ,@(when increment  `(" INCREMENT " ,@(sql-expand increment)))
    ,@(when min-value `(" MINVALUE " ,@(sql-expand min-value)))
    ,@(when max-value `(" MAXVALUE " ,@(sql-expand max-value)))
    ,@(when start `(" START " ,@(sql-expand start)))
    ,@(when cache `(" CACHE " ,@(sql-expand cache)))
    ,@(when cycle `(" CYCLE"))))

(def-sql-op :create-view (name query)
  ;; does not allow to specify the columns of the view yet
  `("CREATE VIEW " ,(to-sql-name name) " AS " ,@(sql-expand query)))

(def-sql-op :create-enum (name members)
  (let ((strings (loop :for m :in members :collect (etypecase m (symbol (string-downcase m)) (string m)))))
    `("CREATE TYPE " ,@(sql-expand name) " AS ENUM (" ,@(sql-expand-list strings) ")")))

;;; https://www.postgresql.org/docs/current/static/sql-createdomain.html
(def-sql-op :create-domain (name &rest args)
  (split-on-keywords ((type) (default ?) (constraint-name ?) (check ?)) args
    (multiple-value-bind (type may-be-null) (dissect-type (car type))
      `("CREATE DOMAIN " ,@(sql-expand name) " AS " ,(to-type-name type)
                         ,@(when default `(" DEFAULT " ,@(sql-expand (car default))))
                         ,@(when constraint-name `(" CONSTRAINT " ,@(sql-expand (car constraint-name))))
                         ,@(unless may-be-null '(" NOT NULL"))
                         ,@(when check `(" CHECK" ,@(sql-expand (car check))))))))

(def-sql-op :drop-domain (name)
  `("DROP DOMAIN " ,@(sql-expand name)))

;;; https://www.postgresql.org/docs/current/static/sql-createrule.html
(def-sql-op :create-rule (name &rest rest)
  (split-on-keywords ((on) (to) (where ?) (instead ? -) (do ? *)) rest
    (check-type (car on) (member :select :insert :update :delete))
    `("CREATE RULE " ,@(sql-expand name)
      " AS ON " ,(symbol-name (car on)) " TO " ,@(sql-expand (car to))
      ,@(when where `(" WHERE " ,@(sql-expand (car where))))
      " DO" ,@(when instead '(" INSTEAD"))
      ,@(if (or (null do) (eq do :nothing))
            '(" NOTHING")
            `("(" ,@(sql-expand-list do "; ") ")")))))

;;; https://www.postgresql.org/docs/current/static/sql-createdatabase.html
(def-sql-op :create-database (name &rest args)
  "Create a database.
   If the database exists an error is raised."
  (split-on-keywords ((owner ?) (template ?) (encoding ?) (lc-collate ?) (lc-ctype ?) (tablespace ?)
		      (allow-connections ?) (connection-limit ?) (is-template ?))
      args
    `("CREATE DATABASE "
      ,@(sql-expand name)
      ,@(when args `(" WITH"))
      ,@(when owner    `(" OWNER "    ,@(sql-expand (car owner))))
      ,@(when template `(" TEMPLATE " ,@(sql-expand (car template))))
      ,@(when encoding `(" ENCODING " ,@(sql-expand (car encoding))))
      ,@(when lc-collate `(" LC_COLLATE " ,@(sql-expand (car lc-collate))))
      ,@(when lc-ctype `(" LC_CTYPE " ,@(sql-expand (car lc-ctype))))
      ,@(when tablespace `(" TABLESPACE " ,@(sql-expand (car tablespace))))
      ,@(when allow-connections `(" ALLOW_CONNECTIONS ",@(if (car allow-connections) `("TRUE") `("FALSE"))))
      ,@(when connection-limit `(" CONNECTION LIMIT " ,@(sql-expand (car connection-limit))))
      ,@(when is-template `(" IS_TEMPLATE " ,@(if (car is-template) `("TRUE") `("FALSE")))))))

(def-drop-op :drop-database "DATABASE")

;;; https://www.postgresql.org/docs/current/static/sql-createrole.html
(def-sql-op :create-role (name &rest args)
  "Add a new role. A role is an entity that can own database objects
and have database privileges; a role can be considered a “user”, a
“group”, or both depending on how it is used.

:options to create role do not require values, e.g. (:create-role
'foo :options 'SUPERUSER 'NOINHERIT).

connection-limit, valid-until, role, in-role, admin are keyword options that accept values."
  (split-on-keywords ((options ? *) (password ?) (connection-limit ?) (valid-until ?) (role * ?) (in-role * ?) (admin * ?)) args
		     `("CREATE ROLE "
		       ,@(sql-expand name)
		       ,@(when args `(" WITH "))
		       ,@(when options `(,@(sql-expand-list options " ")))
		       ,@(when password    `(" PASSWORD "    ,@(sql-expand (car password))))
		       ,@(when connection-limit `(" CONNECTION LIMIT " ,@(sql-expand (car connection-limit))))
		       ,@(when valid-until `(" VALID UNTIL " ,@(sql-expand (car valid-until))))
		       ,@(when role        `(" ROLE "        ,@(sql-expand-list role) " "))
		       ,@(when in-role     `(" IN ROLE "     ,@(sql-expand-list in-role) " "))
		       ,@(when admin       `(" ADMIN "       ,@(sql-expand-list admin) " ")))))

(def-drop-op :drop-role "ROLE")


;;; https://www.postgresql.org/docs/current/static/sql-copy.html
(def-sql-op :copy (table &rest args)
  "Move data between Postgres tables and filesystem files."
  (split-on-keywords ((columns ? *) (from ?) (to ?) (on-segment ?) (binary ?) (oids ?) (header ?) (delimiter ?) (null ?)
		      (escape ?) (newline ?) (csv ?) (quote ?) (force-not-null ? *) (fill-missing-fields ?)
		      (log-errors ?) (segment-reject-limit ? *)) args
  `("COPY "
      ,@(sql-expand table) " "
      ,@(when columns `("(" ,@(sql-expand-list columns) ") "))
      ,@(when from    `("FROM " ,@(sql-expand (car from)) " "))
      ,@(when to      `("TO " ,@(sql-expand (car to)) " "))
      ,@(when on-segment `("ON SEGMENT "))
      ,@(when binary     `("BINARY "))
      ,@(when oids       `("OIDS "))
      ,@(when header     `("HEADER "))
      ,@(when delimiter  `("DELIMITER " ,@(sql-expand (car delimiter)) " "))
      ,@(when null       `("NULL "      ,@(sql-expand (car null)) " "))
      ,@(when escape     `("ESCAPE "    ,@(sql-expand (car escape)) " "))
      ,@(when newline    `("NEWLINE "   ,@(sql-expand (car newline)) " "))
      ,@(when csv        `("CSV "))
      ,@(when quote      `("QUOTE "     ,@(sql-expand (car quote))))
      ,@(when force-not-null       `("FORCE NOT NULL " ,@(sql-expand-list force-not-null) " "))
      ,@(when fill-missing-fields  `("FILL MISSING FIELDS "))
      ,@(when log-errors           `("LOG ERRORS "))
      ,@(when segment-reject-limit `("SEGMENT REJECT LIMIT " ,@(sql-expand (car segment-reject-limit)) " "
							     ,@(if (second segment-reject-limit) `(,@(sql-expand (second segment-reject-limit)))))))))

#+END_SRC

* Scratch
** [[/Users/Can/Develop/Lisp/mine/scratch/hunchentoot.lisp][hunchentoot]]
#+BEGIN_SRC lisp 
;;; Subclass ACCEPTOR
(defclass vhost (acceptor)
  ;; slots
  ((dispatch-table
    :initform '()
    :accessor dispatch-table
    :documentation "List of dispatch functions"))
  ;; options
  (:default-initargs                    ; default-initargs must be used
   :address "127.0.0.1"))               ; because ACCEPTOR uses it

;;; ======================================================================
;;; Now all we need to do is test it

;;; Instantiate VHOSTs
(defvar vhost1 (make-instance 'vhost :port 50001))
(defvar vhost2 (make-instance 'vhost :port 50000))

;;; Populate each dispatch table
(push
 (create-prefix-dispatcher "/foo" 'foo1)
 (dispatch-table vhost1))

(defparameter router "^/blog/(\\d+)/type/(\\w+)")
(defun 2d-array-to-list (array)
  ;; or (coerce array 'list)
  (map 'list #'identity array))

(defun blog ()
  (break "Blogging ~a !!" "God~")
  (setf (content-type*) "text/html")
  (setf (header-out "Really-Love") "You and I")
  (setf (header-out "Server") "Universe")
  (format t "~%~a~%
Script-name => ~a
Headers => ~a ~%Headers-out => ~a~%~a~%" (request-uri*)
(script-name*)
(headers-in*) (headers-out*) (string-repeat "*" 100))
  ;; (destructuring-bind (id name) (2d-array-to-list (nth-value 1 (scan-to-strings router (request-uri*))))
  (ppcre:register-groups-bind (id name) (router (request-uri*))
    (format nil "
<strong style='color: Navy'>Love</strong> => ~a <br /> Method: ~a <br />
(request-uri) => ~a <br />
(request-uri*) => ~a <br />
id: ~a (~a) <br />
name: ~a"
            (get-parameter "love") (request-method*)
            (request-uri *request*) (request-uri*) id (* 3 (parse-integer id)) name)))

;;; Specialise ACCEPTOR-DISPATCH-REQUEST for VHOSTs
(defmethod acceptor-dispatch-request ((vhost vhost) request)
  ;; try REQUEST on each dispatcher in turn
  (format t "~%~a~%Start a request ~a & ~a ~%" (string-repeat "=" 100) request *request*)
  ;; (return-from ACCEPTOR-DISPATCH-REQUEST "You are good!")
  (mapc (lambda (dispatcher)
	      (let ((handler (funcall dispatcher request)))
            (format t "handler: ~a ~a~%" handler dispatcher)
	        (when handler               ; Handler found. FUNCALL it and return result
              (format t " 💥 Found Handler: ~a~%" handler)
	          (return-from acceptor-dispatch-request (funcall handler)))))
	    (dispatch-table vhost))
  (format t "NexT ~%")
  (call-next-method))



(push
 (create-regex-dispatcher router 'blog)
 (dispatch-table vhost1))

(push
 (create-prefix-dispatcher "/foo" 'foo2)
 (dispatch-table vhost2))

(push
 (create-prefix-dispatcher "/test" (lambda () "How are you"))
 (dispatch-table vhost2))

;;; Define handlers
(defun foo1 () "Hello, Baby")
(defun foo2 () "Goodbye")

;;; Start VHOSTs
(start vhost1)
(start vhost2)
(stop vhost2)
;;; Make some requests
(ql:quickload :drakma)
(drakma:http-request "http://127.0.0.1:50001/foo")
;;; =|
;;; 127.0.0.1 - [2012-06-08 14:30:39] "GET /foo HTTP/1.1" 200 5 "-" "Drakma/1.2.6 (SBCL 1.0.56; Linux; 2.6.32-5-686; http://weitz.de/drakma/)"
;;; =>
;;; "Hello"
;;; 200
;;; ((:CONTENT-LENGTH . "5") (:DATE . "Fri, 08 Jun 2012 14:30:39 GMT")
;;;  (:SERVER . "Hunchentoot 1.2.3") (:CONNECTION . "Close")
;;;  (:CONTENT-TYPE . "text/html; charset=utf-8"))
;;; #<PURI:URI http://127.0.0.1:50001/foo>
;;; #<FLEXI-STREAMS:FLEXI-IO-STREAM {CA90059}>
;;; T
;;; "OK"
(drakma:http-request "http://127.0.0.1:50002/foo")
;;; =|
;;; 127.0.0.1 - [2012-06-08 14:30:47] "GET /foo HTTP/1.1" 200 7 "-" "Drakma/1.2.6 (SBCL 1.0.56; Linux; 2.6.32-5-686; http://weitz.de/drakma/)"
;;; =>
;;; "Goodbye"
;;; 200
;;; ((:CONTENT-LENGTH . "7") (:DATE . "Fri, 08 Jun 2012 14:30:47 GMT")
;;;  (:SERVER . "Hunchentoot 1.2.3") (:CONNECTION . "Close")
;;;  (:CONTENT-TYPE . "text/html; charset=utf-8"))
;;; #<PURI:URI http://127.0.0.1:50002/foo>
;;; #<FLEXI-STREAMS:FLEXI-IO-STREAM {CAE8059}>
;;; T
;;; "OK"

#+END_SRC

* Server
** [[/Users/Can/Develop/Lisp/mine/server/socket.cl][socket]]
#+BEGIN_SRC lisp 
(require 'usocket)
($load-file "lib/socket-server.lisp")

(defpackage :celwk-server
  (:use :common-lisp :usocket)
  (:nicknames :socket)
  (:export :start-server
           :client-request))

(in-package :socket)

(defun start-server (&optional (port 1989) (ip "0.0.0.0"))
  (usocket:socket-server ip port
		 #'(lambda (stream)
		     (format nil "Visitor from ~a" stream)
		     (format t "Visitors  from ~a ~%" stream)
		     (format stream "Hello Guy !!~%Server Time: ~A 👀 ~%"
                             ;; (read)	;; read from server~~
			     (cl-user::now nil)))))


(defun client-request (&optional (port 1989) (ip "0.0.0.0"))
  (let ((sock (usocket:socket-connect ip port)))
    (progn
      (force-output (usocket:socket-stream sock))
      (do ((line                                                  
         (read-line (usocket:socket-stream sock) nil)             
         (read-line (usocket:socket-stream sock) nil)))
       ((not line))                                               
        (format t "~A ~%~A~%" line (CL-USER::string-repeat "=" 60)))
      (format t "Local Time : ~A 🍄  ~%" (cl-user::now nil)))))


(defun resolve-hostname (name)
  "Converts from different types to represent an IP address to
the canonical representation which is an array with four
integers."
  (typecase name
    (null #(0 0 0 0))
    (string (car (sb-bsd-sockets:host-ent-addresses
                  (sb-bsd-sockets:get-host-by-name name))))
    (integer (make-array 4 :initial-contents (list (ash name -24)
                                                   (logand (ash name -16) #xFF)
                                                   (logand (ash name -8) #xFF)
                                                   (logand name #xFF))))
    (t name)))


;; Socket/TCP
; example using sockets in SBCL
; to test, run (main) and then from a shell use netcat:
; $ nc localhost 8080

(defparameter *localhost-address* '(0 0 0 0));; '(127 0 0 1))

#+END_SRC

** [[/Users/Can/Develop/Lisp/others/young/server/optima.lisp][optima]]
#+BEGIN_SRC lisp 
#!/usr/local/bin/sbcl --script

(load "~/.sbclrc")
(ql:quickload '(optima clack))
(use-package :optima)

(defun optima (env)
  (optima:match env
    ((guard (property :path-info path)
	    (alexandria:starts-with-subseq "/foo/" path))
     `(200 nil (,(format nil "The path '~A' is in /foo/~%" path))))
    ((guard (property :path-info path)
	    (alexandria:starts-with-subseq "/bar/" path))
     `(200 nil (,(format nil "The path '~A' is in /bar/~%" path))))
    ((property :path-info path)
     `(404 nil (,(format nil "Path ~A not found~%" path))))))

(clack:clackup #'optima :port 9999)

#+END_SRC

** [[/Users/Can/Develop/Lisp/others/young/server/hello-world.lisp][hello-world]]
#+BEGIN_SRC lisp 
;;;; hello-world.lisp

(ql:quickload "restas")

(restas:define-module #:hello-world
    (:use :cl :restas))

(in-package #:hello-world)

(define-route hello-world ("")
  "Hello World")

(start '#:hello-world :port 8080)


(let ((hash (make-hash-table)))
  (setf (gethash "42" hash) "forty-two"
        (gethash "one" hash) '(42))
    (yason:encode hash))


(hunchentoot:start
  (make-instance 'hunchentoot:easy-acceptor
                 :document-root "/Develop/Lisp/"
                 :port 1989))

(hunchentoot:define-easy-handler (get-symbols :uri "/get-symbols")
    (term)
  (setf (hunchentoot:content-type*) "application/json")
  (with-output-to-string (*standard-output*)
    (yason:encode
     (sort
      (mapcar 'string-downcase (apropos-list term :cl))
      'string<))))


(ql:quickload 'hunchentoot)
(ql:quickload 'yason)
(hunchentoot:start
  (make-instance 'hunchentoot:easy-acceptor
                 :document-root "/root/Lisp/server/"
                 :port 1989))

(hunchentoot:define-easy-handler (get-symbols :uri "/get-symbols")
    (term)
  (setf (hunchentoot:content-type*) "application/json")
  (with-output-to-string (*standard-output*)
    (yason:encode
     (sort
      (mapcar 'string-downcase (apropos-list term :cl))
      'string<))))



(hunchentoot:start (make-instance 'hunchentoot:easy-acceptor
                                  :port 4242))
(hunchentoot:define-easy-handler (test-handler :uri "/test")
    ((name :init-form "Pumpkin"))
  (format nil "<!doctype html>
<title>Common Lisp Recipes</title>
<body>Yo, ~A!  The Lisp time is ~A.</body>"
          name (get-universal-time)))

(ql:quickload "restas")
(restas:define-module #:hello-world
    (:use :cl :restas))
(in-package #:hello-world)
(define-route hello-world ("") 
  "Hello World")
(start '#:hello-world :port 8888)






(defun sh (cmd)
    ; #+clisp
        ; (let ((str (ext:run-shell-command cmd :output:stream)))
        ;     (loop for line = (read-line str nil)
        ;      until (null line)
        ;      do (print line)))
    ; #+ecl 
    ;     (si:system cmd)
    ; #+sbcl 
        (sb-ext:run-program "/bin/sh" (list "-c" cmd) :input nil :output *standard-output*)
    #+clozure 
        (ccl:run-program "/bin/sh" (list "-c" cmd) :input nil :output *standard-output*))

(sexml:with-compiletime-active-layers
    (sexml:standard-sexml sexml:xml-doctype)
  (sexml:support-dtd
   (merge-pathnames "html5.dtd" (asdf:system-source-directory "sexml"))
   :<))
(<:augment-with-doctype "html" "")

(<:p "Helloworld")        











#+END_SRC

** [[/Users/Can/Develop/Lisp/others/young/server/clack.lisp][clack]]
#+BEGIN_SRC lisp 
;;(ql:quickload :clack)
(ql:quickload '(clack alexandria optima cl-ppcre))
(use-package :optima)

(defun last-item (list)
  (car (last list)))
;; (defun process-properties (plist keys)
;;   (loop while plist do
;;        (multiple-value-bind (key value tail) (get-properties plist keys)
;;          (when key (process-property key value))
;;          (setf plist (cddr tail)))))

(defun print-plist (plist)
  (format t "~{~A:~10t ~a~%~}" plist))
  
(defun log-request (env)
  (print-plist env)
  (format t "Headers:~% ~S ~%" (last-item env)));  (alexandria:hash-table-alist (last-item env))))
;;	  (alexandria:hash-table-alist (last env)))
;;     (maphash #'(lambda (k v) (format t "~a => ~a~%" k v)) (last env))
  ;; (let ((text
  ;; 	 (with-output-to-string (out)
  ;; 	   (format out "hello, world ")
  ;; 	   (format out "~s~%" (list 1 2 3))
  ;; 	   (format out "Hello, Can!~%I need your ~a ~%" "love"))))
  ;;   `(200 (:content-type "text/plain") (,text))))

(defun optima (env)
  (optima:match env
    ((guard (property :path-info path)
	    (alexandria:starts-with-subseq "/foo/" path))
     `(200 nil (,(format nil "The path '~A' is in /foo/~%" path))))
    ((guard (property :path-info path)
	    (alexandria:starts-with-subseq "/bar/" path))
     `(200 nil (,(format nil "The path '~A' is in /bar/~%" path))))
    ((property :path-info path)
     `(404 nil (,(format nil "Path ~A not found~%" path))))))

(defparameter *style* "
<style>
body {
  font-family: Consolas;
  color: #2f4863;
  line-height: 1.8em;
}
strong {
  color: #8e2c85;
}
</style>
")

(defun info (env)
  (log-request env)
  (destructuring-bind (&key request-method path-info request-uri query-string headers &allow-other-keys) env
    (let ((html (format nil "~sMethod: ~S <br />Path: ~S <br />URI: ~A <br />Query: ~S<br />~%<br />Headers: <br />~S ~%"
		*style* request-method path-info request-uri query-string
		(cl-ppcre:regex-replace-all "((?:\\w|-)*)\\n? *\\. "
					    (cl-ppcre:regex-replace-all "\"|\\\"|\\(|\\)"
									(format nil "~{ ~s <br />~%~}" (alexandria:hash-table-alist headers))
									"")
					    "<strong>\\1</strong>: "))))
      (setf html (cl-ppcre:regex-replace-all "\"" html ""))
      `(200 nil	(,html)))))
;;		(format nil "~{ ~S <br />~% ~}" (alexandria:hash-table-alist headers)))))))

;; (defparameter *clack-server*
;;   (clack:clackup #'info :port 1989))

#+END_SRC

** [[/Users/Can/Develop/Lisp/others/young/server/app.lisp][app]]
#+BEGIN_SRC lisp 
(ql:quickload :clack)

(clack:clackup
  (lambda (env)
    (declare (ignore env))
    '(200 (:content-type "text/plain") ("Hello, Savior ")))
  :server :woo
  :port 1234
  :use-default-middlewares nil)

;; (defvar *handler*
;;     (clack:clackup
;;       (lambda (env)
;;         (declare (ignore env))
;;         '(200 (:content-type "text/plain") ("Hello, Clack! 🎃 ")))))

#+END_SRC

** [[/Users/Can/Develop/Lisp/mine/server/tcp-socket2.lisp][tcp-socket2]]
#+BEGIN_SRC lisp 
(use-package :sb-bsd-sockets)
(require 'sb-bsd-sockets)

(defparameter *content* "Hello <strong style='color: navy'>Can</strong>")
(defparameter *response-content-length* (length *content*))
(defparameter *address* '(127 0 0 1)) ;; '(0 0 0 0)) => For Internet
;; (setf *address* '(0 0 0 0))
(defparameter *port* 2019)

(defparameter CRLF (format nil "~C~C" #\return #\linefeed))

(defparameter *response*
  (concatenate 'string
               "HTTP/1.1 200 OK" CRLF
               (format nil "Content-Length: ~a" *response-content-length*) CRLF
               "Content-Type: text/html" CRLF
               CRLF
               *content*))


(defun stream-connection (socket)
  "Return a stream bound to an accepted socket connection"
  (socket-make-stream (socket-accept socket)
		      :output t
		      :input t))

(defun event-loop-copy (socket)
  (with-open-stream (stream (stream-connection socket))
    (loop
       (write-line (read-line stream))
       (write-sequence *response* stream)
       (finish-output stream))))

(defun event-loop (socket)
  (princ "Event-loop")
  (loop
     (format t "~&~%Wating...~%")
     (with-open-stream (stream (stream-connection socket))
       (format t "~&Connecting...~%")
       (do ((value (read-line stream) (read-line stream)))	;; waiting
           ((= 1 (length value)))
         (princ value)
         (write-line value))
       (write-sequence *response* stream)
       (finish-output stream)
       (princ "Sent~"))))

(defun event-loop-x (socket)
  (with-open-stream (stream (stream-connection socket))
    ;; (loop
    (print "read")
    (multiple-value-bind (value missing) (read-line stream)
      (write-line value))
    ;; (if missing (return)))
    (write-sequence *response* stream)
    (finish-output stream)
    (print "send")
    ))

(defun create-socket ()
  (let ((socket (make-instance 'inet-socket
			       :type :stream
                               :protocol :tcp)))
    (setf (sockopt-reuse-address socket) t)	;; needed??
    (socket-bind socket *address* *port*)
    (socket-listen socket 1)
    socket))

(defun main ()
  (let ((socket (create-socket)))
    (unwind-protect
	 (event-loop socket)
      (socket-close socket))))

#+END_SRC

** [[/Users/Can/Develop/Lisp/mine/server/tcp-socket.lisp][tcp-socket]]
#+BEGIN_SRC lisp 
;;; Socket/TCP
;;; example using sockets in SBCL
;;; to test, run (main) and then from a shell use netcat:
;;; nc localhost 8080

(use-package :sb-bsd-sockets)

(defparameter *address* '(0 0 0 0))  ;; '(127 0 0 1) for localhost only
(defparameter *port* 2019) ;;8080)



(defparameter *test-data* "Goodbye, <strong style='color: red;'>Savior</strong>")
(defparameter *response-content-length* (length *test-data*))
(defparameter CRLF (format nil "~C~C" #\return #\linefeed))

(defparameter *response*
  (concatenate 'string
               "HTTP/1