;;; If the desirability of the transformation depends on the current
;;; OPTIMIZE parameters, then the POLICY macro should be used to
;;; determine when to pass.
-(defmacro define-source-transform (name lambda-list &body body)
- (let ((fn-name
- (if (listp name)
- (collect ((pieces))
- (dolist (piece name)
- (pieces "-")
- (pieces piece))
- (apply #'symbolicate "SOURCE-TRANSFORM" (pieces)))
- (symbolicate "SOURCE-TRANSFORM-" name)))
- (n-form (gensym))
- (n-env (gensym)))
+(defmacro source-transform-lambda (lambda-list &body body)
+ (let ((n-form (gensym))
+ (n-env (gensym))
+ (name (gensym)))
(multiple-value-bind (body decls)
- (parse-defmacro lambda-list n-form body name "form"
+ (parse-defmacro lambda-list n-form body "source transform" "form"
:environment n-env
:error-fun `(lambda (&rest stuff)
(declare (ignore stuff))
- (return-from ,fn-name
+ (return-from ,name
(values nil t))))
- `(progn
- (defun ,fn-name (,n-form)
- (let ((,n-env *lexenv*))
- ,@decls
- ,body))
- (setf (info :function :source-transform ',name) #',fn-name)))))
+ `(lambda (,n-form &aux (,n-env *lexenv*))
+ ,@decls
+ (block ,name
+ ,body)))))
+(defmacro define-source-transform (name lambda-list &body body)
+ `(setf (info :function :source-transform ',name)
+ (source-transform-lambda ,lambda-list ,@body)))
\f
;;;; boolean attribute utilities
;;;;
(deftype attributes () 'fixnum)
-(eval-when (:compile-toplevel :load-toplevel :execute)
+(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
;;; Given a list of attribute names and an alist that translates them
;;; to masks, return the OR of the masks.
;;;
;;; NAME-attributes attribute-name*
;;; Return a set of the named attributes.
-#+sb-xc-host
-(progn
+#-sb-xc
+(progn
(def!macro !def-boolean-attribute (name &rest attribute-names)
(let ((translations-name (symbolicate "*" name "-ATTRIBUTE-TRANSLATIONS*"))
;;;; to parse the IR1 representation of a function call using a
;;;; standard function lambda-list.
-(eval-when (:compile-toplevel :load-toplevel :execute)
+(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
;;; Given a DEFTRANSFORM-style lambda-list, generate code that parses
;;; the arguments of a combination with respect to that lambda-list.
;;; keywords specify the initial values for various optimizers that
;;; the function might have.
(defmacro defknown (name arg-types result-type &optional (attributes '(any))
- &rest keys)
+ &rest keys)
(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)
- (setf attributes (union '(call unsafe unwind) attributes)))
+ (setq attributes (union '(call unsafe unwind) attributes)))
(when (member 'flushable attributes)
(pushnew 'unsafely-flushable attributes))
`(%defknown ',(if (and (consp name)
- (not (eq (car name) 'setf)))
+ (not (legal-fun-name-p name)))
name
(list name))
- '(function ,arg-types ,result-type)
+ '(sfunction ,arg-types ,result-type)
(ir1-attributes ,@attributes)
,@keys))
`(continuation-next ,cont-var)))
(,cont-var (node-cont ,node-var) (node-cont ,node-var)))
(())
+ (declare (type node ,node-var))
,@body
(when ,(if restart-p
`(eq ,node-var (block-last ,n-block))
(values (cdr ,n-res) t)
(values nil nil))))
-;;;
-(defmacro with-continuation-type-assertion ((cont ctype context) &body body)
- `(let ((*lexenv* (ir1ize-the-or-values ,ctype ,cont *lexenv* ,context)))
- ,@body))
+(defmacro with-component-last-block ((component block) &body body)
+ (with-unique-names (old-last-block)
+ (once-only ((component component)
+ (block block))
+ `(let ((,old-last-block (component-last-block ,component)))
+ (unwind-protect
+ (progn (setf (component-last-block ,component)
+ ,block)
+ ,@body)
+ (setf (component-last-block ,component)
+ ,old-last-block))))))
+
\f
;;;; the EVENT statistics/trace utility
;;; experimentation, not for ordinary use, so it should probably
;;; become conditional on SB-SHOW.
-(eval-when (:compile-toplevel :load-toplevel :execute)
+(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
(defstruct (event-info (:copier nil))
;; The name of this event.
new-value))
(defsetf event-level %set-event-level)
-;;; Define a new kind of event. Name is a symbol which names the event
-;;; and Description is a string which describes the event. Level
+;;; Define a new kind of event. NAME is a symbol which names the event
+;;; and DESCRIPTION is a string which describes the event. Level
;;; (default 0) is the level of significance associated with this
;;; event; it is used to determine whether to print a Note when the
;;; event happens.
(declaim (type unsigned-byte *event-note-threshold*))
(defvar *event-note-threshold* 1)
-;;; Note that the event with the specified Name has happened. Node is
+;;; Note that the event with the specified NAME has happened. NODE is
;;; evaluated to determine the node to which the event happened.
(defmacro event (name &optional node)
;; Increment the counter and do any action. Mumble about the event if
#!-sb-fluid (declaim (inline find-in position-in))
-;;; Find Element in a null-terminated List linked by the accessor
-;;; function Next. Key, Test and Test-Not are the same as for generic
+;;; Find ELEMENT in a null-terminated LIST linked by the accessor
+;;; function NEXT. KEY, TEST and TEST-NOT are the same as for generic
;;; sequence functions.
(defun find-in (next
element
(when (funcall test (funcall key current) element)
(return current)))))
-;;; Return the position of Element (or NIL if absent) in a
-;;; null-terminated List linked by the accessor function Next. Key,
-;;; Test and Test-Not are the same as for generic sequence functions.
+;;; Return the position of ELEMENT (or NIL if absent) in a
+;;; null-terminated LIST linked by the accessor function NEXT. KEY,
+;;; TEST and TEST-NOT are the same as for generic sequence functions.
(defun position-in (next
element
list
projects / sbcl.git / blobdiff