/[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.58 by rtoy, Mon Apr 19 15:08:20 2010 UTC revision 1.59 by rtoy, Tue Apr 20 17:57:46 2010 UTC
# 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 188  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 415  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 508  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 579  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 597  Line 597 
597    "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 855  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 863  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 907  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 1038  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 1157  Line 1157 
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 1176  Line 1176 
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 1249  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 1287  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 1306  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 1339  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.58  
changed lines
  Added in v.1.59

  ViewVC Help
Powered by ViewVC 1.1.5