X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fmacros.lisp;h=59de9b077e173b698d7e3d54180fe93dbe8f9ffa;hb=eda83f00e869193cb69826be5fa1086b95d12ff7;hp=700f7e4f55f46ff8e1d85c845e9890be9bfb6361;hpb=f7e3e709f7c2207f1923375942f7fb1c092f92b0;p=sbcl.git diff --git a/src/compiler/macros.lisp b/src/compiler/macros.lisp index 700f7e4..59de9b0 100644 --- a/src/compiler/macros.lisp +++ b/src/compiler/macros.lisp @@ -40,7 +40,8 @@ ;;; kind to associate with NAME. (defmacro def-ir1-translator (name (lambda-list start-var next-var result-var) &body body) - (let ((fn-name (symbolicate "IR1-CONVERT-" name))) + (let ((fn-name (symbolicate "IR1-CONVERT-" name)) + (guard-name (symbolicate name "-GUARD"))) (with-unique-names (whole-var n-env) (multiple-value-bind (body decls doc) (parse-defmacro lambda-list whole-var body name "special form" @@ -56,24 +57,28 @@ ,@decls ,body (values)) - ,@(when doc - `((setf (fdocumentation ',name 'function) ,doc))) + #-sb-xc-host + ;; It's nice to do this for error checking in the target + ;; SBCL, but it's not nice to do this when we're running in + ;; the cross-compilation host Lisp, which owns the + ;; SYMBOL-FUNCTION of its COMMON-LISP symbols. These guard + ;; functions also provide the documentation for special forms. + (progn + (defun ,guard-name (&rest args) + ,@(when doc (list doc)) + (declare (ignore args)) + (error 'special-form-function :name ',name)) + (let ((fun #',guard-name)) + (setf (%simple-fun-arglist fun) ',lambda-list + (%simple-fun-name fun) ',name + (symbol-function ',name) fun) + (fmakunbound ',guard-name))) ;; FIXME: Evidently "there can only be one!" -- we overwrite any ;; other :IR1-CONVERT value. This deserves a warning, I think. (setf (info :function :ir1-convert ',name) #',fn-name) ;; FIXME: rename this to SPECIAL-OPERATOR, to update it to ;; the 1990s? (setf (info :function :kind ',name) :special-form) - ;; It's nice to do this for error checking in the target - ;; SBCL, but it's not nice to do this when we're running in - ;; the cross-compilation host Lisp, which owns the - ;; SYMBOL-FUNCTION of its COMMON-LISP symbols. - #-sb-xc-host - (let ((fun (lambda (&rest rest) - (declare (ignore rest)) - (error 'special-form-function :name ',name)))) - (setf (%simple-fun-arglist fun) ',lambda-list) - (setf (symbol-function ',name) fun)) ',name))))) ;;; (This is similar to DEF-IR1-TRANSLATOR, except that we pass if the @@ -206,8 +211,8 @@ (,get-setf-expansion-fun-name place env) (when (cdr stores) (error "multiple store variables for ~S" place)) - (let ((newval (gensym)) - (n-place (gensym)) + (let ((newval (sb!xc:gensym)) + (n-place (sb!xc:gensym)) (mask (compute-attribute-mask attributes ,translations-name))) (values `(,@temps ,n-place) `(,@values ,get) @@ -229,6 +234,12 @@ attribute-names 'get-setf-expansion))) +;;; Otherwise the source locations for DEFTRANSFORM, DEFKNOWN, &c +;;; would be off by one toplevel form as their source locations are +;;; determined before cross-compiling where the above PROGN is not +;;; seen. +#+sb-xc (progn) + ;;; And now for some gratuitous pseudo-abstraction... ;;; ;;; ATTRIBUTES-UNION @@ -398,10 +409,10 @@ (when (and eval-name defun-only) (error "can't specify both DEFUN-ONLY and EVAL-NAME")) (multiple-value-bind (body decls doc) (parse-body body-decls-doc) - (let ((n-args (gensym)) - (n-node (or node (gensym))) - (n-decls (gensym)) - (n-lambda (gensym)) + (let ((n-args (sb!xc:gensym)) + (n-node (or node (sb!xc:gensym))) + (n-decls (sb!xc:gensym)) + (n-lambda (sb!xc:gensym)) (decls-body `(,@decls ,@body))) (multiple-value-bind (parsed-form vars) (parse-deftransform lambda-list @@ -458,12 +469,16 @@ ;;; the function might have. (defmacro defknown (name arg-types result-type &optional (attributes '(any)) &body keys) + #-sb-xc-host + (when (member 'unsafe attributes) + (style-warn "Ignoring legacy attribute UNSAFE. Replaced by its inverse: DX-SAFE.") + (setf attributes (remove 'unsafe attributes))) (when (and (intersection attributes '(any call unwind)) (intersection attributes '(movable))) (error "function cannot have both good and bad attributes: ~S" attributes)) (when (member 'any attributes) - (setq attributes (union '(call unsafe unwind) attributes))) + (setq attributes (union '(call unwind) attributes))) (when (member 'flushable attributes) (pushnew 'unsafely-flushable attributes)) @@ -496,24 +511,31 @@ ;;; the rest of the optimizer function's lambda-list. LTN-ANNOTATE ;;; methods are passed an additional POLICY argument, and IR2-CONVERT ;;; methods are passed an additional IR2-BLOCK argument. -(defmacro defoptimizer (what (lambda-list &optional (n-node (gensym)) +(defmacro defoptimizer (what (lambda-list &optional (n-node (sb!xc:gensym)) &rest vars) &body body) - (let ((name (if (symbolp what) what - (symbolicate (first what) "-" (second what) "-OPTIMIZER")))) - - (let ((n-args (gensym))) - `(progn - (defun ,name (,n-node ,@vars) - (declare (ignorable ,@vars)) - (let ((,n-args (basic-combination-args ,n-node))) - ,(parse-deftransform lambda-list body n-args - `(return-from ,name nil)))) - ,@(when (consp what) - `((setf (,(let ((*package* (symbol-package 'sb!c::fun-info))) - (symbolicate "FUN-INFO-" (second what))) - (fun-info-or-lose ',(first what))) - #',name))))))) + (flet ((function-name (name) + (etypecase name + (symbol name) + ((cons (eql setf) (cons symbol null)) + (symbolicate (car name) "-" (cadr name)))))) + (let ((name (if (symbolp what) + what + (symbolicate (function-name (first what)) + "-" (second what) "-OPTIMIZER")))) + + (let ((n-args (gensym))) + `(progn + (defun ,name (,n-node ,@vars) + (declare (ignorable ,@vars)) + (let ((,n-args (basic-combination-args ,n-node))) + ,(parse-deftransform lambda-list body n-args + `(return-from ,name nil)))) + ,@(when (consp what) + `((setf (,(let ((*package* (symbol-package 'sb!c::fun-info))) + (symbolicate "FUN-INFO-" (second what))) + (fun-info-or-lose ',(first what))) + #',name)))))))) ;;;; IR groveling macros @@ -670,17 +692,25 @@ (aver-live-component *current-component*) (funcall fun))) +(defmacro with-source-paths (&body forms) + (with-unique-names (source-paths) + `(let* ((,source-paths (make-hash-table :test 'eq)) + (*source-paths* ,source-paths)) + (unwind-protect + (progn ,@forms) + (clrhash ,source-paths))))) + ;;; Bind the hashtables used for keeping track of global variables, ;;; functions, etc. Also establish condition handlers. (defmacro with-ir1-namespace (&body forms) `(let ((*free-vars* (make-hash-table :test 'eq)) (*free-funs* (make-hash-table :test 'equal)) - (*constants* (make-hash-table :test 'equal)) - (*source-paths* (make-hash-table :test 'eq))) - (handler-bind ((compiler-error #'compiler-error-handler) - (style-warning #'compiler-style-warning-handler) - (warning #'compiler-warning-handler)) - ,@forms))) + (*constants* (make-hash-table :test 'equal))) + (unwind-protect + (progn ,@forms) + (clrhash *free-funs*) + (clrhash *free-vars*) + (clrhash *constants*)))) ;;; Look up NAME in the lexical environment namespace designated by ;;; SLOT, returning the , or if no entry. The @@ -972,3 +1002,19 @@ specify bindings for printer control variables.") (nreverse (mapcar #'car *compiler-print-variable-alist*)) (nreverse (mapcar #'cdr *compiler-print-variable-alist*)) ,@forms))) + +;;; Like DESTRUCTURING-BIND, but generates a COMPILER-ERROR on failure +(defmacro compiler-destructuring-bind (lambda-list thing context + &body body) + (let ((whole-name (gensym "WHOLE"))) + (multiple-value-bind (body local-decls) + (parse-defmacro lambda-list whole-name body nil + context + :anonymousp t + :doc-string-allowed nil + :wrap-block nil + :error-fun 'compiler-error) + `(let ((,whole-name ,thing)) + (declare (type list ,whole-name)) + ,@local-decls + ,body))))