/[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.98 by rtoy, Wed Apr 14 17:01:22 2004 UTC revision 1.98.2.2 by rtoy, Tue May 18 14:36:56 2004 UTC
# Line 387  Line 387 
387       (eval-when (:compile-toplevel)       (eval-when (:compile-toplevel)
388         (c::do-defconstant-compile-time ',var ,val ',doc))         (c::do-defconstant-compile-time ',var ,val ',doc))
389       (eval-when (:load-toplevel :execute)       (eval-when (:load-toplevel :execute)
390         (c::%%defconstant ',var ,val ',doc))))         (c::%%defconstant ',var ,val ',doc (c::source-location)))))
391    
392    (defun set-defvar-source-location (name source-location)
393      (setf (info :source-location :defvar name) source-location))
394    
395  ;;; %Defconstant, %%Defconstant  --  Internal  ;;; %Defconstant, %%Defconstant  --  Internal
396  ;;;  ;;;
# Line 396  Line 399 
399  ;;; redefined.  ;;; redefined.
400  ;;;  ;;;
401  (defun c::%defconstant (name value doc)  (defun c::%defconstant (name value doc)
402    (c::%%defconstant name value doc))    (c::%%defconstant name value doc nil))
403  ;;;  ;;;
404  (defun c::%%defconstant (name value doc)  (defun c::%%defconstant (name value doc source-location)
405    (when doc    (when doc
406      (setf (documentation name 'variable) doc))      (setf (documentation name 'variable) doc))
407    (when (boundp name)    (when (boundp name)
# Line 408  Line 411 
411    (setf (symbol-value name) value)    (setf (symbol-value name) value)
412    (setf (info variable kind name) :constant)    (setf (info variable kind name) :constant)
413    (clear-info variable constant-value name)    (clear-info variable constant-value name)
414      (set-defvar-source-location name source-location)
415    name)    name)
416    
417    
# Line 423  Line 427 
427               (setq ,var ,val))))               (setq ,var ,val))))
428      ,@(when docp      ,@(when docp
429          `((setf (documentation ',var 'variable) ',doc)))          `((setf (documentation ',var 'variable) ',doc)))
430        (set-defvar-source-location ',var (c::source-location))
431      ',var))      ',var))
432    
433  (defmacro defparameter (var val &optional (doc nil docp))  (defmacro defparameter (var val &optional (doc nil docp))
# Line 435  Line 440 
440      (setq ,var ,val)      (setq ,var ,val)
441      ,@(when docp      ,@(when docp
442          `((setf (documentation ',var 'variable) ',doc)))          `((setf (documentation ',var 'variable) ',doc)))
443        (set-defvar-source-location ',var (c::source-location))
444      ',var))      ',var))
445    
446    
# Line 537  Line 543 
543  ;;;  ;;;
544  (defmacro multiple-value-setq (varlist value-form)  (defmacro multiple-value-setq (varlist value-form)
545    (unless (and (listp varlist) (every #'symbolp varlist))    (unless (and (listp varlist) (every #'symbolp varlist))
546      (error "Varlist is not a list of symbols: ~S." varlist))      (simple-program-error "Varlist is not a list of symbols: ~S." varlist))
547    `(values (setf (values ,@varlist) ,value-form)))    `(values (setf (values ,@varlist) ,value-form)))
548    
549  ;;;  ;;;
550  (defmacro multiple-value-bind (varlist value-form &body body)  (defmacro multiple-value-bind (varlist value-form &body body)
551    (unless (and (listp varlist) (every #'symbolp varlist))    (unless (and (listp varlist) (every #'symbolp varlist))
552      (error "Varlist is not a list of symbols: ~S." varlist))      (simple-program-error  "Varlist is not a list of symbols: ~S." varlist))
553    (if (= (length varlist) 1)    (if (= (length varlist) 1)
554        `(let ((,(car varlist) ,value-form))        `(let ((,(car varlist) ,value-form))
555           ,@body)           ,@body)
556        (let ((ignore (gensym)))        (let ((ignore (gensym)))
557          `(multiple-value-call #'(lambda (&optional ,@varlist &rest ,ignore)          `(multiple-value-call #'(lambda (&optional ,@(mapcar #'list varlist) &rest ,ignore)
558                                    (declare (ignore ,ignore))                                    (declare (ignore ,ignore))
559                                    ,@body)                                    ,@body)
560             ,value-form))))             ,value-form))))

Legend:
Removed from v.1.98  
changed lines
  Added in v.1.98.2.2

  ViewVC Help
Powered by ViewVC 1.1.5