X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fmacros.lisp;h=59de9b077e173b698d7e3d54180fe93dbe8f9ffa;hb=eda83f00e869193cb69826be5fa1086b95d12ff7;hp=7ec86bdf5d0f2469cb2e52d2ab30f2da7cdf397d;hpb=dad557fe44b1c5e10ab5c09f86df77c5725263b7;p=sbcl.git diff --git a/src/compiler/macros.lisp b/src/compiler/macros.lisp index 7ec86bd..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 @@ -464,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)) @@ -505,21 +514,28 @@ (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 @@ -676,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 @@ -978,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))))