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

Diff of /src/code/macros.lisp

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

revision 1.9 by ram, Tue May 29 16:53:26 1990 UTC revision 1.10 by wlott, Fri Aug 24 18:11:50 1990 UTC
# Line 7  Line 7 
7  ;;; Scott Fahlman (FAHLMAN@CMUC).  ;;; Scott Fahlman (FAHLMAN@CMUC).
8  ;;; **********************************************************************  ;;; **********************************************************************
9  ;;;  ;;;
10    ;;; $Header$
11    ;;;
12  ;;; This file contains the macros that are part of the standard  ;;; This file contains the macros that are part of the standard
13  ;;; Spice Lisp environment.  ;;; Spice Lisp environment.
14  ;;;  ;;;
15  ;;; Written by Scott Fahlman and Rob MacLachlan.  ;;; Written by Scott Fahlman and Rob MacLachlan.
16  ;;; Modified by Bill Chiles to adhere to  ;;; Modified by Bill Chiles to adhere to
17  ;;;  ;;;
18  (in-package 'lisp)  (in-package "LISP")
19  (export '(defvar defparameter defconstant when unless loop setf  (export '(defvar defparameter defconstant when unless loop setf
20            defsetf define-setf-method psetf shiftf rotatef push pushnew pop            defsetf define-setf-method psetf shiftf rotatef push pushnew pop
21            incf decf remf case typecase with-open-file            incf decf remf case typecase with-open-file
# Line 133  Line 135 
135  ;;;  ;;;
136  (defun c::%%defmacro (name definition doc)  (defun c::%%defmacro (name definition doc)
137    (clear-info function where-from name)    (clear-info function where-from name)
138    (setf (info function macro-function name) definition)    #+new-compiler
139    (setf (info function kind name) :macro)    (setf (macro-function name) definition)
140      #-new-compiler
141      (progn
142        (setf (info function macro-function name) definition)
143        (setf (info function kind name) :macro))
144    (setf (documentation name 'function) doc)    (setf (documentation name 'function) doc)
145    name)    name)
146    
# Line 177  Line 183 
183    
184  (defparameter deftype-error-string "Type ~S cannot be used with ~S args.")  (defparameter deftype-error-string "Type ~S cannot be used with ~S args.")
185    
186    #-new-compiler
187    (defvar *bootstrap-deftype* :both)
188    
189    (compiler-let ((*bootstrap-defmacro* :both))
190    
191  (defmacro deftype (name arglist &body body)  (defmacro deftype (name arglist &body body)
192    "Syntax like DEFMACRO, but defines a new type."    "Syntax like DEFMACRO, but defines a new type."
193    (unless (symbolp name)    (unless (symbolp name)
# Line 186  Line 197 
197      (multiple-value-bind (body local-decs doc)      (multiple-value-bind (body local-decs doc)
198                           (parse-defmacro arglist whole body name                           (parse-defmacro arglist whole body name
199                                           :default-default ''*                                           :default-default ''*
200                                           :error-string 'deftype-error-string                                           :error-string 'deftype-error-string)
201                                           )        (let ((guts `(%deftype ',name
202        `(eval-when (compile load eval)                               #'(lambda (,whole)
203           (%deftype ',name                                   ,@local-decs
204                     #'(lambda (,whole) ,@local-decs (block ,name ,body))                                   (block ,name ,body))
205                     ,@(when doc `(,doc)))))))                               ,@(when doc `(,doc)))))
206            #-new-compiler
207            (unless (member :new-compiler *features*)
208              (setf guts
209                    `(let ((*bootstrap-deftype* ,*bootstrap-deftype*))
210                       ,guts)))
211            `(eval-when (compile load eval)
212               ,guts)))))
213    
214    ); compile-let
215  ;;;  ;;;
216  (defun %deftype (name expander &optional doc)  (defun %deftype (name expander &optional doc)
217    (setf (info type kind name) :defined)    #-new-compiler
218    (setf (info type expander name) expander)    (unless (or (eq *bootstrap-deftype* t)
219                  (member :new-compiler *features*))
220        (setf (get name 'deftype-expander)
221              expander))
222      (when #-new-compiler *bootstrap-deftype* #+new-compiler t
223        (setf (info type kind name) :defined)
224        (setf (info type expander name) expander))
225    (when doc    (when doc
226      (setf (documentation name 'type) doc))      (setf (documentation name 'type) doc))
227    (c::%note-type-defined name)    ;; ### Bootstrap hack -- we need to define types before %note-type-defined
228      ;; is defined.
229      (when (fboundp 'c::note-type-defined)
230        (c::%note-type-defined name))
231    name)    name)
232    
233    
# Line 507  Line 536 
536            ;; ### Bootstrap hack...            ;; ### Bootstrap hack...
537            ;; Ignore any DEFSETF info for structure accessors.            ;; Ignore any DEFSETF info for structure accessors.
538            ((info function accessor-for (car form))            ((info function accessor-for (car form))
539             (get-setf-method-inverse form `(funcall #'(setf ,(car form)))))             (get-setf-method-inverse form `(funcall #'(setf ,(car form))) t))
540            ((setq temp (info setf inverse (car form)))            ((setq temp (info setf inverse (car form)))
541             (get-setf-method-inverse form `(,temp)))             (get-setf-method-inverse form `(,temp) nil))
542            ((setq temp (info setf expander (car form)))            ((setq temp (info setf expander (car form)))
543             (funcall temp form environment))             (funcall temp form environment))
544            (t            (t
# Line 517  Line 546 
546                                  (macroexpand-1 form environment)                                  (macroexpand-1 form environment)
547               (if win               (if win
548                   (foo-get-setf-method res environment)                   (foo-get-setf-method res environment)
549                   (get-setf-method-inverse                   (get-setf-method-inverse form
550                    form                                            `(funcall #'(setf ,(car form)))
551                    `(funcall #'(setf ,(car form))))))))))                                            t)))))))
552    
553  (defun get-setf-method-inverse (form inverse)  (defun get-setf-method-inverse (form inverse setf-function)
554    (let ((new-var (gensym))    (let ((new-var (gensym))
555          (vars nil)          (vars nil)
556          (vals nil))          (vals nil))
# Line 530  Line 559 
559        (push x vals))        (push x vals))
560      (setq vals (nreverse vals))      (setq vals (nreverse vals))
561      (values vars vals (list new-var)      (values vars vals (list new-var)
562              `(,@inverse ,@vars ,new-var)              (if setf-function
563                    `(,@inverse ,new-var ,@vars)
564                    `(,@inverse ,@vars ,new-var))
565              `(,(car form) ,@vars))))              `(,(car form) ,@vars))))
566    
567    
# Line 612  Line 643 
643                                 new-access-form)))))                                 new-access-form)))))
644                ,@(if doc                ,@(if doc
645                      `((eval-when (load eval)                      `((eval-when (load eval)
646                          (%put ',access-fn '%setf-documentation ',doc)))                          (setf (info setf documentation ',access-fn) ',doc)))
647                      `((eval-when (load eval)             ;SKH 4/17/84                      `((eval-when (load eval)
648                          (remprop ',access-fn '%setf-documentation))))                          (or (clear-info setf documentation ',access-fn)
649                                (setf (info setf documentation ',access-fn)
650                                      nil)))))
651                ',access-fn)))                ',access-fn)))
652          (t (error "Ill-formed DEFSETF for ~S." access-fn))))          (t (error "Ill-formed DEFSETF for ~S." access-fn))))
653    
# Line 630  Line 663 
663             (cond ((atom (car args))             (cond ((atom (car args))
664                    `(setq ,(car args) ,(cadr args)))                    `(setq ,(car args) ,(cadr args)))
665                   ((info function accessor-for (caar args))                   ((info function accessor-for (caar args))
666                    `(funcall #'(setf ,(caar args)) ,@(cdar args) ,(cadr args)))                    `(funcall #'(setf ,(caar args)) ,(cadr args) ,@(cdar args)))
667                   ((setq temp (info setf inverse (caar args)))                   ((setq temp (info setf inverse (caar args)))
668                    `(,temp ,@(cdar args) ,(cadr args)))                    `(,temp ,@(cdar args) ,(cadr args)))
669                   (t (multiple-value-bind (dummies vals newval setter getter)                   (t (multiple-value-bind (dummies vals newval setter getter)
# Line 927  Line 960 
960    
961  (defsetf elt %setelt)  (defsetf elt %setelt)
962  (defsetf aref %aset)  (defsetf aref %aset)
963    (defsetf row-major-aref %set-row-major-aref)
964  (defsetf svref %svset)  (defsetf svref %svset)
965  (defsetf char %charset)  (defsetf char %charset)
966  (defsetf bit %bitset)  (defsetf bit %bitset)
967  (defsetf schar %scharset)  (defsetf schar %scharset)
968  (defsetf sbit %sbitset)  (defsetf sbit %sbitset)
969    (defsetf %array-dimension %set-array-dimension)
970    (defsetf %raw-bits %set-raw-bits)
971  (defsetf symbol-value set)  (defsetf symbol-value set)
972  (defsetf symbol-function %sp-set-definition)  (defsetf symbol-function %sp-set-definition)
973  (defsetf symbol-plist %sp-set-plist)  (defsetf symbol-plist %sp-set-plist)
# Line 940  Line 976 
976  (defsetf fill-pointer %set-fill-pointer)  (defsetf fill-pointer %set-fill-pointer)
977  (defsetf search-list %set-search-list)  (defsetf search-list %set-search-list)
978    
979    (defsetf sap-ref-8 %set-sap-ref-8)
980    (defsetf signed-sap-ref-8 %set-sap-ref-8)
981    (defsetf sap-ref-16 %set-sap-ref-16)
982    (defsetf signed-sap-ref-16 %set-sap-ref-16)
983    (defsetf sap-ref-32 %set-sap-ref-32)
984    (defsetf signed-sap-ref-32 %set-sap-ref-32)
985    (defsetf sap-ref-sap %set-sap-ref-sap)
986    (defsetf sap-ref-single %set-sap-ref-single)
987    (defsetf sap-ref-double %set-sap-ref-double)
988    
989  (define-setf-method getf (place prop &optional default &environment env)  (define-setf-method getf (place prop &optional default &environment env)
990    (multiple-value-bind (temps values stores set get)    (multiple-value-bind (temps values stores set get)
# Line 1021  Line 1066 
1066                       `(apply (function ,(car getter)) ,@(cdr getter)))))))                       `(apply (function ,(car getter)) ,@(cdr getter)))))))
1067    
1068    
1069    ;;; Special-case a BYTE bytespec so that the compiler can recognize it.
1070    ;;;
1071  (define-setf-method ldb (bytespec place &environment env)  (define-setf-method ldb (bytespec place &environment env)
1072    "The first argument is a byte specifier.  The second is any place form    "The first argument is a byte specifier.  The second is any place form
1073    acceptable to SETF.  Replaces the specified byte of the number in this    acceptable to SETF.  Replaces the specified byte of the number in this
1074    place with bits from the low-order end of the new value."    place with bits from the low-order end of the new value."
1075    (multiple-value-bind (dummies vals newval setter getter)    (multiple-value-bind (dummies vals newval setter getter)
1076                         (foo-get-setf-method place env)                         (foo-get-setf-method place env)
1077      (let ((btemp (gensym))      (if (and (consp bytespec) (eq (car bytespec) 'byte))
1078            (gnuval (gensym)))          (let ((n-size (gensym))
1079        (values (cons btemp dummies)                (n-pos (gensym))
1080                (cons bytespec vals)                (n-new (gensym)))
1081                (list gnuval)            (values (list* n-size n-pos dummies)
1082                `(let ((,(car newval) (dpb ,gnuval ,btemp ,getter)))                    (list* (second bytespec) (third bytespec) vals)
1083                   ,setter                    (list n-new)
1084                   ,gnuval)                    `(let ((,(car newval) (dpb ,n-new (byte ,n-size ,n-pos)
1085                `(ldb ,btemp ,getter)))))                                               ,getter)))
1086                         ,setter
1087                         ,n-new)
1088                      `(ldb (byte ,n-size ,n-pos) ,getter)))
1089            (let ((btemp (gensym))
1090                  (gnuval (gensym)))
1091              (values (cons btemp dummies)
1092                      (cons bytespec vals)
1093                      (list gnuval)
1094                      `(let ((,(car newval) (dpb ,gnuval ,btemp ,getter)))
1095                         ,setter
1096                         ,gnuval)
1097                      `(ldb ,btemp ,getter))))))
1098    
1099    
1100  (define-setf-method mask-field (bytespec place &environment env)  (define-setf-method mask-field (bytespec place &environment env)
# Line 1055  Line 1114 
1114                `(mask-field ,btemp ,getter)))))                `(mask-field ,btemp ,getter)))))
1115    
1116    
 (define-setf-method char-bit (place bit-name &environment env)  
   "The first argument is any place form acceptable to SETF.  Replaces the  
   specified bit of the character in this place with the new value."  
   (multiple-value-bind (dummies vals newval setter getter)  
                        (foo-get-setf-method place env)  
     (let ((btemp (gensym))  
           (gnuval (gensym)))  
       (values `(,@dummies ,btemp)  
               `(,@vals ,bit-name)  
               (list gnuval)  
               `(let ((,(car newval)  
                       (set-char-bit ,getter ,btemp ,gnuval)))  
                  ,setter  
                  ,gnuval)  
               `(char-bit ,getter ,btemp)))))  
   
   
1117  (define-setf-method the (type place &environment env)  (define-setf-method the (type place &environment env)
1118    (multiple-value-bind (dummies vals newval setter getter)    (multiple-value-bind (dummies vals newval setter getter)
1119                         (foo-get-setf-method place env)                         (foo-get-setf-method place env)

Legend:
Removed from v.1.9  
changed lines
  Added in v.1.10

  ViewVC Help
Powered by ViewVC 1.1.5