/[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.24 by gerd, Fri Apr 18 08:54:41 2003 UTC revision 1.25 by gerd, Sun May 4 13:11:21 2003 UTC
# Line 25  Line 25 
25  ;;; *************************************************************************  ;;; *************************************************************************
26  ;;;  ;;;
27    
28  (ext:file-comment  (file-comment
29    "$Header$")    "$Header$")
30  ;;;  ;;;
31  ;;; Macros global variable definitions, and other random support stuff used  ;;; Macros global variable definitions, and other random support stuff used
# Line 43  Line 43 
43  (eval-when (:compile-toplevel :load-toplevel :execute)  (eval-when (:compile-toplevel :load-toplevel :execute)
44    
45    ;; (CLASS-PREDICATE <CLASS-NAME>    ;; (CLASS-PREDICATE <CLASS-NAME>
46    (ext:define-function-name-syntax class-predicate (name)    (define-function-name-syntax class-predicate (name)
47      (when (symbolp (cadr name))      (when (symbolp (cadr name))
48        (values t (cadr name))))        (values t (cadr name))))
49    
50    ;; (SLOT-ACCESSOR <CLASS> <SLOT> <READER/WRITER/BOUNDP>)    ;; (SLOT-ACCESSOR <CLASS> <SLOT> <READER/WRITER/BOUNDP>)
51    ;; <CLASS> is :GLOBAL for functions used by ACCESSOR-SLOT-VALUE etc.    ;; <CLASS> is :GLOBAL for functions used by ACCESSOR-SLOT-VALUE etc.
52    (ext:define-function-name-syntax slot-accessor (name)    (define-function-name-syntax slot-accessor (name)
53      (values (and (symbolp (cadr name))      (values (and (symbolp (cadr name))
54                   (consp (cddr name))                   (consp (cddr name))
55                   (symbolp (caddr name))                   (symbolp (caddr name))
# Line 58  Line 58 
58              (caddr name)))              (caddr name)))
59    
60    ;; (METHOD NAME QUALIFIERS (SPECIALIZERS))    ;; (METHOD NAME QUALIFIERS (SPECIALIZERS))
61    (ext:define-function-name-syntax method (name)    (define-function-name-syntax method (name)
62      (ext:valid-function-name-p (cadr name)))      (valid-function-name-p (cadr name)))
63    
64    ;; (FAST-METHOD NAME QUALIFIERS (SPECIALIZERS))    ;; (FAST-METHOD NAME QUALIFIERS (SPECIALIZERS))
65    (ext:define-function-name-syntax fast-method (name)    (define-function-name-syntax fast-method (name)
66      (ext:valid-function-name-p (cadr name)))      (valid-function-name-p (cadr name)))
67    
68    ;; (EFFECTIVE-METHOD GF-NAME METHOD-SPEC ...)    ;; (EFFECTIVE-METHOD GF-NAME METHOD-SPEC ...)
69    (ext:define-function-name-syntax effective-method (name)    (define-function-name-syntax effective-method (name)
70      (ext:valid-function-name-p (cadr name)))      (valid-function-name-p (cadr name))))
71    
72    ;; (CALL FUNCTION)?  (import '(cl::make-keyword))
   )  
73    
74  ;;;  (defmacro posq (item list)
75  ;;; Age old functions which CommonLisp cleaned-up away.  They probably exist    `(position ,item ,list :test #'eq))
 ;;; in other packages in all CommonLisp implementations, but I will leave it  
 ;;; to the compiler to optimize into calls to them.  
 ;;;  
 (eval-when (:compile-toplevel :load-toplevel :execute)  
   (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 true (&rest ignore) (declare (ignore ignore)) t)  
 (defun false (&rest ignore) (declare (ignore ignore)) nil)  
 (defun zero (&rest ignore) (declare (ignore ignore)) 0)  
   
 (defun get-declaration (name declarations &optional default)  
   (dolist (d declarations default)  
     (dolist (form (cdr d))  
       (when (and (consp form) (eq (car form) name))  
         (return-from get-declaration (cdr form))))))  
76    
77    (defmacro neq (x y)
78      `(not (eq ,x ,y))))
79    
80  (defvar *keyword-package* (find-package "KEYWORD"))  (declaim (inline car-safe))
81    (defun car-safe (obj)
82  (defun make-keyword (symbol)    (when (consp obj)
83    (intern (symbol-name symbol) *keyword-package*))      (car obj)))
84    
85  (defmacro doplist ((key val) plist &body body &environment env)  (defmacro doplist ((key val) plist &body body &environment env)
86    (multiple-value-bind (bod decls doc)    (multiple-value-bind (bod decls doc)
# Line 114  Line 95 
95               (setq ,val (pop .plist-tail.))               (setq ,val (pop .plist-tail.))
96               (progn ,@bod)))))               (progn ,@bod)))))
97    
98  (defmacro dolist-carefully ((var list improper-list-handler) &body body)  
   `(let ((,var nil)  
          (.dolist-carefully. ,list))  
      (loop (when (null .dolist-carefully.) (return nil))  
            (if (consp .dolist-carefully.)  
                (progn  
                  (setq ,var (pop .dolist-carefully.))  
                  ,@body)  
                (,improper-list-handler)))))  
   
   ;;  
 ;;;;;; 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)  
   `(print-unreadable-object (,thing ,stream :identity t) ,@body))  
   
 (defun printing-random-thing-internal (thing stream)  
   (declare (ignore thing stream))  
   nil)  
   
99  ;;;  ;;;
100  ;;; FIND-CLASS  ;;; FIND-CLASS
101  ;;;  ;;;
# Line 255  Line 215 
215    
216  (defsetf slot-value set-slot-value)  (defsetf slot-value set-slot-value)
217    
 (declaim (inline car-safe))  
   
 (defun car-safe (obj)  
   (when (consp obj)  
     (car obj)))  
   
218  (defvar *cold-boot-state* nil)  (defvar *cold-boot-state* nil)
219    
220  #+pcl-debug  #+pcl-debug

Legend:
Removed from v.1.24  
changed lines
  Added in v.1.25

  ViewVC Help
Powered by ViewVC 1.1.5