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

Diff of /src/compiler/macros.lisp

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

revision 1.41.2.1 by pw, Tue May 23 16:37:19 2000 UTC revision 1.41.2.2 by dtc, Fri Jul 7 09:34:25 2000 UTC
# Line 111  Line 111 
111  ;;;  ;;;
112  (proclaim '(function symbolicate (&rest (or string symbol)) symbol))  (proclaim '(function symbolicate (&rest (or string symbol)) symbol))
113  (defun symbolicate (&rest things)  (defun symbolicate (&rest things)
114      (declare (values symbol))
115    (values (intern (reduce #'(lambda (x y)    (values (intern (reduce #'(lambda (x y)
116                                (concatenate 'string (string x) (string y)))                                (concatenate 'string (string x) (string y)))
117                            things))))                            things))))
# Line 267  Line 268 
268  ;;; bound.  We make the variables IGNORABLE so that we don't have to manually  ;;; bound.  We make the variables IGNORABLE so that we don't have to manually
269  ;;; declare them Ignore if their only purpose is to make the syntax work.  ;;; declare them Ignore if their only purpose is to make the syntax work.
270  ;;;  ;;;
 (proclaim '(function parse-deftransform (list list symbol t) list))  
271  (defun parse-deftransform (lambda-list body args error-form)  (defun parse-deftransform (lambda-list body args error-form)
272      (declare (list lambda-list body) (symbol args))
273    (multiple-value-bind (req opt restp rest keyp keys allowp)    (multiple-value-bind (req opt restp rest keyp keys allowp)
274                         (parse-lambda-list lambda-list)                         (parse-lambda-list lambda-list)
275      (let* ((min-args (length req))      (let* ((min-args (length req))
# Line 322  Line 323 
323                                 `((check-transform-keys ,n-keys ',(keywords))))))                                 `((check-transform-keys ,n-keys ',(keywords))))))
324                  ,error-form)                  ,error-form)
325                (let ,(binds)                (let ,(binds)
                 ;;; ### Bootstrap hack...  
                 #+new-compiler  
326                  (declare (ignorable ,@(vars)))                  (declare (ignorable ,@(vars)))
                 #-new-compiler  
                 (progn ,@(vars))  
327                  ,@body))                  ,@body))
328             (vars)))))))             (vars)))))))
329    
# Line 768  Line 765 
765  ;;;    These functions are called by the expansion of the Defprinter  ;;;    These functions are called by the expansion of the Defprinter
766  ;;; macro to do the actual printing.  ;;; macro to do the actual printing.
767  ;;;  ;;;
 (proclaim '(ftype (function (symbol t stream &optional t) void)  
                   defprinter-prin1 defprinter-princ))  
