;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*-


;;; File converted on 26-Mar-91 10:27:21 from source macros
;;;. Original source {dsk}<usr>local>users>welch>lisp>clos>rev4>il-format>macros.;3 created 19-Feb-91 13:51:21

;;;. Copyright (c) 1991 Venue



(in-package "CLOS")


;;;Macros global variable
;;; definitions, and other random support stuff used by the rest of the system. For simplicity (not
;;; having to use eval-when a lot), this file must be loaded before it can be compiled. 


(in-package 'clos)

(proclaim '(declaration values arglist indentation class variable-rebinding clos-fast-call))


;;; Age old functions which CommonLisp cleaned-up away.  They probably exist in other packages in
;;; all CommonLisp implementations, but I will leave it to the compiler to optimize into calls to
;;; them. Common Lisp BUG: Some Common Lisps define these in the Lisp package which causes all sorts
;;; of lossage.  Common Lisp should explictly specify which symbols appear in the Lisp package. 


(eval-when (compile load eval)
       (defmacro memq (item list)
              `(member ,item ,list :test #'eq))
       (defmacro assq (item list)
              `(assoc ,item ,list :test #'eq))
       (defmacro rassq (item list)
              `(rassoc ,item ,list :test #'eq))
       (defmacro delq (item list)
              `(delete ,item ,list :test #'eq))
       (defmacro posq (item list)
              `(position ,item ,list :test #'eq))
       (defmacro neq (x y)
              `(not (eq ,x ,y)))
       (defun make-caxr (n form)
              (if (< n 4)
                  `(,(nth n '(car cadr caddr cadddr))
                    ,form)
                  (make-caxr (- n 4)
                         `(cddddr ,form))))
       (defun make-cdxr (n form)
              (cond ((zerop n)
                     form)
                    ((< n 5)
                     `(,(nth n '(identity cdr cddr cdddr cddddr))
                       ,form))
                    (t (make-cdxr (- n 4)
                              `(cddddr ,form))))))

(defun zero (&rest ignore)
       (declare (ignore ignore))
       0)

(defun make-plist (keys vals)
       (if (null vals)
           nil
           (list* (car keys)
                  (car vals)
                  (make-plist (cdr keys)
                         (cdr vals)))))

(defun remtail (list tail)
       (if (eq list tail)
           nil
           (cons (car list)
                 (remtail (cdr list)
                        tail))))


;;; ONCE-ONLY does the same thing as it does in zetalisp.  I should have just lifted it from there
;;; but I am honest.  Not only that but this one is written in Common Lisp.  I feel a lot like
;;; bootstrapping, or maybe more like rebuilding Rome. 


(defmacro once-only (vars &body body)
       (let ((gensym-var (gensym))
             (run-time-vars (gensym))
             (run-time-vals (gensym))
             (expand-time-val-forms nil))
            (dolist (var vars)
                (push `(if (or (symbolp ,var)
                               (numberp ,var)
                               (and (listp ,var)
                                    (member (car ,var)
                                           ''function)))
                           ,var
                           (let ((,gensym-var (gensym)))
                                (push ,gensym-var ,run-time-vars)
                                (push ,var ,run-time-vals)
                                ,gensym-var))
                      expand-time-val-forms))
            `(let* (,run-time-vars ,run-time-vals (wrapped-body (let ,(mapcar #'list vars
                                                                             (reverse 
                                                                                expand-time-val-forms
                                                                                    ))
                                                                     ,@body)))
                   `(let ,(mapcar #'list (reverse ,run-time-vars)
                                 (reverse ,run-time-vals))
                         ,wrapped-body))))

(eval-when
 (compile load eval)
 (defun extract-declarations (body &optional environment)
        (declare (values documentation declarations body))
        (let (documentation declarations form)
             (when (and (stringp (car body))
                        (cdr body))
                 (setq documentation (pop body)))
             (block outer
                 (loop (when (null body)
                             (return-from outer nil))
                       (setq form (car body))
                       (when (block inner
                                 (loop (cond ((not (listp form))
                                              (return-from outer nil))
                                             ((eq (car form)
                                                  'declare)
                                              (return-from inner 't))
                                             (t (multiple-value-bind
                                                 (newform macrop)
                                                 (macroexpand-1 form environment)
                                                 (if (or (not (eq newform form))
                                                         macrop)
                                                     (setq form newform)
                                                     (return-from outer nil)))))))
                           (pop body)
                           (dolist (declaration (cdr form))
                               (push declaration declarations)))))
             (values documentation (and declarations `((declare ,.(nreverse declarations))))
                    body))))

(defvar *keyword-package* (find-package 'keyword))

(defun make-keyword (symbol)
       (intern (symbol-name symbol)
              *keyword-package*))

(eval-when (compile load eval)
       (defun string-append (&rest strings)
              (setq strings (copy-list strings))
                                                             ; The explorer can't even rplaca an
                                                             ; &rest arg? 
              (do ((string-loc strings (cdr string-loc)))
                  ((null string-loc)
                   (apply #'concatenate 'string strings))
                (rplaca string-loc (string (car string-loc))))))

(defun symbol-append (sym1 sym2 &optional (package *package*))
       (intern (string-append sym1 sym2)
              package))

(defmacro check-member (place list &key (test #'eql)
                              (pretty-name place))
       (once-only (place list)
              `(or (member ,place ,list :test ,test)
                   (error "The value of ~A, ~S is not one of ~S." ',pretty-name ,place ,list))))

(defmacro alist-entry (alist key make-entry-fn)
       (once-only (alist key)
              `(or (assq ,key ,alist)
                   (progn (setf ,alist (cons (,make-entry-fn ,key)
                                             ,alist))
                          (car ,alist)))))

(defmacro collecting-once (&key initial-value)
       `(let* ((head ,initial-value)
               (tail ,(and initial-value `(last head))))
              (values #'(lambda (value)
                               (if (null head)
                                   (setq head (setq tail (list value)))
                                   (unless (memq value head)
                                       (setq tail (cdr (rplacd tail (list value)))))))
                     #'(lambda nil head))))

(defmacro doplist ((key val)
                   plist &body body &environment env)
       (multiple-value-bind (doc decls bod)
              (extract-declarations body env)
              (declare (ignore doc))
              `(let ((.plist-tail. ,plist)
                     ,key
                     ,val)
                    ,@decls
                    (loop (when (null .plist-tail.)
                                (return nil))
                          (setq ,key (pop .plist-tail.))
                          (when (null .plist-tail.)
                                (error "Malformed plist in doplist, odd number of elements."))
                          (setq ,val (pop .plist-tail.))
                          (progn ,@bod)))))

(defmacro if* (condition true &rest false)
       `(if ,condition
            ,true
            (progn ,@false)))


;; 



;;; printing-random-thing



;; 



;;; Similar to printing-random-object in the lisp machine but much simpler and machine independent. 


(defmacro printing-random-thing ((thing stream)
                                 &body body)
       (once-only (stream)
              `(progn (format ,stream "#<")
                      ,@body
                      (format ,stream " ")
                      (printing-random-thing-internal ,thing ,stream)
                      (format ,stream ">"))))

(defun printing-random-thing-internal (thing stream)
       (let ((*print-base* 8))
            (princ (il:\\hiloc thing)
                   stream)
            (princ "," stream)
            (princ (il:\\loloc thing)
                   stream)))


;; 



;;; 



;; 


(defun capitalize-words (string &optional (dashes-p t))
       (let ((string (copy-seq (string string))))
            (declare (string string))
            (do* ((flag t flag)
                  (length (length string)
                         length)
                  (char nil char)
                  (i 0 (+ i 1)))
                 ((= i length)
                  string)
               (setq char (elt string i))
               (cond ((both-case-p char)
                      (if flag
                          (and (setq flag (lower-case-p char))
                               (setf (elt string i)
                                     (char-upcase char)))
                          (and (not flag)
                               (setf (elt string i)
                                     (char-downcase char))))
                      (setq flag nil))
                     ((char-equal char #\-)
                      (setq flag t)
                      (unless dashes-p
                          (setf (elt string i)
                                #\Space)))
                     (t (setq flag nil))))))


;;; FIND-CLASS This is documented in the CLOS specification. 


(defvar *find-class* (make-hash-table :test #'eq))

(defun legal-class-name-p (x)
       (and (symbolp x)
            (not (keywordp x))))

(defun find-class (symbol &optional (errorp t)
                         environment)
       (declare (ignore environment))
       (or (gethash symbol *find-class*)
           (cond ((null errorp)
                  nil)
                 ((legal-class-name-p symbol)
                  (error "No class named: ~S." symbol))
                 (t (error "~S is not a legal class name." symbol)))))

(defsetf find-class (symbol &optional (errorp t)
                           environment)
       (new-value)
       (declare (ignore errorp environment))
       `(|SETF CLOS FIND-CLASS| ,new-value ,symbol))

(defun |SETF CLOS FIND-CLASS| (new-value symbol)
       (if (legal-class-name-p symbol)
           (setf (gethash symbol *find-class*)
                 new-value)
           (error "~S is not a legal class name." symbol)))

(defun find-wrapper (symbol)
       (class-wrapper (find-class symbol)))

(defmacro gathering1 (gatherer &body body)
  `(gathering ((.gathering1. ,gatherer))
               (macrolet ((gather1 (x)
                                 `(gather ,x .gathering1.)))
                      ,@body)))


;;; 


(defmacro vectorizing (&key (size 0))
       `(let* ((limit ,size)
               (result (make-array limit))
               (index 0))
              (values #'(lambda (value)
                               (if (= index limit)
                                   (error "vectorizing more elements than promised.")
                                   (progn (setf (svref result index)
                                                value)
                                          (incf index)
                                          value)))
                     #'(lambda nil result))))


;;; These are augmented definitions of list-elements and list-tails from iterate.lisp.  These
;;; versions provide the extra :by keyword which can be used to specify the step function through
;;; the list. 


(defmacro *list-elements (list &key (by #'cdr))
       `(let ((tail ,list))
             #'(lambda (finish)
                      (if (endp tail)
                          (funcall finish)
                          (prog1 (car tail)
                              (setq tail (funcall ,by tail)))))))

(defmacro *list-tails (list &key (by #'cdr))
       `(let ((tail ,list))
             #'(lambda (finish)
                      (prog1 (if (endp tail)
                                 (funcall finish)
                                 tail)
                          (setq tail (funcall ,by tail))))))