/[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 by ram, Mon Oct 31 04:27:28 1994 UTC revision 1.41.2.2 by dtc, Fri Jul 7 09:34:25 2000 UTC
# Line 25  Line 25 
25    
26  (proclaim '(special *wild-type* *universal-type* *compiler-error-context*))  (proclaim '(special *wild-type* *universal-type* *compiler-error-context*))
27    
 (declaim (ftype function (setf dylan::value-datum) dylan::find-module  
                 dylan::lookup-varinfo-value  
                 dylan::parse-and-convert dylan::value-datum))  
   
28  ;;;; Deftypes:  ;;;; Deftypes:
29    
30  ;;;  ;;;
 ;;; Should be standard:  
 (deftype boolean () '(member t nil))  
   
 ;;;  
31  ;;; Inlinep is used to determine how a function is called.  The values have  ;;; Inlinep is used to determine how a function is called.  The values have
32  ;;; these meanings:  ;;; these meanings:
33  ;;;        Nil  No declaration seen: do whatever you feel like, but don't dump  ;;;        Nil  No declaration seen: do whatever you feel like, but don't dump
# Line 119  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 275  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 330  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 746  Line 735 
735           (values nil nil))))           (values nil nil))))
736    
737    
738    
739    ;;; With-debug-counters  --  Interface
740    ;;;
741    ;;;    Bind the hashtables and counters used for keeping track of
742    ;;; continuation, TN, and label IDs for the debug dumping routines.
743    ;;;
744    (defmacro with-debug-counters (&body forms)
745      `(let ((*continuation-numbers* (make-hash-table :test #'eq))
746             (*number-continuations* (make-hash-table :test #'eql))
747             (*continuation-number* 0)
748             (*tn-ids* (make-hash-table :test #'eq))
749             (*id-tns* (make-hash-table :test #'eql))
750             (*tn-id* 0)
751             (*id-labels* (make-hash-table :test #'eq))
752             (*label-ids* (make-hash-table :test #'eql))
753             (*label-id* 0))
754         ,@forms))
755    
756    
757  ;;;; The Defprinter macro:  ;;;; The Defprinter macro:
758    
759  (defvar *defprint-pretty* nil  (defvar *defprint-pretty* nil
# Line 757  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 769  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 960  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 1001  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 1013  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 1085  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 1101  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  
changed lines
  Added in v.1.41.2.2

  ViewVC Help
Powered by ViewVC 1.1.5