768  (defun defprinter-prin1 (name value stream &optional indent)  (defun defprinter-prin1 (name value stream &optional indent)
769    (declare (ignore indent))    (declare (symbol name) (stream stream) (ignore indent))
770    (write-string "  " stream)    (write-string "  " stream)
771    (when *print-pretty*    (when *print-pretty*
772      (pprint-newline :linear stream))      (pprint-newline :linear stream))
# Line 780  Line 775 
775    (prin1 value stream))    (prin1 value stream))
776  ;;;  ;;;
777  (defun defprinter-princ (name value stream &optional indent)  (defun defprinter-princ (name value stream &optional indent)
778    (declare (ignore indent))    (declare (symbol name) (stream stream) (ignore indent))
779    (write-string "  " stream)    (write-string "  " stream)
780    (when *print-pretty*    (when *print-pretty*
781      (pprint-newline :linear stream))      (pprint-newline :linear stream))
# Line 971  Line 966 
966          (logand ,@(mapcar #'(lambda (x) `(the attributes ,x)) attributes))))          (logand ,@(mapcar #'(lambda (x) `(the attributes ,x)) attributes))))
967  ;;;  ;;;
968  (proclaim '(inline attributes=))  (proclaim '(inline attributes=))
 (proclaim '(function attributes= (attributes attributes) boolean))  
969  (defun attributes= (attr1 attr2)  (defun attributes= (attr1 attr2)
970      (declare (type attributes attr1 attr2))
971    "Returns true if the attributes present in Attr1 are indentical to those in    "Returns true if the attributes present in Attr1 are indentical to those in
972    Attr2."    Attr2."
973    (eql attr1 attr2))    (eql attr1 attr2))
# Line 1012  Line 1007 
1007  ;;;  ;;;
1008  ;;;    Return the event info for Name or die trying.  ;;;    Return the event info for Name or die trying.
1009  ;;;  ;;;
 (proclaim '(function event-info-or-lose (t) event-info))  
1010  (defun event-info-or-lose (name)  (defun event-info-or-lose (name)
1011      (declare (values event-info))
1012    (let ((res (gethash name *event-info*)))    (let ((res (gethash name *event-info*)))
1013      (unless res      (unless res
1014        (error "~S is not the name of an event." name))        (error "~S is not the name of an event." name))
# Line 1024  Line 1019 
1019    
1020  ;;; Event-Count, Event-Action, Event-Level  --  Interface  ;;; Event-Count, Event-Action, Event-Level  --  Interface
1021  ;;;  ;;;
 (proclaim '(function event-count (symbol) fixnum))  
1022  (defun event-count (name)  (defun event-count (name)
1023    "Return the number of times that Event has happened."    "Return the number of times that Event has happened."
1024      (declare (symbol name) (values fixnum))
1025    (event-info-count (event-info-or-lose name)))    (event-info-count (event-info-or-lose name)))
1026  ;;;  ;;;
 (proclaim '(function event-action (symbol) (or function null)))  
1027  (defun event-action (name)  (defun event-action (name)
1028    "Return the function that is called when Event happens.  If this is null,    "Return the function that is called when Event happens.  If this is null,
1029    there is no action.  The function is passed the node to which the event    there is no action.  The function is passed the node to which the event
1030    happened, or NIL if there is no relevant node.  This may be set with SETF."    happened, or NIL if there is no relevant node.  This may be set with SETF."
1031      (declare (symbol name) (values (or function null)))
1032    (event-info-action (event-info-or-lose name)))    (event-info-action (event-info-or-lose name)))
1033  ;;;  ;;;
 (proclaim '(function %set-event-action (symbol (or function null)) (or function null)))  
1034  (defun %set-event-action (name new-value)  (defun %set-event-action (name new-value)
1035      (declare (symbol name) (type (or function null) new-value)
1036               (values (or function null)))
1037    (setf (event-info-action (event-info-or-lose name))    (setf (event-info-action (event-info-or-lose name))
1038          new-value))          new-value))
1039  ;;;  ;;;
1040  (defsetf event-action %set-event-action)  (defsetf event-action %set-event-action)
1041  ;;;  ;;;
 (proclaim '(function event-level (symbol) unsigned-byte))  
1042  (defun event-level (name)  (defun event-level (name)
1043    "Return the non-negative integer which represents the level of significance    "Return the non-negative integer which represents the level of significance
1044    of the event Name.  This is used to determine whether to print a message when    of the event Name.  This is used to determine whether to print a message when
1045    the event happens.  This may be set with SETF."    the event happens.  This may be set with SETF."
1046      (declare (symbol name) (values unsigned-byte))
1047    (event-info-level (event-info-or-lose name)))    (event-info-level (event-info-or-lose name)))
1048  ;;;  ;;;
 (proclaim '(function %set-event-level (symbol unsigned-byte) unsigned-byte))  
1049  (defun %set-event-level (name new-value)  (defun %set-event-level (name new-value)
1050      (declare (symbol name) (type unsigned-byte new-value)
1051               (values unsigned-byte))
1052    (setf (event-info-level (event-info-or-lose name))    (setf (event-info-level (event-info-or-lose name))
1053          new-value))          new-value))
1054  ;;;  ;;;
# Line 1096  Line 1093 
1093    
1094  ;;; Event-Statistics, Clear-Statistics  --  Interface  ;;; Event-Statistics, Clear-Statistics  --  Interface
1095  ;;;  ;;;
 (proclaim '(function event-statistics (&optional unsigned-byte stream) void))  
1096  (defun event-statistics (&optional (min-count 1) (stream *standard-output*))  (defun event-statistics (&optional (min-count 1) (stream *standard-output*))
1097      (declare (type unsigned-byte min-count) (stream stream) (values))
1098    "Print a listing of events and their counts, sorted by the count.  Events    "Print a listing of events and their counts, sorted by the count.  Events
1099    that happened fewer than Min-Count times will not be printed.  Stream is the    that happened fewer than Min-Count times will not be printed.  Stream is the
1100    stream to write to."    stream to write to."
# Line 1112  Line 1109 
1109                (event-info-description event)))                (event-info-description event)))
1110      (values)))      (values)))
1111  ;;;  ;;;
 (proclaim '(function clear-statistics () void))  
1112  (defun clear-statistics ()  (defun clear-statistics ()
1113      (declare (values))
1114    (maphash #'(lambda (k v)    (maphash #'(lambda (k v)
1115                 (declare (ignore k))                 (declare (ignore k))
1116                 (setf (event-info-count v) 0))                 (setf (event-info-count v) 0))

Legend:
Removed from v.1.41.2.1  
changed lines
  Added in v.1.41.2.2

  ViewVC Help
Powered by ViewVC 1.1.5