/[cmucl]/src/pcl/macros.lisp
ViewVC logotype

Diff of /src/pcl/macros.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.19 by pmai, Mon Aug 26 16:09:34 2002 UTC revision 1.20 by pmai, Mon Aug 26 16:58:06 2002 UTC
# Line 72  Line 72 
72  (defmacro posq (item list) `(position ,item ,list :test #'eq))  (defmacro posq (item list) `(position ,item ,list :test #'eq))
73  (defmacro neq (x y) `(not (eq ,x ,y)))  (defmacro neq (x y) `(not (eq ,x ,y)))
74    
   
 (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)))))  
75  )  )
76    
77  (defun true (&rest ignore) (declare (ignore ignore)) t)  (defun true (&rest ignore) (declare (ignore ignore)) t)
78  (defun false (&rest ignore) (declare (ignore ignore)) nil)  (defun false (&rest ignore) (declare (ignore ignore)) nil)
79  (defun zero (&rest ignore) (declare (ignore ignore)) 0)  (defun zero (&rest ignore) (declare (ignore ignore)) 0)
80    
 (defun make-plist (keys vals)  
   (if (null vals)  
       ()  
       (list* (car keys)  
              (car vals)  
              (make-plist (cdr keys) (cdr vals)))))  
   
 (defun remtail (list tail)  
   (if (eq list tail) () (cons (car list) (remtail (cdr list) tail))))  
   
81  (defun get-declaration (name declarations &optional default)  (defun get-declaration (name declarations &optional default)
82    (dolist (d declarations default)    (dolist (d declarations default)
83      (dolist (form (cdr d))      (dolist (form (cdr d))
# Line 110  Line 90 
90  (defun make-keyword (symbol)  (defun make-keyword (symbol)
91    (intern (symbol-name symbol) *keyword-package*))    (intern (symbol-name symbol) *keyword-package*))
92    
 (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))  
   (ext:once-only ((place place) (list 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)  
   (ext:once-only ((alist alist) (key key))  
     `(or (assq ,key ,alist)  
          (progn (setf ,alist (cons (,make-entry-fn ,key) ,alist))  
                 (car ,alist)))))  
   
93  (defmacro doplist ((key val) plist &body body &environment env)  (defmacro doplist ((key val) plist &body body &environment env)
94    (multiple-value-bind (bod decls doc)    (multiple-value-bind (bod decls doc)
95        (system:parse-body body env)        (system:parse-body body env)
# Line 149  Line 103 
103               (setq ,val (pop .plist-tail.))               (setq ,val (pop .plist-tail.))
104               (progn ,@bod)))))               (progn ,@bod)))))
105    
 (defmacro if* (condition true &rest false)  
   `(if ,condition ,true (progn ,@false)))  
   
106  (defmacro dolist-carefully ((var list improper-list-handler) &body body)  (defmacro dolist-carefully ((var list improper-list-handler) &body body)
107    `(let ((,var nil)    `(let ((,var nil)
108           (.dolist-carefully. ,list))           (.dolist-carefully. ,list))

Legend:
Removed from v.1.19  
changed lines
  Added in v.1.20

  ViewVC Help
Powered by ViewVC 1.1.5