/[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.56.26.1 by rtoy, Thu Feb 25 20:34:53 2010 UTC revision 1.59 by rtoy, Tue Apr 20 17:57:46 2010 UTC
# Line 75  Line 75 
75  ;;; the compiler policy parameters.  ;;; the compiler policy parameters.
76  ;;;  ;;;
77  (defmacro policy (node &rest conditions)  (defmacro policy (node &rest conditions)
78    _N"Policy Node Condition*    "Policy Node Condition*
79    Test whether some conditions apply to the current compiler policy for Node.    Test whether some conditions apply to the current compiler policy for Node.
80    Each condition is a predicate form which accesses the policy values by    Each condition is a predicate form which accesses the policy values by
81    referring to them as the variables SPEED, SPACE, SAFETY, CSPEED, BREVITY and    referring to them as the variables SPEED, SPACE, SAFETY, CSPEED, BREVITY and
# Line 127  Line 127 
127  (defun special-form-function (&rest stuff)  (defun special-form-function (&rest stuff)
128    (declare (ignore stuff))    (declare (ignore stuff))
129    (error 'simple-undefined-function    (error 'simple-undefined-function
130           :format-control _"Can't funcall the SYMBOL-FUNCTION of special forms."))           :format-control (intl:gettext "Can't funcall the SYMBOL-FUNCTION of special forms.")))
131    
132  ;;; CONVERT-CONDITION-INTO-COMPILER-ERROR  --  Internal  ;;; CONVERT-CONDITION-INTO-COMPILER-ERROR  --  Internal
133  ;;;  ;;;
# Line 151  Line 151 
151  (defmacro def-ir1-translator (name (lambda-list start-var cont-var  (defmacro def-ir1-translator (name (lambda-list start-var cont-var
152                                                  &key (kind :special-form))                                                  &key (kind :special-form))
153                                     &body body)                                     &body body)
154    _N"Def-IR1-Translator Name (Lambda-List Start-Var Cont-Var {Key Value}*)    "Def-IR1-Translator Name (Lambda-List Start-Var Cont-Var {Key Value}*)
155                        [Doc-String] Form*                        [Doc-String] Form*
156    Define a function that converts a Special-Form or other magical thing into    Define a function that converts a Special-Form or other magical thing into
157    IR1.  Lambda-List is a defmacro style lambda list.  Start-Var and Cont-Var    IR1.  Lambda-List is a defmacro style lambda list.  Start-Var and Cont-Var
# Line 168  Line 168 
168                                :doc-string-allowed t                                :doc-string-allowed t
169                                :environment n-env                                :environment n-env
170                                :error-fun 'convert-condition-into-compiler-error)                                :error-fun 'convert-condition-into-compiler-error)
171          (when doc
172            (intl::note-translatable intl::*default-domain* doc))
173        `(progn        `(progn
174           (declaim (function ,fn-name (continuation continuation t) void))           (declaim (function ,fn-name (continuation continuation t) void))
175           (defun ,fn-name (,start-var ,cont-var ,n-form)           (defun ,fn-name (,start-var ,cont-var ,n-form)
# Line 186  Line 188 
188                   (declare (ignore stuff))                   (declare (ignore stuff))
189                   (error 'simple-undefined-function                   (error 'simple-undefined-function
190                          :name ',name                          :name ',name
191                          :format-control _"Can't funcall the SYMBOL-FUNCTION of the special form ~A."                          :format-control (intl:gettext "Can't funcall the SYMBOL-FUNCTION of the special form ~A.")
192                          :format-arguments (list ',name)))                          :format-arguments (list ',name)))
193                 (setf (symbol-function ',name)                 (setf (symbol-function ',name)
194                       (function ,(symbolicate "SPECIAL-FORM-FUNCTION-" name)))))))))                       (function ,(symbolicate "SPECIAL-FORM-FUNCTION-" name)))))))))
# Line 198  Line 200 
200  ;;; invalid.  ;;; invalid.
201  ;;;  ;;;
202  (defmacro def-source-transform (name lambda-list &body body)  (defmacro def-source-transform (name lambda-list &body body)
203    _N"Def-Source-Transform Name Lambda-List Form*    "Def-Source-Transform Name Lambda-List Form*
204    Define a macro-like source-to-source transformation for the function Name.    Define a macro-like source-to-source transformation for the function Name.
205    A source transform may \"pass\" by returning a non-nil second value.  If the    A source transform may \"pass\" by returning a non-nil second value.  If the
206    transform passes, then the form is converted as a normal function call.  If    transform passes, then the form is converted as a normal function call.  If
# Line 239  Line 241 
241    
242    
243  (defmacro def-primitive-translator (name lambda-list &body body)  (defmacro def-primitive-translator (name lambda-list &body body)
244    _N"Def-Primitive-Translator Name Lambda-List Form*    "Def-Primitive-Translator Name Lambda-List Form*
245    Define a function that converts a use of (%PRIMITIVE Name ...) into Lisp    Define a function that converts a use of (%PRIMITIVE Name ...) into Lisp
246    code.  Lambda-List is a defmacro style lambda list."    code.  Lambda-List is a defmacro style lambda list."
247    (let ((fn-name (symbolicate "PRIMITIVE-TRANSLATE-" name))    (let ((fn-name (symbolicate "PRIMITIVE-TRANSLATE-" name))
# Line 353  Line 355 
355                                            &key result policy node defun-only                                            &key result policy node defun-only
356                                            eval-name important (when :native))                                            eval-name important (when :native))
357                               &parse-body (body decls doc))                               &parse-body (body decls doc))
358    _N"Deftransform Name (Lambda-List [Arg-Types] [Result-Type] {Key Value}*)    "Deftransform Name (Lambda-List [Arg-Types] [Result-Type] {Key Value}*)
359                 Declaration* [Doc-String] Form*                 Declaration* [Doc-String] Form*
360    Define an IR1 transformation for Name.  An IR1 transformation computes a    Define an IR1 transformation for Name.  An IR1 transformation computes a
361    lambda that replaces the function variable reference for the call.  A    lambda that replaces the function variable reference for the call.  A
# Line 413  Line 415 
415                byte-code or both (default :native.)"                byte-code or both (default :native.)"
416    
417    (when (and eval-name defun-only)    (when (and eval-name defun-only)
418      (error _"Can't specify both DEFUN-ONLY and EVAL-NAME."))      (error (intl:gettext "Can't specify both DEFUN-ONLY and EVAL-NAME.")))
419    (let ((n-args (gensym))    (let ((n-args (gensym))
420          (n-node (or node (gensym)))          (n-node (or node (gensym)))
421          (n-decls (gensym))          (n-decls (gensym))
# Line 461  Line 463 
463  ;;;  ;;;
464  (defmacro defknown (name arg-types result-type &optional (attributes '(any))  (defmacro defknown (name arg-types result-type &optional (attributes '(any))
465                           &rest keys)                           &rest keys)
466    _N"Defknown Name Arg-Types Result-Type [Attributes] {Key Value}*    "Defknown Name Arg-Types Result-Type [Attributes] {Key Value}*
467    Declare the function Name to be a known function.  We construct a type    Declare the function Name to be a known function.  We construct a type
468    specifier for the function by wrapping (FUNCTION ...) around the Arg-Types    specifier for the function by wrapping (FUNCTION ...) around the Arg-Types
469    and Result-Type.  Attributes is a an unevaluated list of the boolean    and Result-Type.  Attributes is a an unevaluated list of the boolean
# Line 506  Line 508 
508    optimizers that the function might have."    optimizers that the function might have."
509    (when (and (intersection attributes '(any call unwind))    (when (and (intersection attributes '(any call unwind))
510               (intersection attributes '(movable)))               (intersection attributes '(movable)))
511      (error _"Function cannot have both good and bad attributes: ~S" attributes))      (error (intl:gettext "Function cannot have both good and bad attributes: ~S") attributes))
512    
513    `(%defknown ',(if (and (consp name)    `(%defknown ',(if (and (consp name)
514                           (not (eq (car name) 'setf)))                           (not (eq (car name) 'setf)))
# Line 527  Line 529 
529  (defmacro defoptimizer (what (lambda-list &optional (n-node (gensym))  (defmacro defoptimizer (what (lambda-list &optional (n-node (gensym))
530                                            &rest vars)                                            &rest vars)
531                               &body body)                               &body body)
532    _N"Defoptimizer (Function Kind) (Lambda-List [Node-Var] Var*)    "Defoptimizer (Function Kind) (Lambda-List [Node-Var] Var*)
533                  Declaration* Form*                  Declaration* Form*
534    Define some Kind of optimizer for the named Function.  Function must be a    Define some Kind of optimizer for the named Function.  Function must be a
535    known function.  Lambda-List is used to parse the arguments to the    known function.  Lambda-List is used to parse the arguments to the
# Line 566  Line 568 
568  ;;; Do-Blocks, Do-Blocks-Backwards  --  Interface  ;;; Do-Blocks, Do-Blocks-Backwards  --  Interface
569  ;;;  ;;;
570  (defmacro do-blocks ((block-var component &optional ends result) &body body)  (defmacro do-blocks ((block-var component &optional ends result) &body body)
571    _N"Do-Blocks (Block-Var Component [Ends] [Result-Form]) {Declaration}* {Form}*    "Do-Blocks (Block-Var Component [Ends] [Result-Form]) {Declaration}* {Form}*
572    Iterate over the blocks in a component, binding Block-Var to each block in    Iterate over the blocks in a component, binding Block-Var to each block in
573    turn.  The value of Ends determines whether to iterate over dummy head and    turn.  The value of Ends determines whether to iterate over dummy head and
574    tail blocks:    tail blocks:
# Line 577  Line 579 
579    
580    If supplied, Result-Form is the value to return."    If supplied, Result-Form is the value to return."
581    (unless (member ends '(nil :head :tail :both))    (unless (member ends '(nil :head :tail :both))
582      (error _"Losing Ends value: ~S." ends))      (error (intl:gettext "Losing Ends value: ~S.") ends))
583    (let ((n-component (gensym))    (let ((n-component (gensym))
584          (n-tail (gensym)))          (n-tail (gensym)))
585      `(let* ((,n-component ,component)      `(let* ((,n-component ,component)
# Line 592  Line 594 
594           ,@body))))           ,@body))))
595  ;;;  ;;;
596  (defmacro do-blocks-backwards ((block-var component &optional ends result) &body body)  (defmacro do-blocks-backwards ((block-var component &optional ends result) &body body)
597    _N"Do-Blocks-Backwards (Block-Var Component [Ends] [Result-Form]) {Declaration}* {Form}*    "Do-Blocks-Backwards (Block-Var Component [Ends] [Result-Form]) {Declaration}* {Form}*
598    Like Do-Blocks, only iterate over the blocks in reverse order."    Like Do-Blocks, only iterate over the blocks in reverse order."
599    (unless (member ends '(nil :head :tail :both))    (unless (member ends '(nil :head :tail :both))
600      (error _"Losing Ends value: ~S." ends))      (error (intl:gettext "Losing Ends value: ~S.") ends))
601    (let ((n-component (gensym))    (let ((n-component (gensym))
602          (n-head (gensym)))          (n-head (gensym)))
603      `(let* ((,n-component ,component)      `(let* ((,n-component ,component)
# Line 615  Line 617 
617  ;;;    Could change it not to replicate the code someday perhaps...  ;;;    Could change it not to replicate the code someday perhaps...
618  ;;;  ;;;
619  (defmacro do-uses ((node-var continuation &optional result) &body body)  (defmacro do-uses ((node-var continuation &optional result) &body body)
620    _N"Do-Uses (Node-Var Continuation [Result]) {Declaration}* {Form}*    "Do-Uses (Node-Var Continuation [Result]) {Declaration}* {Form}*
621    Iterate over the uses of Continuation, binding Node to each one succesively."    Iterate over the uses of Continuation, binding Node to each one succesively."
622    (once-only ((n-cont continuation))    (once-only ((n-cont continuation))
623      `(ecase (continuation-kind ,n-cont)      `(ecase (continuation-kind ,n-cont)
# Line 648  Line 650 
650  ;;; BLOCK-LAST each time.  ;;; BLOCK-LAST each time.
651  ;;;  ;;;
652  (defmacro do-nodes ((node-var cont-var block &key restart-p) &body body)  (defmacro do-nodes ((node-var cont-var block &key restart-p) &body body)
653    _N"Do-Nodes (Node-Var Cont-Var Block {Key Value}*) {Declaration}* {Form}*    "Do-Nodes (Node-Var Cont-Var Block {Key Value}*) {Declaration}* {Form}*
654    Iterate over the nodes in Block, binding Node-Var to the each node and    Iterate over the nodes in Block, binding Node-Var to the each node and
655    Cont-Var to the node's Cont.  The only keyword option is Restart-P, which    Cont-Var to the node's Cont.  The only keyword option is Restart-P, which
656    causes iteration to be restarted when a node is deleted out from under us (if    causes iteration to be restarted when a node is deleted out from under us (if
# Line 680  Line 682 
682             (return nil))))))             (return nil))))))
683  ;;;  ;;;
684  (defmacro do-nodes-backwards ((node-var cont-var block) &body body)  (defmacro do-nodes-backwards ((node-var cont-var block) &body body)
685    _N"Do-Nodes-Backwards (Node-Var Cont-Var Block) {Declaration}* {Form}*    "Do-Nodes-Backwards (Node-Var Cont-Var Block) {Declaration}* {Form}*
686    Like Do-Nodes, only iterates in reverse order."    Like Do-Nodes, only iterates in reverse order."
687    (let ((n-block (gensym))    (let ((n-block (gensym))
688          (n-start (gensym))          (n-start (gensym))
# Line 704  Line 706 
706  ;;;    The lexical environment is presumably already null...  ;;;    The lexical environment is presumably already null...
707  ;;;  ;;;
708  (defmacro with-ir1-environment (node &rest forms)  (defmacro with-ir1-environment (node &rest forms)
709    _N"With-IR1-Environment Node Form*    "With-IR1-Environment Node Form*
710    Bind the IR1 context variables so that IR1 conversion can be done after the    Bind the IR1 context variables so that IR1 conversion can be done after the
711    main conversion pass has finished."    main conversion pass has finished."
712    (let ((n-node (gensym)))    (let ((n-node (gensym)))
# Line 735  Line 737 
737  ;;; LEXENV-FIND  --  Interface  ;;; LEXENV-FIND  --  Interface
738  ;;;  ;;;
739  (defmacro lexenv-find (name slot &key test)  (defmacro lexenv-find (name slot &key test)
740    _N"LEXENV-FIND Name Slot {Key Value}*    "LEXENV-FIND Name Slot {Key Value}*
741    Look up Name in the lexical environment namespace designated by Slot,    Look up Name in the lexical environment namespace designated by Slot,
742    returning the <value, T>, or <NIL, NIL> if no entry.  The :TEST keyword    returning the <value, T>, or <NIL, NIL> if no entry.  The :TEST keyword
743    may be used to determine the name equality predicate."    may be used to determine the name equality predicate."
# Line 782  Line 784 
784  ;;;; The Defprinter macro:  ;;;; The Defprinter macro:
785    
786  (defvar *defprint-pretty* nil  (defvar *defprint-pretty* nil
787    _N"If true, defprinter print functions print each slot on a separate line.")    "If true, defprinter print functions print each slot on a separate line.")
788    
789    
790  ;;; Defprinter-Prin1, Defprinter-Princ  --  Internal  ;;; Defprinter-Prin1, Defprinter-Princ  --  Internal
# Line 809  Line 811 
811    (princ value stream))    (princ value stream))
812    
813  (defmacro defprinter (name &rest slots)  (defmacro defprinter (name &rest slots)
814    _N"Defprinter Name Slot-Desc*    "Defprinter Name Slot-Desc*
815    Define some kind of reasonable defstruct structure-print function.  Name    Define some kind of reasonable defstruct structure-print function.  Name
816    is the name of the structure.  We define a function %PRINT-name which    is the name of the structure.  We define a function %PRINT-name which
817    prints the slots in the structure in the way described by the Slot-Descs.    prints the slots in the structure in the way described by the Slot-Descs.
# Line 853  Line 855 
855                                 stream)))                                 stream)))
856                      (:test (setq test (second option)))                      (:test (setq test (second option)))
857                      (t                      (t
858                       (error _"Losing Defprinter option: ~S."                       (error (intl:gettext "Losing Defprinter option: ~S.")
859                              (first option)))))))))                              (first option)))))))))
860    
861        `(defun ,(symbolicate "%PRINT-" name) (structure stream depth)        `(defun ,(symbolicate "%PRINT-" name) (structure stream depth)
# Line 861  Line 863 
863                    (declare (ignorable stream))                    (declare (ignorable stream))
864                    ,@(prints)))                    ,@(prints)))
865             (cond (*print-readably*             (cond (*print-readably*
866                    (error _"~S cannot be printed readably." structure))                    (error (intl:gettext "~S cannot be printed readably.") structure))
867                   ((and *print-level* (>= depth *print-level*))                   ((and *print-level* (>= depth *print-level*))
868                    (format stream "#<~S ~X>"                    (format stream "#<~S ~X>"
869                            ',name                            ',name
# Line 905  Line 907 
907      (dolist (name names)      (dolist (name names)
908        (let ((mask (cdr (assoc name alist))))        (let ((mask (cdr (assoc name alist))))
909          (unless mask          (unless mask
910            (error _"Unknown attribute name: ~S." name))            (error (intl:gettext "Unknown attribute name: ~S.") name))
911          (res mask)))          (res mask)))
912      (res)))      (res)))
913    
# Line 916  Line 918 
918  ;;;    Parse the specification and generate some accessor macros.  ;;;    Parse the specification and generate some accessor macros.
919  ;;;  ;;;
920  (defmacro def-boolean-attribute (name &rest attribute-names)  (defmacro def-boolean-attribute (name &rest attribute-names)
921    _N"Def-Boolean-Attribute Name Attribute-Name*    "Def-Boolean-Attribute Name Attribute-Name*
922    Define a new class of boolean attributes, with the attributes havin the    Define a new class of boolean attributes, with the attributes havin the
923    specified Attribute-Names.  Name is the name of the class, which is used to    specified Attribute-Names.  Name is the name of the class, which is used to
924    generate some macros to manipulate sets of the attributes:    generate some macros to manipulate sets of the attributes:
# Line 979  Line 981 
981  ;;;    And now for some gratuitous pseudo-abstraction...  ;;;    And now for some gratuitous pseudo-abstraction...
982  ;;;  ;;;
983  (defmacro attributes-union (&rest attributes)  (defmacro attributes-union (&rest attributes)
984    _N"Returns the union of all the sets of boolean attributes which are its    "Returns the union of all the sets of boolean attributes which are its
985    arguments."    arguments."
986    `(the attributes    `(the attributes
987          (logior ,@(mapcar #'(lambda (x) `(the attributes ,x)) attributes))))          (logior ,@(mapcar #'(lambda (x) `(the attributes ,x)) attributes))))
988  ;;;  ;;;
989  (defmacro attributes-intersection (&rest attributes)  (defmacro attributes-intersection (&rest attributes)
990    _N"Returns the intersection of all the sets of boolean attributes which are its    "Returns the intersection of all the sets of boolean attributes which are its
991    arguments."    arguments."
992    `(the attributes    `(the attributes
993          (logand ,@(mapcar #'(lambda (x) `(the attributes ,x)) attributes))))          (logand ,@(mapcar #'(lambda (x) `(the attributes ,x)) attributes))))
# Line 993  Line 995 
995  (declaim (inline attributes=))  (declaim (inline attributes=))
996  (defun attributes= (attr1 attr2)  (defun attributes= (attr1 attr2)
997    (declare (type attributes attr1 attr2))    (declare (type attributes attr1 attr2))
998    _N"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
999    Attr2."    Attr2."
1000    (eql attr1 attr2))    (eql attr1 attr2))
1001    
# Line 1036  Line 1038 
1038    (declare (values event-info))    (declare (values event-info))
1039    (let ((res (gethash name *event-info*)))    (let ((res (gethash name *event-info*)))
1040      (unless res      (unless res
1041        (error _"~S is not the name of an event." name))        (error (intl:gettext "~S is not the name of an event.") name))
1042      res))      res))
1043    
1044  ); Eval-When (Compile Load Eval)  ); Eval-When (Compile Load Eval)
# Line 1045  Line 1047 
1047  ;;; Event-Count, Event-Action, Event-Level  --  Interface  ;;; Event-Count, Event-Action, Event-Level  --  Interface
1048  ;;;  ;;;
1049  (defun event-count (name)  (defun event-count (name)
1050    _N"Return the number of times that Event has happened."    "Return the number of times that Event has happened."
1051    (declare (symbol name) (values fixnum))    (declare (symbol name) (values fixnum))
1052    (event-info-count (event-info-or-lose name)))    (event-info-count (event-info-or-lose name)))
1053  ;;;  ;;;
1054  (defun event-action (name)  (defun event-action (name)
1055    _N"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,
1056    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
1057    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."
1058    (declare (symbol name) (values (or function null)))    (declare (symbol name) (values (or function null)))
# Line 1065  Line 1067 
1067  (defsetf event-action %set-event-action)  (defsetf event-action %set-event-action)
1068  ;;;  ;;;
1069  (defun event-level (name)  (defun event-level (name)
1070    _N"Return the non-negative integer which represents the level of significance    "Return the non-negative integer which represents the level of significance
1071    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
1072    the event happens.  This may be set with SETF."    the event happens.  This may be set with SETF."
1073    (declare (symbol name) (values unsigned-byte))    (declare (symbol name) (values unsigned-byte))
# Line 1086  Line 1088 
1088  ;;; it quickly.  ;;; it quickly.
1089  ;;;  ;;;
1090  (defmacro defevent (name description &optional (level 0))  (defmacro defevent (name description &optional (level 0))
1091    _N"Defevent Name Description    "Defevent Name Description
1092    Define a new kind of event.  Name is a symbol which names the event and    Define a new kind of event.  Name is a symbol which names the event and
1093    Description is a string which describes the event.  Level (default 0) is the    Description is a string which describes the event.  Level (default 0) is the
1094    level of significance associated with this event; it is used to determine    level of significance associated with this event; it is used to determine
# Line 1101  Line 1103 
1103    
1104  (declaim (type unsigned-byte *event-note-threshold*))  (declaim (type unsigned-byte *event-note-threshold*))
1105  (defvar *event-note-threshold* 1  (defvar *event-note-threshold* 1
1106    _N"This variable is a non-negative integer specifying the lowest level of    "This variable is a non-negative integer specifying the lowest level of
1107    event that will print a Note when it occurs.")    event that will print a Note when it occurs.")
1108    
1109  ;;; Event  --  Interface  ;;; Event  --  Interface
# Line 1110  Line 1112 
1112  ;;; policy indicates.  ;;; policy indicates.
1113  ;;;  ;;;
1114  (defmacro event (name &optional node)  (defmacro event (name &optional node)
1115    _N"Event Name Node    "Event Name Node
1116    Note that the event with the specified Name has happened.  Node is evaluated    Note that the event with the specified Name has happened.  Node is evaluated
1117    to determine the node to which the event happened."    to determine the node to which the event happened."
1118    `(%event ,(event-info-var (event-info-or-lose name)) ,node))    `(%event ,(event-info-var (event-info-or-lose name)) ,node))
# Line 1120  Line 1122 
1122  ;;;  ;;;
1123  (defun event-statistics (&optional (min-count 1) (stream *standard-output*))  (defun event-statistics (&optional (min-count 1) (stream *standard-output*))
1124    (declare (type unsigned-byte min-count) (stream stream) (values))    (declare (type unsigned-byte min-count) (stream stream) (values))
1125    _N"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
1126    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
1127    stream to write to."    stream to write to."
1128    (collect ((info))    (collect ((info))
# Line 1151  Line 1153 
1153  ;;;  ;;;
1154  (defun find-in (next element list &key (key #'identity)  (defun find-in (next element list &key (key #'identity)
1155                       (test #'eql test-p) (test-not nil not-p))                       (test #'eql test-p) (test-not nil not-p))
1156    _N"Find Element in a null-terminated List linked by the accessor function    "Find Element in a null-terminated List linked by the accessor function
1157    Next.  Key, Test and Test-Not are the same as for generic sequence    Next.  Key, Test and Test-Not are the same as for generic sequence
1158    functions."    functions."
1159    (when (and test-p not-p)    (when (and test-p not-p)
1160      (error _"Silly to supply both :Test and :Test-Not."))      (error (intl:gettext "Silly to supply both :Test and :Test-Not.")))
1161    (if not-p    (if not-p
1162        (do ((current list (funcall next current)))        (do ((current list (funcall next current)))
1163            ((null current) nil)            ((null current) nil)
# Line 1170  Line 1172 
1172  ;;;  ;;;
1173  (defun position-in (next element list &key (key #'identity)  (defun position-in (next element list &key (key #'identity)
1174                       (test #'eql test-p) (test-not nil not-p))                       (test #'eql test-p) (test-not nil not-p))
1175    _N"Return the position of Element (or NIL if absent) in a null-terminated List    "Return the position of Element (or NIL if absent) in a null-terminated List
1176    linked by the accessor function Next.  Key, Test and Test-Not are the same as    linked by the accessor function Next.  Key, Test and Test-Not are the same as
1177    for generic sequence functions."    for generic sequence functions."
1178    (when (and test-p not-p)    (when (and test-p not-p)
1179      (error _"Silly to supply both :Test and :Test-Not."))      (error (intl:gettext "Silly to supply both :Test and :Test-Not.")))
1180    (if not-p    (if not-p
1181        (do ((current list (funcall next current))        (do ((current list (funcall next current))
1182             (i 0 (1+ i)))             (i 0 (1+ i)))
# Line 1191  Line 1193 
1193  ;;; Map-In  --  Interface  ;;; Map-In  --  Interface
1194  ;;;  ;;;
1195  (defun map-in (next function list)  (defun map-in (next function list)
1196    _N"Map Function over the elements in a null-terminated List linked by the    "Map Function over the elements in a null-terminated List linked by the
1197    accessor function Next, returning a list of the results."    accessor function Next, returning a list of the results."
1198    (collect ((res))    (collect ((res))
1199      (do ((current list (funcall next current)))      (do ((current list (funcall next current)))
# Line 1203  Line 1205 
1205  ;;; Deletef-In  --  Interface  ;;; Deletef-In  --  Interface
1206  ;;;  ;;;
1207  (defmacro deletef-in (next place item &environment env)  (defmacro deletef-in (next place item &environment env)
1208    _N"Deletef-In Next Place Item    "Deletef-In Next Place Item
1209    Delete Item from a null-terminated list linked by the accessor function Next    Delete Item from a null-terminated list linked by the accessor function Next
1210    that is stored in Place.  Item must appear exactly once in the list."    that is stored in Place.  Item must appear exactly once in the list."
1211    (multiple-value-bind    (multiple-value-bind
# Line 1231  Line 1233 
1233  ;;; Push-In  --  Interface  ;;; Push-In  --  Interface
1234  ;;;  ;;;
1235  (defmacro push-in (next item place &environment env)  (defmacro push-in (next item place &environment env)
1236    _N"Push Item onto a list linked by the accessor function Next that is stored in    "Push Item onto a list linked by the accessor function Next that is stored in
1237    Place."    Place."
1238    (multiple-value-bind    (multiple-value-bind
1239        (temps vals stores store access)        (temps vals stores store access)
# Line 1247  Line 1249 
1249  ;;;  ;;;
1250  (defmacro eposition (&rest args)  (defmacro eposition (&rest args)
1251    `(or (position ,@args)    `(or (position ,@args)
1252         (error _"Shouldn't happen?")))         (error (intl:gettext "Shouldn't happen?"))))
1253    
1254    
1255  ;;; Modular functions  ;;; Modular functions
# Line 1285  Line 1287 
1287                       (= (length lambda-list)                       (= (length lambda-list)
1288                          (length (modular-fun-info-lambda-list info))))                          (length (modular-fun-info-lambda-list info))))
1289            (setf (modular-fun-info-name info) name)            (setf (modular-fun-info-name info) name)
1290            (warn _"Redefining modular version ~S of ~S for width ~S."            (warn (intl:gettext "Redefining modular version ~S of ~S for width ~S.")
1291                  name prototype width))                  name prototype width))
1292          (setf (gethash prototype kernel::*modular-funs*)          (setf (gethash prototype kernel::*modular-funs*)
1293                (merge 'list                (merge 'list
# Line 1304  Line 1306 
1306    (check-type width unsigned-byte)    (check-type width unsigned-byte)
1307    (dolist (arg lambda-list)    (dolist (arg lambda-list)
1308      (when (member arg lambda-list-keywords)      (when (member arg lambda-list-keywords)
1309        (error _"Lambda list keyword ~S is not supported for ~        (error (intl:gettext "Lambda list keyword ~S is not supported for ~
1310                modular function lambda lists." arg)))                modular function lambda lists.") arg)))
1311    `(progn    `(progn
1312       (%define-modular-fun ',name ',lambda-list ',prototype ,width)       (%define-modular-fun ',name ',lambda-list ',prototype ,width)
1313       (defknown ,name ,(mapcar (constantly 'integer) lambda-list)       (defknown ,name ,(mapcar (constantly 'integer) lambda-list)
# Line 1337  Line 1339 
1339    (check-type name symbol)    (check-type name symbol)
1340    (dolist (arg lambda-list)    (dolist (arg lambda-list)
1341      (when (member arg lambda-list-keywords)      (when (member arg lambda-list-keywords)
1342        (error _"Lambda list keyword ~S is not supported for ~        (error (intl:gettext "Lambda list keyword ~S is not supported for ~
1343                modular function lambda lists." arg)))                modular function lambda lists.") arg)))
1344    (let ((call (gensym))    (let ((call (gensym))
1345          (args (gensym)))          (args (gensym)))
1346      `(setf (gethash ',name kernel::*modular-funs*)      `(setf (gethash ',name kernel::*modular-funs*)

Legend:
Removed from v.1.56.26.1  
changed lines
  Added in v.1.59

  ViewVC Help
Powered by ViewVC 1.1.5