various refactorings and tidying..
..redid the hairy remove-ourselves-from-tail-set mess in
MERGE-LETS as a separate function,
DEPART-FROM-TAIL-SET
..split diagnostic/reporting stuff (starting around
(DECLAIM (SPECIAL *CURRENT-PATH*)) out of ir1util.lisp
into ir1report.lisp
..moved UNIX-HOST stuff around in an effort to get rid
of compiler not-defined-(yet) warnings
..split target-pathname.lisp out of pathname.lisp to support
this
..moved target-only HOST stuff from pathname.lisp (which is
built both on host and target) to filesys.lisp (which
is flagged as :NOT-HOST in stems-and-flags.lisp-expr)
..Since there's no longer any numbers.lisp or
host-numbers.lisp to contrast to, target-numbers.lisp
really ought to be called numbers.lisp.
..split ir1-translators.lisp out of ir1tran.lisp (as per FIXME)
..moved IDENTITY, COMPLEMENT, and CONSTANTLY out of list.lisp
into funutils.lisp
(t
(lose)))))
(apply #'concatenate 'simple-string (strings)))))
-
-(/show0 "filesys.lisp 471")
-
-(def!struct (unix-host
- (:make-load-form-fun make-unix-host-load-form)
- (:include host
- (parse #'parse-unix-namestring)
- (unparse #'unparse-unix-namestring)
- (unparse-host #'unparse-unix-host)
- (unparse-directory #'unparse-unix-directory)
- (unparse-file #'unparse-unix-file)
- (unparse-enough #'unparse-unix-enough)
- (customary-case :lower))))
-
-(/show0 "filesys.lisp 486")
-
-(defvar *unix-host* (make-unix-host))
-
-(/show0 "filesys.lisp 488")
-
-(defun make-unix-host-load-form (host)
- (declare (ignore host))
- '*unix-host*)
\f
;;;; wildcard matching stuff
--- /dev/null
+;;;; miscellaneous operations on functions, returning functions, or
+;;;; primarily useful for functional programming
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!IMPL")
+
+(defun identity (thing)
+ #!+sb-doc
+ "This function simply returns what was passed to it."
+ thing)
+
+(defun complement (function)
+ #!+sb-doc
+ "Return a new function that returns T whenever FUNCTION returns NIL and
+ NIL whenever FUNCTION returns non-NIL."
+ (lambda (&optional (arg0 nil arg0-p) (arg1 nil arg1-p) (arg2 nil arg2-p)
+ &rest more-args)
+ (not (cond (more-args (apply function arg0 arg1 arg2 more-args))
+ (arg2-p (funcall function arg0 arg1 arg2))
+ (arg1-p (funcall function arg0 arg1))
+ (arg0-p (funcall function arg0))
+ (t (funcall function))))))
+
+(defun constantly (value)
+ #!+sb-doc
+ "Return a function that always returns VALUE."
+ (lambda ()
+ ;; KLUDGE: This declaration is a hack to make the closure ignore
+ ;; all its arguments without consing a &REST list or anything.
+ ;; Perhaps once DYNAMIC-EXTENT is implemented we won't need to
+ ;; screw around with this kind of thing. -- WHN 2001-04-06
+ (declare (optimize (speed 3) (safety 0)))
+ value))
assoc-if assoc-if-not rassoc rassoc-if rassoc-if-not subst subst-if
subst-if-not nsubst nsubst-if nsubst-if-not sublis nsublis))
-;;; These functions perform basic list operations:
-(defun car (list) #!+sb-doc "Returns the 1st object in a list." (car list))
+;;; These functions perform basic list operations.
+(defun car (list) #!+sb-doc "Return the 1st object in a list." (car list))
(defun cdr (list)
- #!+sb-doc "Returns all but the first object in a list."
+ #!+sb-doc "Return all but the first object in a list."
(cdr list))
-(defun cadr (list) #!+sb-doc "Returns the 2nd object in a list." (cadr list))
-(defun cdar (list) #!+sb-doc "Returns the cdr of the 1st sublist." (cdar list))
-(defun caar (list) #!+sb-doc "Returns the car of the 1st sublist." (caar list))
+(defun cadr (list) #!+sb-doc "Return the 2nd object in a list." (cadr list))
+(defun cdar (list) #!+sb-doc "Return the cdr of the 1st sublist." (cdar list))
+(defun caar (list) #!+sb-doc "Return the car of the 1st sublist." (caar list))
(defun cddr (list)
- #!+sb-doc "Returns all but the 1st two objects of a list."
+ #!+sb-doc "Return all but the 1st two objects of a list."
(cddr list))
(defun caddr (list)
- #!+sb-doc "Returns the 1st object in the cddr of a list."
+ #!+sb-doc "Return the 1st object in the cddr of a list."
(caddr list))
(defun caadr (list)
- #!+sb-doc "Returns the 1st object in the cadr of a list."
+ #!+sb-doc "Return the 1st object in the cadr of a list."
(caadr list))
(defun caaar (list)
- #!+sb-doc "Returns the 1st object in the caar of a list."
+ #!+sb-doc "Return the 1st object in the caar of a list."
(caaar list))
(defun cdaar (list)
- #!+sb-doc "Returns the cdr of the caar of a list."
+ #!+sb-doc "Return the cdr of the caar of a list."
(cdaar list))
(defun cddar (list)
- #!+sb-doc "Returns the cdr of the cdar of a list."
+ #!+sb-doc "Return the cdr of the cdar of a list."
(cddar list))
(defun cdddr (list)
- #!+sb-doc "Returns the cdr of the cddr of a list."
+ #!+sb-doc "Return the cdr of the cddr of a list."
(cdddr list))
(defun cadar (list)
- #!+sb-doc "Returns the car of the cdar of a list."
+ #!+sb-doc "Return the car of the cdar of a list."
(cadar list))
(defun cdadr (list)
- #!+sb-doc "Returns the cdr of the cadr of a list."
+ #!+sb-doc "Return the cdr of the cadr of a list."
(cdadr list))
(defun caaaar (list)
- #!+sb-doc "Returns the car of the caaar of a list."
+ #!+sb-doc "Return the car of the caaar of a list."
(caaaar list))
(defun caaadr (list)
- #!+sb-doc "Returns the car of the caadr of a list."
+ #!+sb-doc "Return the car of the caadr of a list."
(caaadr list))
(defun caaddr (list)
- #!+sb-doc "Returns the car of the caddr of a list."
+ #!+sb-doc "Return the car of the caddr of a list."
(caaddr list))
(defun cadddr (list)
- #!+sb-doc "Returns the car of the cdddr of a list."
+ #!+sb-doc "Return the car of the cdddr of a list."
(cadddr list))
(defun cddddr (list)
- #!+sb-doc "Returns the cdr of the cdddr of a list."
+ #!+sb-doc "Return the cdr of the cdddr of a list."
(cddddr list))
(defun cdaaar (list)
- #!+sb-doc "Returns the cdr of the caaar of a list."
+ #!+sb-doc "Return the cdr of the caaar of a list."
(cdaaar list))
(defun cddaar (list)
- #!+sb-doc "Returns the cdr of the cdaar of a list."
+ #!+sb-doc "Return the cdr of the cdaar of a list."
(cddaar list))
(defun cdddar (list)
- #!+sb-doc "Returns the cdr of the cddar of a list."
+ #!+sb-doc "Return the cdr of the cddar of a list."
(cdddar list))
(defun caadar (list)
- #!+sb-doc "Returns the car of the cadar of a list."
+ #!+sb-doc "Return the car of the cadar of a list."
(caadar list))
(defun cadaar (list)
- #!+sb-doc "Returns the car of the cdaar of a list."
+ #!+sb-doc "Return the car of the cdaar of a list."
(cadaar list))
(defun cadadr (list)
- #!+sb-doc "Returns the car of the cdadr of a list."
+ #!+sb-doc "Return the car of the cdadr of a list."
(cadadr list))
(defun caddar (list)
- #!+sb-doc "Returns the car of the cddar of a list."
+ #!+sb-doc "Return the car of the cddar of a list."
(caddar list))
(defun cdaadr (list)
- #!+sb-doc "Returns the cdr of the caadr of a list."
+ #!+sb-doc "Return the cdr of the caadr of a list."
(cdaadr list))
(defun cdadar (list)
- #!+sb-doc "Returns the cdr of the cadar of a list."
+ #!+sb-doc "Return the cdr of the cadar of a list."
(cdadar list))
(defun cdaddr (list)
- #!+sb-doc "Returns the cdr of the caddr of a list."
+ #!+sb-doc "Return the cdr of the caddr of a list."
(cdaddr list))
(defun cddadr (list)
- #!+sb-doc "Returns the cdr of the cdadr of a list."
+ #!+sb-doc "Return the cdr of the cdadr of a list."
(cddadr list))
(defun cons (se1 se2)
- #!+sb-doc "Returns a list with se1 as the car and se2 as the cdr."
+ #!+sb-doc "Return a list with SE1 as the CAR and SE2 as the CDR."
(cons se1 se2))
\f
(declaim (maybe-inline tree-equal-test tree-equal-test-not))
;;;; :KEY arg optimization to save funcall of IDENTITY
;;; APPLY-KEY saves us a function call sometimes.
-;;; This is not wrapped in an (EVAL-WHEN (COMPILE EVAL) ..)
-;;; because this is used in seq.lisp and sort.lisp.
+;;; This isn't wrapped in an (EVAL-WHEN (COMPILE EVAL) ..)
+;;; because it's used in seq.lisp and sort.lisp.
(defmacro apply-key (key element)
`(if ,key
(funcall ,key ,element)
,element))
-
-(defun identity (thing)
- #!+sb-doc
- "This function simply returns what was passed to it."
- thing)
-
-(defun complement (function)
- #!+sb-doc
- "Return a new function that returns T whenever FUNCTION returns NIL and
- NIL whenever FUNCTION returns non-NIL."
- (lambda (&optional (arg0 nil arg0-p) (arg1 nil arg1-p) (arg2 nil arg2-p)
- &rest more-args)
- (not (cond (more-args (apply function arg0 arg1 arg2 more-args))
- (arg2-p (funcall function arg0 arg1 arg2))
- (arg1-p (funcall function arg0 arg1))
- (arg0-p (funcall function arg0))
- (t (funcall function))))))
-
-(defun constantly (value)
- #!+sb-doc
- "Return a function that always returns VALUE."
- (lambda ()
- ;; KLUDGE: This declaration is a hack to make the closure ignore
- ;; all its arguments without consing a &REST list or anything.
- ;; Perhaps once DYNAMIC-EXTENT is implemented we won't need to
- ;; screw around with this kind of thing. -- WHN 2001-04-06
- (declare (optimize (speed 3) (safety 0)))
- value))
\f
;;;; macros for (&KEY (KEY #'IDENTITY) (TEST #'EQL TESTP) (TEST-NOT NIL NOTP))
--- /dev/null
+;;;; This file contains the definitions of most number functions.
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!KERNEL")
+\f
+;;;; the NUMBER-DISPATCH macro
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+
+;;; Grovel an individual case to NUMBER-DISPATCH, augmenting RESULT
+;;; with the type dispatches and bodies. Result is a tree built of
+;;; alists representing the dispatching off each arg (in order). The
+;;; leaf is the body to be executed in that case.
+(defun parse-number-dispatch (vars result types var-types body)
+ (cond ((null vars)
+ (unless (null types) (error "More types than vars."))
+ (when (cdr result)
+ (error "Duplicate case: ~S." body))
+ (setf (cdr result)
+ (sublis var-types body :test #'equal)))
+ ((null types)
+ (error "More vars than types."))
+ (t
+ (flet ((frob (var type)
+ (parse-number-dispatch
+ (rest vars)
+ (or (assoc type (cdr result) :test #'equal)
+ (car (setf (cdr result)
+ (acons type nil (cdr result)))))
+ (rest types)
+ (acons `(dispatch-type ,var) type var-types)
+ body)))
+ (let ((type (first types))
+ (var (first vars)))
+ (if (and (consp type) (eq (first type) 'foreach))
+ (dolist (type (rest type))
+ (frob var type))
+ (frob var type)))))))
+
+;;; our guess for the preferred order in which to do type tests
+;;; (cheaper and/or more probable first.)
+(defparameter *type-test-ordering*
+ '(fixnum single-float double-float integer #!+long-float long-float bignum
+ complex ratio))
+
+;;; Should TYPE1 be tested before TYPE2?
+(defun type-test-order (type1 type2)
+ (let ((o1 (position type1 *type-test-ordering*))
+ (o2 (position type2 *type-test-ordering*)))
+ (cond ((not o1) nil)
+ ((not o2) t)
+ (t
+ (< o1 o2)))))
+
+;;; Return an ETYPECASE form that does the type dispatch, ordering the
+;;; cases for efficiency.
+(defun generate-number-dispatch (vars error-tags cases)
+ (if vars
+ (let ((var (first vars))
+ (cases (sort cases #'type-test-order :key #'car)))
+ `((typecase ,var
+ ,@(mapcar #'(lambda (case)
+ `(,(first case)
+ ,@(generate-number-dispatch (rest vars)
+ (rest error-tags)
+ (cdr case))))
+ cases)
+ (t (go ,(first error-tags))))))
+ cases))
+
+) ; EVAL-WHEN
+
+;;; This is a vaguely case-like macro that does number cross-product
+;;; dispatches. The Vars are the variables we are dispatching off of.
+;;; The Type paired with each Var is used in the error message when no
+;;; case matches. Each case specifies a Type for each var, and is
+;;; executed when that signature holds. A type may be a list
+;;; (FOREACH Each-Type*), causing that case to be repeatedly
+;;; instantiated for every Each-Type. In the body of each case, any
+;;; list of the form (DISPATCH-TYPE Var-Name) is substituted with the
+;;; type of that var in that instance of the case.
+;;;
+;;; As an alternate to a case spec, there may be a form whose CAR is a
+;;; symbol. In this case, we apply the CAR of the form to the CDR and
+;;; treat the result of the call as a list of cases. This process is
+;;; not applied recursively.
+(defmacro number-dispatch (var-specs &body cases)
+ (let ((res (list nil))
+ (vars (mapcar #'car var-specs))
+ (block (gensym)))
+ (dolist (case cases)
+ (if (symbolp (first case))
+ (let ((cases (apply (symbol-function (first case)) (rest case))))
+ (dolist (case cases)
+ (parse-number-dispatch vars res (first case) nil (rest case))))
+ (parse-number-dispatch vars res (first case) nil (rest case))))
+
+ (collect ((errors)
+ (error-tags))
+ (dolist (spec var-specs)
+ (let ((var (first spec))
+ (type (second spec))
+ (tag (gensym)))
+ (error-tags tag)
+ (errors tag)
+ (errors `(return-from
+ ,block
+ (error 'simple-type-error :datum ,var
+ :expected-type ',type
+ :format-control
+ "~@<Argument ~A is not a ~S: ~2I~_~S~:>"
+ :format-arguments
+ (list ',var ',type ,var))))))
+
+ `(block ,block
+ (tagbody
+ (return-from ,block
+ ,@(generate-number-dispatch vars (error-tags)
+ (cdr res)))
+ ,@(errors))))))
+\f
+;;;; binary operation dispatching utilities
+
+(eval-when (:compile-toplevel :execute)
+
+;;; Return NUMBER-DISPATCH forms for rational X float.
+(defun float-contagion (op x y &optional (rat-types '(fixnum bignum ratio)))
+ `(((single-float single-float) (,op ,x ,y))
+ (((foreach ,@rat-types)
+ (foreach single-float double-float #!+long-float long-float))
+ (,op (coerce ,x '(dispatch-type ,y)) ,y))
+ (((foreach single-float double-float #!+long-float long-float)
+ (foreach ,@rat-types))
+ (,op ,x (coerce ,y '(dispatch-type ,x))))
+ #!+long-float
+ (((foreach single-float double-float long-float) long-float)
+ (,op (coerce ,x 'long-float) ,y))
+ #!+long-float
+ ((long-float (foreach single-float double-float))
+ (,op ,x (coerce ,y 'long-float)))
+ (((foreach single-float double-float) double-float)
+ (,op (coerce ,x 'double-float) ,y))
+ ((double-float single-float)
+ (,op ,x (coerce ,y 'double-float)))))
+
+;;; Return NUMBER-DISPATCH forms for bignum X fixnum.
+(defun bignum-cross-fixnum (fix-op big-op)
+ `(((fixnum fixnum) (,fix-op x y))
+ ((fixnum bignum)
+ (,big-op (make-small-bignum x) y))
+ ((bignum fixnum)
+ (,big-op x (make-small-bignum y)))
+ ((bignum bignum)
+ (,big-op x y))))
+
+) ; EVAL-WHEN
+\f
+;;;; canonicalization utilities
+
+;;; If IMAGPART is 0, return REALPART, otherwise make a complex. This is
+;;; used when we know that REALPART and IMAGPART are the same type, but
+;;; rational canonicalization might still need to be done.
+#!-sb-fluid (declaim (inline canonical-complex))
+(defun canonical-complex (realpart imagpart)
+ (if (eql imagpart 0)
+ realpart
+ (cond #!+long-float
+ ((and (typep realpart 'long-float)
+ (typep imagpart 'long-float))
+ (truly-the (complex long-float) (complex realpart imagpart)))
+ ((and (typep realpart 'double-float)
+ (typep imagpart 'double-float))
+ (truly-the (complex double-float) (complex realpart imagpart)))
+ ((and (typep realpart 'single-float)
+ (typep imagpart 'single-float))
+ (truly-the (complex single-float) (complex realpart imagpart)))
+ (t
+ (%make-complex realpart imagpart)))))
+
+;;; Given a numerator and denominator with the GCD already divided
+;;; out, make a canonical rational. We make the denominator positive,
+;;; and check whether it is 1.
+#!-sb-fluid (declaim (inline build-ratio))
+(defun build-ratio (num den)
+ (multiple-value-bind (num den)
+ (if (minusp den)
+ (values (- num) (- den))
+ (values num den))
+ (if (eql den 1)
+ num
+ (%make-ratio num den))))
+
+;;; Truncate X and Y, but bum the case where Y is 1.
+#!-sb-fluid (declaim (inline maybe-truncate))
+(defun maybe-truncate (x y)
+ (if (eql y 1)
+ x
+ (truncate x y)))
+\f
+;;;; COMPLEXes
+
+(defun upgraded-complex-part-type (spec)
+ #!+sb-doc
+ "Returns the element type of the most specialized COMPLEX number type that
+ can hold parts of type SPEC."
+ (cond ((unknown-type-p (specifier-type spec))
+ (error "undefined type: ~S" spec))
+ ((subtypep spec 'single-float)
+ 'single-float)
+ ((subtypep spec 'double-float)
+ 'double-float)
+ #!+long-float
+ ((subtypep spec 'long-float)
+ 'long-float)
+ ((subtypep spec 'rational)
+ 'rational)
+ (t
+ 'real)))
+
+(defun complex (realpart &optional (imagpart 0))
+ #!+sb-doc
+ "Builds a complex number from the specified components."
+ (flet ((%%make-complex (realpart imagpart)
+ (cond #!+long-float
+ ((and (typep realpart 'long-float)
+ (typep imagpart 'long-float))
+ (truly-the (complex long-float)
+ (complex realpart imagpart)))
+ ((and (typep realpart 'double-float)
+ (typep imagpart 'double-float))
+ (truly-the (complex double-float)
+ (complex realpart imagpart)))
+ ((and (typep realpart 'single-float)
+ (typep imagpart 'single-float))
+ (truly-the (complex single-float)
+ (complex realpart imagpart)))
+ (t
+ (%make-complex realpart imagpart)))))
+ (number-dispatch ((realpart real) (imagpart real))
+ ((rational rational)
+ (canonical-complex realpart imagpart))
+ (float-contagion %%make-complex realpart imagpart (rational)))))
+
+(defun realpart (number)
+ #!+sb-doc
+ "Extracts the real part of a number."
+ (typecase number
+ #!+long-float
+ ((complex long-float)
+ (truly-the long-float (realpart number)))
+ ((complex double-float)
+ (truly-the double-float (realpart number)))
+ ((complex single-float)
+ (truly-the single-float (realpart number)))
+ ((complex rational)
+ (sb!kernel:%realpart number))
+ (t
+ number)))
+
+(defun imagpart (number)
+ #!+sb-doc
+ "Extracts the imaginary part of a number."
+ (typecase number
+ #!+long-float
+ ((complex long-float)
+ (truly-the long-float (imagpart number)))
+ ((complex double-float)
+ (truly-the double-float (imagpart number)))
+ ((complex single-float)
+ (truly-the single-float (imagpart number)))
+ ((complex rational)
+ (sb!kernel:%imagpart number))
+ (float
+ (float 0 number))
+ (t
+ 0)))
+
+(defun conjugate (number)
+ #!+sb-doc
+ "Returns the complex conjugate of NUMBER. For non-complex numbers, this is
+ an identity."
+ (if (complexp number)
+ (complex (realpart number) (- (imagpart number)))
+ number))
+
+(defun signum (number)
+ #!+sb-doc
+ "If NUMBER is zero, return NUMBER, else return (/ NUMBER (ABS NUMBER))."
+ (if (zerop number)
+ number
+ (if (rationalp number)
+ (if (plusp number) 1 -1)
+ (/ number (abs number)))))
+\f
+;;;; ratios
+
+(defun numerator (number)
+ #!+sb-doc
+ "Return the numerator of NUMBER, which must be rational."
+ (numerator number))
+
+(defun denominator (number)
+ #!+sb-doc
+ "Return the denominator of NUMBER, which must be rational."
+ (denominator number))
+\f
+;;;; arithmetic operations
+
+(macrolet ((define-arith (op init doc)
+ #!-sb-doc (declare (ignore doc))
+ `(defun ,op (&rest args)
+ #!+sb-doc ,doc
+ (if (null args) ,init
+ (do ((args (cdr args) (cdr args))
+ (res (car args) (,op res (car args))))
+ ((null args) res))))))
+ (define-arith + 0
+ "Returns the sum of its arguments. With no args, returns 0.")
+ (define-arith * 1
+ "Returns the product of its arguments. With no args, returns 1."))
+
+(defun - (number &rest more-numbers)
+ #!+sb-doc
+ "Subtracts the second and all subsequent arguments from the first.
+ With one arg, negates it."
+ (if more-numbers
+ (do ((nlist more-numbers (cdr nlist))
+ (result number))
+ ((atom nlist) result)
+ (declare (list nlist))
+ (setq result (- result (car nlist))))
+ (- number)))
+
+(defun / (number &rest more-numbers)
+ #!+sb-doc
+ "Divide the first argument by each of the following arguments, in turn.
+ With one argument, return reciprocal."
+ (if more-numbers
+ (do ((nlist more-numbers (cdr nlist))
+ (result number))
+ ((atom nlist) result)
+ (declare (list nlist))
+ (setq result (/ result (car nlist))))
+ (/ number)))
+
+(defun 1+ (number)
+ #!+sb-doc
+ "Returns NUMBER + 1."
+ (1+ number))
+
+(defun 1- (number)
+ #!+sb-doc
+ "Returns NUMBER - 1."
+ (1- number))
+
+(eval-when (:compile-toplevel)
+
+(sb!xc:defmacro two-arg-+/- (name op big-op)
+ `(defun ,name (x y)
+ (number-dispatch ((x number) (y number))
+ (bignum-cross-fixnum ,op ,big-op)
+ (float-contagion ,op x y)
+
+ ((complex complex)
+ (canonical-complex (,op (realpart x) (realpart y))
+ (,op (imagpart x) (imagpart y))))
+ (((foreach bignum fixnum ratio single-float double-float
+ #!+long-float long-float) complex)
+ (complex (,op x (realpart y)) (,op (imagpart y))))
+ ((complex (or rational float))
+ (complex (,op (realpart x) y) (imagpart x)))
+
+ (((foreach fixnum bignum) ratio)
+ (let* ((dy (denominator y))
+ (n (,op (* x dy) (numerator y))))
+ (%make-ratio n dy)))
+ ((ratio integer)
+ (let* ((dx (denominator x))
+ (n (,op (numerator x) (* y dx))))
+ (%make-ratio n dx)))
+ ((ratio ratio)
+ (let* ((nx (numerator x))
+ (dx (denominator x))
+ (ny (numerator y))
+ (dy (denominator y))
+ (g1 (gcd dx dy)))
+ (if (eql g1 1)
+ (%make-ratio (,op (* nx dy) (* dx ny)) (* dx dy))
+ (let* ((t1 (,op (* nx (truncate dy g1)) (* (truncate dx g1) ny)))
+ (g2 (gcd t1 g1))
+ (t2 (truncate dx g1)))
+ (cond ((eql t1 0) 0)
+ ((eql g2 1)
+ (%make-ratio t1 (* t2 dy)))
+ (T (let* ((nn (truncate t1 g2))
+ (t3 (truncate dy g2))
+ (nd (if (eql t2 1) t3 (* t2 t3))))
+ (if (eql nd 1) nn (%make-ratio nn nd))))))))))))
+
+); Eval-When (Compile)
+
+(two-arg-+/- two-arg-+ + add-bignums)
+(two-arg-+/- two-arg-- - subtract-bignum)
+
+(defun two-arg-* (x y)
+ (flet ((integer*ratio (x y)
+ (if (eql x 0) 0
+ (let* ((ny (numerator y))
+ (dy (denominator y))
+ (gcd (gcd x dy)))
+ (if (eql gcd 1)
+ (%make-ratio (* x ny) dy)
+ (let ((nn (* (truncate x gcd) ny))
+ (nd (truncate dy gcd)))
+ (if (eql nd 1)
+ nn
+ (%make-ratio nn nd)))))))
+ (complex*real (x y)
+ (canonical-complex (* (realpart x) y) (* (imagpart x) y))))
+ (number-dispatch ((x number) (y number))
+ (float-contagion * x y)
+
+ ((fixnum fixnum) (multiply-fixnums x y))
+ ((bignum fixnum) (multiply-bignum-and-fixnum x y))
+ ((fixnum bignum) (multiply-bignum-and-fixnum y x))
+ ((bignum bignum) (multiply-bignums x y))
+
+ ((complex complex)
+ (let* ((rx (realpart x))
+ (ix (imagpart x))
+ (ry (realpart y))
+ (iy (imagpart y)))
+ (canonical-complex (- (* rx ry) (* ix iy)) (+ (* rx iy) (* ix ry)))))
+ (((foreach bignum fixnum ratio single-float double-float
+ #!+long-float long-float)
+ complex)
+ (complex*real y x))
+ ((complex (or rational float))
+ (complex*real x y))
+
+ (((foreach bignum fixnum) ratio) (integer*ratio x y))
+ ((ratio integer) (integer*ratio y x))
+ ((ratio ratio)
+ (let* ((nx (numerator x))
+ (dx (denominator x))
+ (ny (numerator y))
+ (dy (denominator y))
+ (g1 (gcd nx dy))
+ (g2 (gcd dx ny)))
+ (build-ratio (* (maybe-truncate nx g1)
+ (maybe-truncate ny g2))
+ (* (maybe-truncate dx g2)
+ (maybe-truncate dy g1))))))))
+
+;;; Divide two integers, producing a canonical rational. If a fixnum,
+;;; we see whether they divide evenly before trying the GCD. In the
+;;; bignum case, we don't bother, since bignum division is expensive,
+;;; and the test is not very likely to succeed.
+(defun integer-/-integer (x y)
+ (if (and (typep x 'fixnum) (typep y 'fixnum))
+ (multiple-value-bind (quo rem) (truncate x y)
+ (if (zerop rem)
+ quo
+ (let ((gcd (gcd x y)))
+ (declare (fixnum gcd))
+ (if (eql gcd 1)
+ (build-ratio x y)
+ (build-ratio (truncate x gcd) (truncate y gcd))))))
+ (let ((gcd (gcd x y)))
+ (if (eql gcd 1)
+ (build-ratio x y)
+ (build-ratio (truncate x gcd) (truncate y gcd))))))
+
+(defun two-arg-/ (x y)
+ (number-dispatch ((x number) (y number))
+ (float-contagion / x y (ratio integer))
+
+ ((complex complex)
+ (let* ((rx (realpart x))
+ (ix (imagpart x))
+ (ry (realpart y))
+ (iy (imagpart y)))
+ (if (> (abs ry) (abs iy))
+ (let* ((r (/ iy ry))
+ (dn (* ry (+ 1 (* r r)))))
+ (canonical-complex (/ (+ rx (* ix r)) dn)
+ (/ (- ix (* rx r)) dn)))
+ (let* ((r (/ ry iy))
+ (dn (* iy (+ 1 (* r r)))))
+ (canonical-complex (/ (+ (* rx r) ix) dn)
+ (/ (- (* ix r) rx) dn))))))
+ (((foreach integer ratio single-float double-float) complex)
+ (let* ((ry (realpart y))
+ (iy (imagpart y)))
+ (if (> (abs ry) (abs iy))
+ (let* ((r (/ iy ry))
+ (dn (* ry (+ 1 (* r r)))))
+ (canonical-complex (/ x dn)
+ (/ (- (* x r)) dn)))
+ (let* ((r (/ ry iy))
+ (dn (* iy (+ 1 (* r r)))))
+ (canonical-complex (/ (* x r) dn)
+ (/ (- x) dn))))))
+ ((complex (or rational float))
+ (canonical-complex (/ (realpart x) y)
+ (/ (imagpart x) y)))
+
+ ((ratio ratio)
+ (let* ((nx (numerator x))
+ (dx (denominator x))
+ (ny (numerator y))
+ (dy (denominator y))
+ (g1 (gcd nx ny))
+ (g2 (gcd dx dy)))
+ (build-ratio (* (maybe-truncate nx g1) (maybe-truncate dy g2))
+ (* (maybe-truncate dx g2) (maybe-truncate ny g1)))))
+
+ ((integer integer)
+ (integer-/-integer x y))
+
+ ((integer ratio)
+ (if (zerop x)
+ 0
+ (let* ((ny (numerator y))
+ (dy (denominator y))
+ (gcd (gcd x ny)))
+ (build-ratio (* (maybe-truncate x gcd) dy)
+ (maybe-truncate ny gcd)))))
+
+ ((ratio integer)
+ (let* ((nx (numerator x))
+ (gcd (gcd nx y)))
+ (build-ratio (maybe-truncate nx gcd)
+ (* (maybe-truncate y gcd) (denominator x)))))))
+
+(defun %negate (n)
+ (number-dispatch ((n number))
+ (((foreach fixnum single-float double-float #!+long-float long-float))
+ (%negate n))
+ ((bignum)
+ (negate-bignum n))
+ ((ratio)
+ (%make-ratio (- (numerator n)) (denominator n)))
+ ((complex)
+ (complex (- (realpart n)) (- (imagpart n))))))
+\f
+;;;; TRUNCATE and friends
+
+(defun truncate (number &optional (divisor 1))
+ #!+sb-doc
+ "Returns number (or number/divisor) as an integer, rounded toward 0.
+ The second returned value is the remainder."
+ (macrolet ((truncate-float (rtype)
+ `(let* ((float-div (coerce divisor ',rtype))
+ (res (%unary-truncate (/ number float-div))))
+ (values res
+ (- number
+ (* (coerce res ',rtype) float-div))))))
+ (number-dispatch ((number real) (divisor real))
+ ((fixnum fixnum) (truncate number divisor))
+ (((foreach fixnum bignum) ratio)
+ (let ((q (truncate (* number (denominator divisor))
+ (numerator divisor))))
+ (values q (- number (* q divisor)))))
+ ((fixnum bignum)
+ (values 0 number))
+ ((ratio (or float rational))
+ (let ((q (truncate (numerator number)
+ (* (denominator number) divisor))))
+ (values q (- number (* q divisor)))))
+ ((bignum fixnum)
+ (bignum-truncate number (make-small-bignum divisor)))
+ ((bignum bignum)
+ (bignum-truncate number divisor))
+
+ (((foreach single-float double-float #!+long-float long-float)
+ (or rational single-float))
+ (if (eql divisor 1)
+ (let ((res (%unary-truncate number)))
+ (values res (- number (coerce res '(dispatch-type number)))))
+ (truncate-float (dispatch-type number))))
+ #!+long-float
+ ((long-float (or single-float double-float long-float))
+ (truncate-float long-float))
+ #!+long-float
+ (((foreach double-float single-float) long-float)
+ (truncate-float long-float))
+ ((double-float (or single-float double-float))
+ (truncate-float double-float))
+ ((single-float double-float)
+ (truncate-float double-float))
+ (((foreach fixnum bignum ratio)
+ (foreach single-float double-float #!+long-float long-float))
+ (truncate-float (dispatch-type divisor))))))
+
+;;; Declare these guys inline to let them get optimized a little.
+;;; ROUND and FROUND are not declared inline since they seem too
+;;; obscure and too big to inline-expand by default. Also, this gives
+;;; the compiler a chance to pick off the unary float case. Similarly,
+;;; CEILING and FLOOR are only maybe-inline for now, so that the
+;;; power-of-2 CEILING and FLOOR transforms get a chance.
+#!-sb-fluid (declaim (inline rem mod fceiling ffloor ftruncate))
+(declaim (maybe-inline ceiling floor))
+
+(defun floor (number &optional (divisor 1))
+ #!+sb-doc
+ "Returns the greatest integer not greater than number, or number/divisor.
+ The second returned value is (mod number divisor)."
+ ;; If the numbers do not divide exactly and the result of
+ ;; (/ NUMBER DIVISOR) would be negative then decrement the quotient
+ ;; and augment the remainder by the divisor.
+ (multiple-value-bind (tru rem) (truncate number divisor)
+ (if (and (not (zerop rem))
+ (if (minusp divisor)
+ (plusp number)
+ (minusp number)))
+ (values (1- tru) (+ rem divisor))
+ (values tru rem))))
+
+(defun ceiling (number &optional (divisor 1))
+ #!+sb-doc
+ "Returns the smallest integer not less than number, or number/divisor.
+ The second returned value is the remainder."
+ ;; If the numbers do not divide exactly and the result of
+ ;; (/ NUMBER DIVISOR) would be positive then increment the quotient
+ ;; and decrement the remainder by the divisor.
+ (multiple-value-bind (tru rem) (truncate number divisor)
+ (if (and (not (zerop rem))
+ (if (minusp divisor)
+ (minusp number)
+ (plusp number)))
+ (values (+ tru 1) (- rem divisor))
+ (values tru rem))))
+
+(defun round (number &optional (divisor 1))
+ #!+sb-doc
+ "Rounds number (or number/divisor) to nearest integer.
+ The second returned value is the remainder."
+ (if (eql divisor 1)
+ (round number)
+ (multiple-value-bind (tru rem) (truncate number divisor)
+ (let ((thresh (/ (abs divisor) 2)))
+ (cond ((or (> rem thresh)
+ (and (= rem thresh) (oddp tru)))
+ (if (minusp divisor)
+ (values (- tru 1) (+ rem divisor))
+ (values (+ tru 1) (- rem divisor))))
+ ((let ((-thresh (- thresh)))
+ (or (< rem -thresh)
+ (and (= rem -thresh) (oddp tru))))
+ (if (minusp divisor)
+ (values (+ tru 1) (- rem divisor))
+ (values (- tru 1) (+ rem divisor))))
+ (t (values tru rem)))))))
+
+(defun rem (number divisor)
+ #!+sb-doc
+ "Returns second result of TRUNCATE."
+ (multiple-value-bind (tru rem) (truncate number divisor)
+ (declare (ignore tru))
+ rem))
+
+(defun mod (number divisor)
+ #!+sb-doc
+ "Returns second result of FLOOR."
+ (let ((rem (rem number divisor)))
+ (if (and (not (zerop rem))
+ (if (minusp divisor)
+ (plusp number)
+ (minusp number)))
+ (+ rem divisor)
+ rem)))
+
+(macrolet ((def-frob (name op doc)
+ `(defun ,name (number &optional (divisor 1))
+ ,doc
+ (multiple-value-bind (res rem) (,op number divisor)
+ (values (float res (if (floatp rem) rem 1.0)) rem)))))
+ (def-frob ffloor floor
+ "Same as FLOOR, but returns first value as a float.")
+ (def-frob fceiling ceiling
+ "Same as CEILING, but returns first value as a float." )
+ (def-frob ftruncate truncate
+ "Same as TRUNCATE, but returns first value as a float.")
+ (def-frob fround round
+ "Same as ROUND, but returns first value as a float."))
+\f
+;;;; comparisons
+
+(defun = (number &rest more-numbers)
+ #!+sb-doc
+ "Returns T if all of its arguments are numerically equal, NIL otherwise."
+ (do ((nlist more-numbers (cdr nlist)))
+ ((atom nlist) T)
+ (declare (list nlist))
+ (if (not (= (car nlist) number)) (return nil))))
+
+(defun /= (number &rest more-numbers)
+ #!+sb-doc
+ "Returns T if no two of its arguments are numerically equal, NIL otherwise."
+ (do* ((head number (car nlist))
+ (nlist more-numbers (cdr nlist)))
+ ((atom nlist) t)
+ (declare (list nlist))
+ (unless (do* ((nl nlist (cdr nl)))
+ ((atom nl) T)
+ (declare (list nl))
+ (if (= head (car nl)) (return nil)))
+ (return nil))))
+
+(defun < (number &rest more-numbers)
+ #!+sb-doc
+ "Returns T if its arguments are in strictly increasing order, NIL otherwise."
+ (do* ((n number (car nlist))
+ (nlist more-numbers (cdr nlist)))
+ ((atom nlist) t)
+ (declare (list nlist))
+ (if (not (< n (car nlist))) (return nil))))
+
+(defun > (number &rest more-numbers)
+ #!+sb-doc
+ "Returns T if its arguments are in strictly decreasing order, NIL otherwise."
+ (do* ((n number (car nlist))
+ (nlist more-numbers (cdr nlist)))
+ ((atom nlist) t)
+ (declare (list nlist))
+ (if (not (> n (car nlist))) (return nil))))
+
+(defun <= (number &rest more-numbers)
+ #!+sb-doc
+ "Returns T if arguments are in strictly non-decreasing order, NIL otherwise."
+ (do* ((n number (car nlist))
+ (nlist more-numbers (cdr nlist)))
+ ((atom nlist) t)
+ (declare (list nlist))
+ (if (not (<= n (car nlist))) (return nil))))
+
+(defun >= (number &rest more-numbers)
+ #!+sb-doc
+ "Returns T if arguments are in strictly non-increasing order, NIL otherwise."
+ (do* ((n number (car nlist))
+ (nlist more-numbers (cdr nlist)))
+ ((atom nlist) t)
+ (declare (list nlist))
+ (if (not (>= n (car nlist))) (return nil))))
+
+(defun max (number &rest more-numbers)
+ #!+sb-doc
+ "Returns the greatest of its arguments."
+ (do ((nlist more-numbers (cdr nlist))
+ (result number))
+ ((null nlist) (return result))
+ (declare (list nlist))
+ (if (> (car nlist) result) (setq result (car nlist)))))
+
+(defun min (number &rest more-numbers)
+ #!+sb-doc
+ "Returns the least of its arguments."
+ (do ((nlist more-numbers (cdr nlist))
+ (result number))
+ ((null nlist) (return result))
+ (declare (list nlist))
+ (if (< (car nlist) result) (setq result (car nlist)))))
+
+(eval-when (:compile-toplevel :execute)
+
+;;; The INFINITE-X-FINITE-Y and INFINITE-Y-FINITE-X args tell us how
+;;; to handle the case when X or Y is a floating-point infinity and
+;;; the other arg is a rational. (Section 12.1.4.1 of the ANSI spec
+;;; says that comparisons are done by converting the float to a
+;;; rational when comparing with a rational, but infinities can't be
+;;; converted to a rational, so we show some initiative and do it this
+;;; way instead.)
+(defun basic-compare (op &key infinite-x-finite-y infinite-y-finite-x)
+ `(((fixnum fixnum) (,op x y))
+
+ ((single-float single-float) (,op x y))
+ #!+long-float
+ (((foreach single-float double-float long-float) long-float)
+ (,op (coerce x 'long-float) y))
+ #!+long-float
+ ((long-float (foreach single-float double-float))
+ (,op x (coerce y 'long-float)))
+ (((foreach single-float double-float) double-float)
+ (,op (coerce x 'double-float) y))
+ ((double-float single-float)
+ (,op x (coerce y 'double-float)))
+ (((foreach single-float double-float #!+long-float long-float) rational)
+ (if (eql y 0)
+ (,op x (coerce 0 '(dispatch-type x)))
+ (if (float-infinity-p x)
+ ,infinite-x-finite-y
+ (,op (rational x) y))))
+ (((foreach bignum fixnum ratio) float)
+ (if (float-infinity-p y)
+ ,infinite-y-finite-x
+ (,op x (rational y))))))
+) ; EVAL-WHEN
+
+(macrolet ((def-two-arg-</> (name op ratio-arg1 ratio-arg2 &rest cases)
+ `(defun ,name (x y)
+ (number-dispatch ((x real) (y real))
+ (basic-compare
+ ,op
+ :infinite-x-finite-y
+ (,op x (coerce 0 '(dispatch-type x)))
+ :infinite-y-finite-x
+ (,op (coerce 0 '(dispatch-type y)) y))
+ (((foreach fixnum bignum) ratio)
+ (,op x (,ratio-arg2 (numerator y)
+ (denominator y))))
+ ((ratio integer)
+ (,op (,ratio-arg1 (numerator x)
+ (denominator x))
+ y))
+ ((ratio ratio)
+ (,op (* (numerator (truly-the ratio x))
+ (denominator (truly-the ratio y)))
+ (* (numerator (truly-the ratio y))
+ (denominator (truly-the ratio x)))))
+ ,@cases))))
+ (def-two-arg-</> two-arg-< < floor ceiling
+ ((fixnum bignum)
+ (bignum-plus-p y))
+ ((bignum fixnum)
+ (not (bignum-plus-p x)))
+ ((bignum bignum)
+ (minusp (bignum-compare x y))))
+ (def-two-arg-</> two-arg-> > ceiling floor
+ ((fixnum bignum)
+ (not (bignum-plus-p y)))
+ ((bignum fixnum)
+ (bignum-plus-p x))
+ ((bignum bignum)
+ (plusp (bignum-compare x y)))))
+
+(defun two-arg-= (x y)
+ (number-dispatch ((x number) (y number))
+ (basic-compare =
+ ;; An infinite value is never equal to a finite value.
+ :infinite-x-finite-y nil
+ :infinite-y-finite-x nil)
+ ((fixnum (or bignum ratio)) nil)
+
+ ((bignum (or fixnum ratio)) nil)
+ ((bignum bignum)
+ (zerop (bignum-compare x y)))
+
+ ((ratio integer) nil)
+ ((ratio ratio)
+ (and (eql (numerator x) (numerator y))
+ (eql (denominator x) (denominator y))))
+
+ ((complex complex)
+ (and (= (realpart x) (realpart y))
+ (= (imagpart x) (imagpart y))))
+ (((foreach fixnum bignum ratio single-float double-float
+ #!+long-float long-float) complex)
+ (and (= x (realpart y))
+ (zerop (imagpart y))))
+ ((complex (or float rational))
+ (and (= (realpart x) y)
+ (zerop (imagpart x))))))
+
+(defun eql (obj1 obj2)
+ #!+sb-doc
+ "Return T if OBJ1 and OBJ2 represent the same object, otherwise NIL."
+ (or (eq obj1 obj2)
+ (if (or (typep obj2 'fixnum)
+ (not (typep obj2 'number)))
+ nil
+ (macrolet ((foo (&rest stuff)
+ `(typecase obj2
+ ,@(mapcar #'(lambda (foo)
+ (let ((type (car foo))
+ (fn (cadr foo)))
+ `(,type
+ (and (typep obj1 ',type)
+ (,fn obj1 obj2)))))
+ stuff))))
+ (foo
+ (single-float eql)
+ (double-float eql)
+ #!+long-float
+ (long-float eql)
+ (bignum
+ (lambda (x y)
+ (zerop (bignum-compare x y))))
+ (ratio
+ (lambda (x y)
+ (and (eql (numerator x) (numerator y))
+ (eql (denominator x) (denominator y)))))
+ (complex
+ (lambda (x y)
+ (and (eql (realpart x) (realpart y))
+ (eql (imagpart x) (imagpart y))))))))))
+\f
+;;;; logicals
+
+(defun logior (&rest integers)
+ #!+sb-doc
+ "Returns the bit-wise or of its arguments. Args must be integers."
+ (declare (list integers))
+ (if integers
+ (do ((result (pop integers) (logior result (pop integers))))
+ ((null integers) result))
+ 0))
+
+(defun logxor (&rest integers)
+ #!+sb-doc
+ "Returns the bit-wise exclusive or of its arguments. Args must be integers."
+ (declare (list integers))
+ (if integers
+ (do ((result (pop integers) (logxor result (pop integers))))
+ ((null integers) result))
+ 0))
+
+(defun logand (&rest integers)
+ #!+sb-doc
+ "Returns the bit-wise and of its arguments. Args must be integers."
+ (declare (list integers))
+ (if integers
+ (do ((result (pop integers) (logand result (pop integers))))
+ ((null integers) result))
+ -1))
+
+(defun logeqv (&rest integers)
+ #!+sb-doc
+ "Returns the bit-wise equivalence of its arguments. Args must be integers."
+ (declare (list integers))
+ (if integers
+ (do ((result (pop integers) (logeqv result (pop integers))))
+ ((null integers) result))
+ -1))
+
+(defun lognand (integer1 integer2)
+ #!+sb-doc
+ "Returns the complement of the logical AND of integer1 and integer2."
+ (lognand integer1 integer2))
+
+(defun lognor (integer1 integer2)
+ #!+sb-doc
+ "Returns the complement of the logical OR of integer1 and integer2."
+ (lognor integer1 integer2))
+
+(defun logandc1 (integer1 integer2)
+ #!+sb-doc
+ "Returns the logical AND of (LOGNOT integer1) and integer2."
+ (logandc1 integer1 integer2))
+
+(defun logandc2 (integer1 integer2)
+ #!+sb-doc
+ "Returns the logical AND of integer1 and (LOGNOT integer2)."
+ (logandc2 integer1 integer2))
+
+(defun logorc1 (integer1 integer2)
+ #!+sb-doc
+ "Returns the logical OR of (LOGNOT integer1) and integer2."
+ (logorc1 integer1 integer2))
+
+(defun logorc2 (integer1 integer2)
+ #!+sb-doc
+ "Returns the logical OR of integer1 and (LOGNOT integer2)."
+ (logorc2 integer1 integer2))
+
+(defun lognot (number)
+ #!+sb-doc
+ "Returns the bit-wise logical not of integer."
+ (etypecase number
+ (fixnum (lognot (truly-the fixnum number)))
+ (bignum (bignum-logical-not number))))
+
+(macrolet ((def-frob (name op big-op)
+ `(defun ,name (x y)
+ (number-dispatch ((x integer) (y integer))
+ (bignum-cross-fixnum ,op ,big-op)))))
+ (def-frob two-arg-and logand bignum-logical-and)
+ (def-frob two-arg-ior logior bignum-logical-ior)
+ (def-frob two-arg-xor logxor bignum-logical-xor))
+
+(defun logcount (integer)
+ #!+sb-doc
+ "Count the number of 1 bits if INTEGER is positive, and the number of 0 bits
+ if INTEGER is negative."
+ (etypecase integer
+ (fixnum
+ (logcount (truly-the (integer 0 #.(max most-positive-fixnum
+ (lognot most-negative-fixnum)))
+ (if (minusp (truly-the fixnum integer))
+ (lognot (truly-the fixnum integer))
+ integer))))
+ (bignum
+ (bignum-logcount integer))))
+
+(defun logtest (integer1 integer2)
+ #!+sb-doc
+ "Predicate which returns T if logand of integer1 and integer2 is not zero."
+ (logtest integer1 integer2))
+
+(defun logbitp (index integer)
+ #!+sb-doc
+ "Predicate returns T if bit index of integer is a 1."
+ (logbitp index integer))
+
+(defun ash (integer count)
+ #!+sb-doc
+ "Shifts integer left by count places preserving sign. - count shifts right."
+ (declare (integer integer count))
+ (etypecase integer
+ (fixnum
+ (cond ((zerop integer)
+ 0)
+ ((fixnump count)
+ (let ((length (integer-length (truly-the fixnum integer)))
+ (count (truly-the fixnum count)))
+ (declare (fixnum length count))
+ (cond ((and (plusp count)
+ (> (+ length count)
+ (integer-length most-positive-fixnum)))
+ (bignum-ashift-left (make-small-bignum integer) count))
+ (t
+ (truly-the fixnum
+ (ash (truly-the fixnum integer) count))))))
+ ((minusp count)
+ (if (minusp integer) -1 0))
+ (t
+ (bignum-ashift-left (make-small-bignum integer) count))))
+ (bignum
+ (if (plusp count)
+ (bignum-ashift-left integer count)
+ (bignum-ashift-right integer (- count))))))
+
+(defun integer-length (integer)
+ #!+sb-doc
+ "Returns the number of significant bits in the absolute value of integer."
+ (etypecase integer
+ (fixnum
+ (integer-length (truly-the fixnum integer)))
+ (bignum
+ (bignum-integer-length integer))))
+\f
+;;;; BYTE, bytespecs, and related operations
+
+(defun byte (size position)
+ #!+sb-doc
+ "Returns a byte specifier which may be used by other byte functions."
+ (byte size position))
+
+(defun byte-size (bytespec)
+ #!+sb-doc
+ "Returns the size part of the byte specifier bytespec."
+ (byte-size bytespec))
+
+(defun byte-position (bytespec)
+ #!+sb-doc
+ "Returns the position part of the byte specifier bytespec."
+ (byte-position bytespec))
+
+(defun ldb (bytespec integer)
+ #!+sb-doc
+ "Extract the specified byte from integer, and right justify result."
+ (ldb bytespec integer))
+
+(defun ldb-test (bytespec integer)
+ #!+sb-doc
+ "Returns T if any of the specified bits in integer are 1's."
+ (ldb-test bytespec integer))
+
+(defun mask-field (bytespec integer)
+ #!+sb-doc
+ "Extract the specified byte from integer, but do not right justify result."
+ (mask-field bytespec integer))
+
+(defun dpb (newbyte bytespec integer)
+ #!+sb-doc
+ "Returns new integer with newbyte in specified position, newbyte is right justified."
+ (dpb newbyte bytespec integer))
+
+(defun deposit-field (newbyte bytespec integer)
+ #!+sb-doc
+ "Returns new integer with newbyte in specified position, newbyte is not right justified."
+ (deposit-field newbyte bytespec integer))
+
+(defun %ldb (size posn integer)
+ (logand (ash integer (- posn))
+ (1- (ash 1 size))))
+
+(defun %mask-field (size posn integer)
+ (logand integer (ash (1- (ash 1 size)) posn)))
+
+(defun %dpb (newbyte size posn integer)
+ (let ((mask (1- (ash 1 size))))
+ (logior (logand integer (lognot (ash mask posn)))
+ (ash (logand newbyte mask) posn))))
+
+(defun %deposit-field (newbyte size posn integer)
+ (let ((mask (ash (ldb (byte size 0) -1) posn)))
+ (logior (logand newbyte mask)
+ (logand integer (lognot mask)))))
+\f
+;;;; BOOLE
+
+;;; The boole function dispaches to any logic operation depending on
+;;; the value of a variable. Presently, legal selector values are [0..15].
+;;; boole is open coded for calls with a constant selector. or with calls
+;;; using any of the constants declared below.
+
+(defconstant boole-clr 0
+ #!+sb-doc
+ "Boole function op, makes BOOLE return 0.")
+
+(defconstant boole-set 1
+ #!+sb-doc
+ "Boole function op, makes BOOLE return -1.")
+
+(defconstant boole-1 2
+ #!+sb-doc
+ "Boole function op, makes BOOLE return integer1.")
+
+(defconstant boole-2 3
+ #!+sb-doc
+ "Boole function op, makes BOOLE return integer2.")
+
+(defconstant boole-c1 4
+ #!+sb-doc
+ "Boole function op, makes BOOLE return complement of integer1.")
+
+(defconstant boole-c2 5
+ #!+sb-doc
+ "Boole function op, makes BOOLE return complement of integer2.")
+
+(defconstant boole-and 6
+ #!+sb-doc
+ "Boole function op, makes BOOLE return logand of integer1 and integer2.")
+
+(defconstant boole-ior 7
+ #!+sb-doc
+ "Boole function op, makes BOOLE return logior of integer1 and integer2.")
+
+(defconstant boole-xor 8
+ #!+sb-doc
+ "Boole function op, makes BOOLE return logxor of integer1 and integer2.")
+
+(defconstant boole-eqv 9
+ #!+sb-doc
+ "Boole function op, makes BOOLE return logeqv of integer1 and integer2.")
+
+(defconstant boole-nand 10
+ #!+sb-doc
+ "Boole function op, makes BOOLE return log nand of integer1 and integer2.")
+
+(defconstant boole-nor 11
+ #!+sb-doc
+ "Boole function op, makes BOOLE return lognor of integer1 and integer2.")
+
+(defconstant boole-andc1 12
+ #!+sb-doc
+ "Boole function op, makes BOOLE return logandc1 of integer1 and integer2.")
+
+(defconstant boole-andc2 13
+ #!+sb-doc
+ "Boole function op, makes BOOLE return logandc2 of integer1 and integer2.")
+
+(defconstant boole-orc1 14
+ #!+sb-doc
+ "Boole function op, makes BOOLE return logorc1 of integer1 and integer2.")
+
+(defconstant boole-orc2 15
+ #!+sb-doc
+ "Boole function op, makes BOOLE return logorc2 of integer1 and integer2.")
+
+(defun boole (op integer1 integer2)
+ #!+sb-doc
+ "Bit-wise boolean function on two integers. Function chosen by OP:
+ 0 BOOLE-CLR
+ 1 BOOLE-SET
+ 2 BOOLE-1
+ 3 BOOLE-2
+ 4 BOOLE-C1
+ 5 BOOLE-C2
+ 6 BOOLE-AND
+ 7 BOOLE-IOR
+ 8 BOOLE-XOR
+ 9 BOOLE-EQV
+ 10 BOOLE-NAND
+ 11 BOOLE-NOR
+ 12 BOOLE-ANDC1
+ 13 BOOLE-ANDC2
+ 14 BOOLE-ORC1
+ 15 BOOLE-ORC2"
+ (case op
+ (0 (boole 0 integer1 integer2))
+ (1 (boole 1 integer1 integer2))
+ (2 (boole 2 integer1 integer2))
+ (3 (boole 3 integer1 integer2))
+ (4 (boole 4 integer1 integer2))
+ (5 (boole 5 integer1 integer2))
+ (6 (boole 6 integer1 integer2))
+ (7 (boole 7 integer1 integer2))
+ (8 (boole 8 integer1 integer2))
+ (9 (boole 9 integer1 integer2))
+ (10 (boole 10 integer1 integer2))
+ (11 (boole 11 integer1 integer2))
+ (12 (boole 12 integer1 integer2))
+ (13 (boole 13 integer1 integer2))
+ (14 (boole 14 integer1 integer2))
+ (15 (boole 15 integer1 integer2))
+ (t (error "~S is not of type (mod 16)." op))))
+\f
+;;;; GCD and LCM
+
+(defun gcd (&rest numbers)
+ #!+sb-doc
+ "Returns the greatest common divisor of the arguments, which must be
+ integers. Gcd with no arguments is defined to be 0."
+ (cond ((null numbers) 0)
+ ((null (cdr numbers)) (abs (the integer (car numbers))))
+ (t
+ (do ((gcd (the integer (car numbers))
+ (gcd gcd (the integer (car rest))))
+ (rest (cdr numbers) (cdr rest)))
+ ((null rest) gcd)
+ (declare (integer gcd)
+ (list rest))))))
+
+(defun lcm (&rest numbers)
+ #!+sb-doc
+ "Returns the least common multiple of one or more integers. LCM of no
+ arguments is defined to be 1."
+ (cond ((null numbers) 1)
+ ((null (cdr numbers)) (abs (the integer (car numbers))))
+ (t
+ (do ((lcm (the integer (car numbers))
+ (lcm lcm (the integer (car rest))))
+ (rest (cdr numbers) (cdr rest)))
+ ((null rest) lcm)
+ (declare (integer lcm) (list rest))))))
+
+(defun two-arg-lcm (n m)
+ (declare (integer n m))
+ (* (truncate (max n m) (gcd n m)) (min n m)))
+
+;;; Do the GCD of two integer arguments. With fixnum arguments, we use the
+;;; binary GCD algorithm from Knuth's seminumerical algorithms (slightly
+;;; structurified), otherwise we call BIGNUM-GCD. We pick off the special case
+;;; of 0 before the dispatch so that the bignum code doesn't have to worry
+;;; about "small bignum" zeros.
+(defun two-arg-gcd (u v)
+ (cond ((eql u 0) v)
+ ((eql v 0) u)
+ (t
+ (number-dispatch ((u integer) (v integer))
+ ((fixnum fixnum)
+ (locally
+ (declare (optimize (speed 3) (safety 0)))
+ (do ((k 0 (1+ k))
+ (u (abs u) (ash u -1))
+ (v (abs v) (ash v -1)))
+ ((oddp (logior u v))
+ (do ((temp (if (oddp u) (- v) (ash u -1))
+ (ash temp -1)))
+ (nil)
+ (declare (fixnum temp))
+ (when (oddp temp)
+ (if (plusp temp)
+ (setq u temp)
+ (setq v (- temp)))
+ (setq temp (- u v))
+ (when (zerop temp)
+ (let ((res (ash u k)))
+ (declare (type (signed-byte 31) res)
+ (optimize (inhibit-warnings 3)))
+ (return res))))))
+ (declare (type (mod 30) k)
+ (type (signed-byte 31) u v)))))
+ ((bignum bignum)
+ (bignum-gcd u v))
+ ((bignum fixnum)
+ (bignum-gcd u (make-small-bignum v)))
+ ((fixnum bignum)
+ (bignum-gcd (make-small-bignum u) v))))))
+\f
+;;; From discussion on comp.lang.lisp and Akira Kurihara.
+(defun isqrt (n)
+ #!+sb-doc
+ "Returns the root of the nearest integer less than n which is a perfect
+ square."
+ (declare (type unsigned-byte n) (values unsigned-byte))
+ ;; Theoretically (> n 7), i.e., n-len-quarter > 0.
+ (if (and (fixnump n) (<= n 24))
+ (cond ((> n 15) 4)
+ ((> n 8) 3)
+ ((> n 3) 2)
+ ((> n 0) 1)
+ (t 0))
+ (let* ((n-len-quarter (ash (integer-length n) -2))
+ (n-half (ash n (- (ash n-len-quarter 1))))
+ (n-half-isqrt (isqrt n-half))
+ (init-value (ash (1+ n-half-isqrt) n-len-quarter)))
+ (loop
+ (let ((iterated-value
+ (ash (+ init-value (truncate n init-value)) -1)))
+ (unless (< iterated-value init-value)
+ (return init-value))
+ (setq init-value iterated-value))))))
+\f
+;;;; miscellaneous number predicates
+
+(macrolet ((def-frob (name doc)
+ `(defun ,name (number) ,doc (,name number))))
+ (def-frob zerop "Returns T if number = 0, NIL otherwise.")
+ (def-frob plusp "Returns T if number > 0, NIL otherwise.")
+ (def-frob minusp "Returns T if number < 0, NIL otherwise.")
+ (def-frob oddp "Returns T if number is odd, NIL otherwise.")
+ (def-frob evenp "Returns T if number is even, NIL otherwise."))
(unparse-enough (required-argument) :type function)
(customary-case (required-argument) :type (member :upper :lower)))
+(def!method print-object ((host host) stream)
+ (print-unreadable-object (host stream :type t :identity t)))
+
(def!struct (logical-host
(:make-load-form-fun make-logical-host-load-form-fun)
(:include host
;; on standard Unix filesystems)
(version nil :type (or integer pathname-component-tokens (member :newest))))
-;;; Return a value suitable, e.g., for preinitializing
-;;; *DEFAULT-PATHNAME-DEFAULTS* before *DEFAULT-PATHNAME-DEFAULTS* is
-;;; initialized (at which time we can't safely call e.g. #'PATHNAME).
-(defun make-trivial-default-pathname ()
- (%make-pathname *unix-host* nil nil nil nil :newest))
-
;;; Logical pathnames have the following format:
;;;
;;; logical-namestring ::=
+++ /dev/null
-;;;; This file contains the definitions of most number functions.
-
-;;;; This software is part of the SBCL system. See the README file for
-;;;; more information.
-;;;;
-;;;; This software is derived from the CMU CL system, which was
-;;;; written at Carnegie Mellon University and released into the
-;;;; public domain. The software is in the public domain and is
-;;;; provided with absolutely no warranty. See the COPYING and CREDITS
-;;;; files for more information.
-
-(in-package "SB!KERNEL")
-\f
-;;;; the NUMBER-DISPATCH macro
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
-
-;;; Grovel an individual case to NUMBER-DISPATCH, augmenting RESULT
-;;; with the type dispatches and bodies. Result is a tree built of
-;;; alists representing the dispatching off each arg (in order). The
-;;; leaf is the body to be executed in that case.
-(defun parse-number-dispatch (vars result types var-types body)
- (cond ((null vars)
- (unless (null types) (error "More types than vars."))
- (when (cdr result)
- (error "Duplicate case: ~S." body))
- (setf (cdr result)
- (sublis var-types body :test #'equal)))
- ((null types)
- (error "More vars than types."))
- (t
- (flet ((frob (var type)
- (parse-number-dispatch
- (rest vars)
- (or (assoc type (cdr result) :test #'equal)
- (car (setf (cdr result)
- (acons type nil (cdr result)))))
- (rest types)
- (acons `(dispatch-type ,var) type var-types)
- body)))
- (let ((type (first types))
- (var (first vars)))
- (if (and (consp type) (eq (first type) 'foreach))
- (dolist (type (rest type))
- (frob var type))
- (frob var type)))))))
-
-;;; our guess for the preferred order in which to do type tests
-;;; (cheaper and/or more probable first.)
-(defparameter *type-test-ordering*
- '(fixnum single-float double-float integer #!+long-float long-float bignum
- complex ratio))
-
-;;; Should TYPE1 be tested before TYPE2?
-(defun type-test-order (type1 type2)
- (let ((o1 (position type1 *type-test-ordering*))
- (o2 (position type2 *type-test-ordering*)))
- (cond ((not o1) nil)
- ((not o2) t)
- (t
- (< o1 o2)))))
-
-;;; Return an ETYPECASE form that does the type dispatch, ordering the
-;;; cases for efficiency.
-(defun generate-number-dispatch (vars error-tags cases)
- (if vars
- (let ((var (first vars))
- (cases (sort cases #'type-test-order :key #'car)))
- `((typecase ,var
- ,@(mapcar #'(lambda (case)
- `(,(first case)
- ,@(generate-number-dispatch (rest vars)
- (rest error-tags)
- (cdr case))))
- cases)
- (t (go ,(first error-tags))))))
- cases))
-
-) ; EVAL-WHEN
-
-;;; This is a vaguely case-like macro that does number cross-product
-;;; dispatches. The Vars are the variables we are dispatching off of.
-;;; The Type paired with each Var is used in the error message when no
-;;; case matches. Each case specifies a Type for each var, and is
-;;; executed when that signature holds. A type may be a list
-;;; (FOREACH Each-Type*), causing that case to be repeatedly
-;;; instantiated for every Each-Type. In the body of each case, any
-;;; list of the form (DISPATCH-TYPE Var-Name) is substituted with the
-;;; type of that var in that instance of the case.
-;;;
-;;; As an alternate to a case spec, there may be a form whose CAR is a
-;;; symbol. In this case, we apply the CAR of the form to the CDR and
-;;; treat the result of the call as a list of cases. This process is
-;;; not applied recursively.
-(defmacro number-dispatch (var-specs &body cases)
- (let ((res (list nil))
- (vars (mapcar #'car var-specs))
- (block (gensym)))
- (dolist (case cases)
- (if (symbolp (first case))
- (let ((cases (apply (symbol-function (first case)) (rest case))))
- (dolist (case cases)
- (parse-number-dispatch vars res (first case) nil (rest case))))
- (parse-number-dispatch vars res (first case) nil (rest case))))
-
- (collect ((errors)
- (error-tags))
- (dolist (spec var-specs)
- (let ((var (first spec))
- (type (second spec))
- (tag (gensym)))
- (error-tags tag)
- (errors tag)
- (errors `(return-from
- ,block
- (error 'simple-type-error :datum ,var
- :expected-type ',type
- :format-control
- "~@<Argument ~A is not a ~S: ~2I~_~S~:>"
- :format-arguments
- (list ',var ',type ,var))))))
-
- `(block ,block
- (tagbody
- (return-from ,block
- ,@(generate-number-dispatch vars (error-tags)
- (cdr res)))
- ,@(errors))))))
-\f
-;;;; binary operation dispatching utilities
-
-(eval-when (:compile-toplevel :execute)
-
-;;; Return NUMBER-DISPATCH forms for rational X float.
-(defun float-contagion (op x y &optional (rat-types '(fixnum bignum ratio)))
- `(((single-float single-float) (,op ,x ,y))
- (((foreach ,@rat-types)
- (foreach single-float double-float #!+long-float long-float))
- (,op (coerce ,x '(dispatch-type ,y)) ,y))
- (((foreach single-float double-float #!+long-float long-float)
- (foreach ,@rat-types))
- (,op ,x (coerce ,y '(dispatch-type ,x))))
- #!+long-float
- (((foreach single-float double-float long-float) long-float)
- (,op (coerce ,x 'long-float) ,y))
- #!+long-float
- ((long-float (foreach single-float double-float))
- (,op ,x (coerce ,y 'long-float)))
- (((foreach single-float double-float) double-float)
- (,op (coerce ,x 'double-float) ,y))
- ((double-float single-float)
- (,op ,x (coerce ,y 'double-float)))))
-
-;;; Return NUMBER-DISPATCH forms for bignum X fixnum.
-(defun bignum-cross-fixnum (fix-op big-op)
- `(((fixnum fixnum) (,fix-op x y))
- ((fixnum bignum)
- (,big-op (make-small-bignum x) y))
- ((bignum fixnum)
- (,big-op x (make-small-bignum y)))
- ((bignum bignum)
- (,big-op x y))))
-
-) ; EVAL-WHEN
-\f
-;;;; canonicalization utilities
-
-;;; If IMAGPART is 0, return REALPART, otherwise make a complex. This is
-;;; used when we know that REALPART and IMAGPART are the same type, but
-;;; rational canonicalization might still need to be done.
-#!-sb-fluid (declaim (inline canonical-complex))
-(defun canonical-complex (realpart imagpart)
- (if (eql imagpart 0)
- realpart
- (cond #!+long-float
- ((and (typep realpart 'long-float)
- (typep imagpart 'long-float))
- (truly-the (complex long-float) (complex realpart imagpart)))
- ((and (typep realpart 'double-float)
- (typep imagpart 'double-float))
- (truly-the (complex double-float) (complex realpart imagpart)))
- ((and (typep realpart 'single-float)
- (typep imagpart 'single-float))
- (truly-the (complex single-float) (complex realpart imagpart)))
- (t
- (%make-complex realpart imagpart)))))
-
-;;; Given a numerator and denominator with the GCD already divided
-;;; out, make a canonical rational. We make the denominator positive,
-;;; and check whether it is 1.
-#!-sb-fluid (declaim (inline build-ratio))
-(defun build-ratio (num den)
- (multiple-value-bind (num den)
- (if (minusp den)
- (values (- num) (- den))
- (values num den))
- (if (eql den 1)
- num
- (%make-ratio num den))))
-
-;;; Truncate X and Y, but bum the case where Y is 1.
-#!-sb-fluid (declaim (inline maybe-truncate))
-(defun maybe-truncate (x y)
- (if (eql y 1)
- x
- (truncate x y)))
-\f
-;;;; COMPLEXes
-
-(defun upgraded-complex-part-type (spec)
- #!+sb-doc
- "Returns the element type of the most specialized COMPLEX number type that
- can hold parts of type SPEC."
- (cond ((unknown-type-p (specifier-type spec))
- (error "undefined type: ~S" spec))
- ((subtypep spec 'single-float)
- 'single-float)
- ((subtypep spec 'double-float)
- 'double-float)
- #!+long-float
- ((subtypep spec 'long-float)
- 'long-float)
- ((subtypep spec 'rational)
- 'rational)
- (t
- 'real)))
-
-(defun complex (realpart &optional (imagpart 0))
- #!+sb-doc
- "Builds a complex number from the specified components."
- (flet ((%%make-complex (realpart imagpart)
- (cond #!+long-float
- ((and (typep realpart 'long-float)
- (typep imagpart 'long-float))
- (truly-the (complex long-float)
- (complex realpart imagpart)))
- ((and (typep realpart 'double-float)
- (typep imagpart 'double-float))
- (truly-the (complex double-float)
- (complex realpart imagpart)))
- ((and (typep realpart 'single-float)
- (typep imagpart 'single-float))
- (truly-the (complex single-float)
- (complex realpart imagpart)))
- (t
- (%make-complex realpart imagpart)))))
- (number-dispatch ((realpart real) (imagpart real))
- ((rational rational)
- (canonical-complex realpart imagpart))
- (float-contagion %%make-complex realpart imagpart (rational)))))
-
-(defun realpart (number)
- #!+sb-doc
- "Extracts the real part of a number."
- (typecase number
- #!+long-float
- ((complex long-float)
- (truly-the long-float (realpart number)))
- ((complex double-float)
- (truly-the double-float (realpart number)))
- ((complex single-float)
- (truly-the single-float (realpart number)))
- ((complex rational)
- (sb!kernel:%realpart number))
- (t
- number)))
-
-(defun imagpart (number)
- #!+sb-doc
- "Extracts the imaginary part of a number."
- (typecase number
- #!+long-float
- ((complex long-float)
- (truly-the long-float (imagpart number)))
- ((complex double-float)
- (truly-the double-float (imagpart number)))
- ((complex single-float)
- (truly-the single-float (imagpart number)))
- ((complex rational)
- (sb!kernel:%imagpart number))
- (float
- (float 0 number))
- (t
- 0)))
-
-(defun conjugate (number)
- #!+sb-doc
- "Returns the complex conjugate of NUMBER. For non-complex numbers, this is
- an identity."
- (if (complexp number)
- (complex (realpart number) (- (imagpart number)))
- number))
-
-(defun signum (number)
- #!+sb-doc
- "If NUMBER is zero, return NUMBER, else return (/ NUMBER (ABS NUMBER))."
- (if (zerop number)
- number
- (if (rationalp number)
- (if (plusp number) 1 -1)
- (/ number (abs number)))))
-\f
-;;;; ratios
-
-(defun numerator (number)
- #!+sb-doc
- "Return the numerator of NUMBER, which must be rational."
- (numerator number))
-
-(defun denominator (number)
- #!+sb-doc
- "Return the denominator of NUMBER, which must be rational."
- (denominator number))
-\f
-;;;; arithmetic operations
-
-(macrolet ((define-arith (op init doc)
- #!-sb-doc (declare (ignore doc))
- `(defun ,op (&rest args)
- #!+sb-doc ,doc
- (if (null args) ,init
- (do ((args (cdr args) (cdr args))
- (res (car args) (,op res (car args))))
- ((null args) res))))))
- (define-arith + 0
- "Returns the sum of its arguments. With no args, returns 0.")
- (define-arith * 1
- "Returns the product of its arguments. With no args, returns 1."))
-
-(defun - (number &rest more-numbers)
- #!+sb-doc
- "Subtracts the second and all subsequent arguments from the first.
- With one arg, negates it."
- (if more-numbers
- (do ((nlist more-numbers (cdr nlist))
- (result number))
- ((atom nlist) result)
- (declare (list nlist))
- (setq result (- result (car nlist))))
- (- number)))
-
-(defun / (number &rest more-numbers)
- #!+sb-doc
- "Divide the first argument by each of the following arguments, in turn.
- With one argument, return reciprocal."
- (if more-numbers
- (do ((nlist more-numbers (cdr nlist))
- (result number))
- ((atom nlist) result)
- (declare (list nlist))
- (setq result (/ result (car nlist))))
- (/ number)))
-
-(defun 1+ (number)
- #!+sb-doc
- "Returns NUMBER + 1."
- (1+ number))
-
-(defun 1- (number)
- #!+sb-doc
- "Returns NUMBER - 1."
- (1- number))
-
-(eval-when (:compile-toplevel)
-
-(sb!xc:defmacro two-arg-+/- (name op big-op)
- `(defun ,name (x y)
- (number-dispatch ((x number) (y number))
- (bignum-cross-fixnum ,op ,big-op)
- (float-contagion ,op x y)
-
- ((complex complex)
- (canonical-complex (,op (realpart x) (realpart y))
- (,op (imagpart x) (imagpart y))))
- (((foreach bignum fixnum ratio single-float double-float
- #!+long-float long-float) complex)
- (complex (,op x (realpart y)) (,op (imagpart y))))
- ((complex (or rational float))
- (complex (,op (realpart x) y) (imagpart x)))
-
- (((foreach fixnum bignum) ratio)
- (let* ((dy (denominator y))
- (n (,op (* x dy) (numerator y))))
- (%make-ratio n dy)))
- ((ratio integer)
- (let* ((dx (denominator x))
- (n (,op (numerator x) (* y dx))))
- (%make-ratio n dx)))
- ((ratio ratio)
- (let* ((nx (numerator x))
- (dx (denominator x))
- (ny (numerator y))
- (dy (denominator y))
- (g1 (gcd dx dy)))
- (if (eql g1 1)
- (%make-ratio (,op (* nx dy) (* dx ny)) (* dx dy))
- (let* ((t1 (,op (* nx (truncate dy g1)) (* (truncate dx g1) ny)))
- (g2 (gcd t1 g1))
- (t2 (truncate dx g1)))
- (cond ((eql t1 0) 0)
- ((eql g2 1)
- (%make-ratio t1 (* t2 dy)))
- (T (let* ((nn (truncate t1 g2))
- (t3 (truncate dy g2))
- (nd (if (eql t2 1) t3 (* t2 t3))))
- (if (eql nd 1) nn (%make-ratio nn nd))))))))))))
-
-); Eval-When (Compile)
-
-(two-arg-+/- two-arg-+ + add-bignums)
-(two-arg-+/- two-arg-- - subtract-bignum)
-
-(defun two-arg-* (x y)
- (flet ((integer*ratio (x y)
- (if (eql x 0) 0
- (let* ((ny (numerator y))
- (dy (denominator y))
- (gcd (gcd x dy)))
- (if (eql gcd 1)
- (%make-ratio (* x ny) dy)
- (let ((nn (* (truncate x gcd) ny))
- (nd (truncate dy gcd)))
- (if (eql nd 1)
- nn
- (%make-ratio nn nd)))))))
- (complex*real (x y)
- (canonical-complex (* (realpart x) y) (* (imagpart x) y))))
- (number-dispatch ((x number) (y number))
- (float-contagion * x y)
-
- ((fixnum fixnum) (multiply-fixnums x y))
- ((bignum fixnum) (multiply-bignum-and-fixnum x y))
- ((fixnum bignum) (multiply-bignum-and-fixnum y x))
- ((bignum bignum) (multiply-bignums x y))
-
- ((complex complex)
- (let* ((rx (realpart x))
- (ix (imagpart x))
- (ry (realpart y))
- (iy (imagpart y)))
- (canonical-complex (- (* rx ry) (* ix iy)) (+ (* rx iy) (* ix ry)))))
- (((foreach bignum fixnum ratio single-float double-float
- #!+long-float long-float)
- complex)
- (complex*real y x))
- ((complex (or rational float))
- (complex*real x y))
-
- (((foreach bignum fixnum) ratio) (integer*ratio x y))
- ((ratio integer) (integer*ratio y x))
- ((ratio ratio)
- (let* ((nx (numerator x))
- (dx (denominator x))
- (ny (numerator y))
- (dy (denominator y))
- (g1 (gcd nx dy))
- (g2 (gcd dx ny)))
- (build-ratio (* (maybe-truncate nx g1)
- (maybe-truncate ny g2))
- (* (maybe-truncate dx g2)
- (maybe-truncate dy g1))))))))
-
-;;; Divide two integers, producing a canonical rational. If a fixnum,
-;;; we see whether they divide evenly before trying the GCD. In the
-;;; bignum case, we don't bother, since bignum division is expensive,
-;;; and the test is not very likely to succeed.
-(defun integer-/-integer (x y)
- (if (and (typep x 'fixnum) (typep y 'fixnum))
- (multiple-value-bind (quo rem) (truncate x y)
- (if (zerop rem)
- quo
- (let ((gcd (gcd x y)))
- (declare (fixnum gcd))
- (if (eql gcd 1)
- (build-ratio x y)
- (build-ratio (truncate x gcd) (truncate y gcd))))))
- (let ((gcd (gcd x y)))
- (if (eql gcd 1)
- (build-ratio x y)
- (build-ratio (truncate x gcd) (truncate y gcd))))))
-
-(defun two-arg-/ (x y)
- (number-dispatch ((x number) (y number))
- (float-contagion / x y (ratio integer))
-
- ((complex complex)
- (let* ((rx (realpart x))
- (ix (imagpart x))
- (ry (realpart y))
- (iy (imagpart y)))
- (if (> (abs ry) (abs iy))
- (let* ((r (/ iy ry))
- (dn (* ry (+ 1 (* r r)))))
- (canonical-complex (/ (+ rx (* ix r)) dn)
- (/ (- ix (* rx r)) dn)))
- (let* ((r (/ ry iy))
- (dn (* iy (+ 1 (* r r)))))
- (canonical-complex (/ (+ (* rx r) ix) dn)
- (/ (- (* ix r) rx) dn))))))
- (((foreach integer ratio single-float double-float) complex)
- (let* ((ry (realpart y))
- (iy (imagpart y)))
- (if (> (abs ry) (abs iy))
- (let* ((r (/ iy ry))
- (dn (* ry (+ 1 (* r r)))))
- (canonical-complex (/ x dn)
- (/ (- (* x r)) dn)))
- (let* ((r (/ ry iy))
- (dn (* iy (+ 1 (* r r)))))
- (canonical-complex (/ (* x r) dn)
- (/ (- x) dn))))))
- ((complex (or rational float))
- (canonical-complex (/ (realpart x) y)
- (/ (imagpart x) y)))
-
- ((ratio ratio)
- (let* ((nx (numerator x))
- (dx (denominator x))
- (ny (numerator y))
- (dy (denominator y))
- (g1 (gcd nx ny))
- (g2 (gcd dx dy)))
- (build-ratio (* (maybe-truncate nx g1) (maybe-truncate dy g2))
- (* (maybe-truncate dx g2) (maybe-truncate ny g1)))))
-
- ((integer integer)
- (integer-/-integer x y))
-
- ((integer ratio)
- (if (zerop x)
- 0
- (let* ((ny (numerator y))
- (dy (denominator y))
- (gcd (gcd x ny)))
- (build-ratio (* (maybe-truncate x gcd) dy)
- (maybe-truncate ny gcd)))))
-
- ((ratio integer)
- (let* ((nx (numerator x))
- (gcd (gcd nx y)))
- (build-ratio (maybe-truncate nx gcd)
- (* (maybe-truncate y gcd) (denominator x)))))))
-
-(defun %negate (n)
- (number-dispatch ((n number))
- (((foreach fixnum single-float double-float #!+long-float long-float))
- (%negate n))
- ((bignum)
- (negate-bignum n))
- ((ratio)
- (%make-ratio (- (numerator n)) (denominator n)))
- ((complex)
- (complex (- (realpart n)) (- (imagpart n))))))
-\f
-;;;; TRUNCATE and friends
-
-(defun truncate (number &optional (divisor 1))
- #!+sb-doc
- "Returns number (or number/divisor) as an integer, rounded toward 0.
- The second returned value is the remainder."
- (macrolet ((truncate-float (rtype)
- `(let* ((float-div (coerce divisor ',rtype))
- (res (%unary-truncate (/ number float-div))))
- (values res
- (- number
- (* (coerce res ',rtype) float-div))))))
- (number-dispatch ((number real) (divisor real))
- ((fixnum fixnum) (truncate number divisor))
- (((foreach fixnum bignum) ratio)
- (let ((q (truncate (* number (denominator divisor))
- (numerator divisor))))
- (values q (- number (* q divisor)))))
- ((fixnum bignum)
- (values 0 number))
- ((ratio (or float rational))
- (let ((q (truncate (numerator number)
- (* (denominator number) divisor))))
- (values q (- number (* q divisor)))))
- ((bignum fixnum)
- (bignum-truncate number (make-small-bignum divisor)))
- ((bignum bignum)
- (bignum-truncate number divisor))
-
- (((foreach single-float double-float #!+long-float long-float)
- (or rational single-float))
- (if (eql divisor 1)
- (let ((res (%unary-truncate number)))
- (values res (- number (coerce res '(dispatch-type number)))))
- (truncate-float (dispatch-type number))))
- #!+long-float
- ((long-float (or single-float double-float long-float))
- (truncate-float long-float))
- #!+long-float
- (((foreach double-float single-float) long-float)
- (truncate-float long-float))
- ((double-float (or single-float double-float))
- (truncate-float double-float))
- ((single-float double-float)
- (truncate-float double-float))
- (((foreach fixnum bignum ratio)
- (foreach single-float double-float #!+long-float long-float))
- (truncate-float (dispatch-type divisor))))))
-
-;;; Declare these guys inline to let them get optimized a little.
-;;; ROUND and FROUND are not declared inline since they seem too
-;;; obscure and too big to inline-expand by default. Also, this gives
-;;; the compiler a chance to pick off the unary float case. Similarly,
-;;; CEILING and FLOOR are only maybe-inline for now, so that the
-;;; power-of-2 CEILING and FLOOR transforms get a chance.
-#!-sb-fluid (declaim (inline rem mod fceiling ffloor ftruncate))
-(declaim (maybe-inline ceiling floor))
-
-(defun floor (number &optional (divisor 1))
- #!+sb-doc
- "Returns the greatest integer not greater than number, or number/divisor.
- The second returned value is (mod number divisor)."
- ;; If the numbers do not divide exactly and the result of
- ;; (/ NUMBER DIVISOR) would be negative then decrement the quotient
- ;; and augment the remainder by the divisor.
- (multiple-value-bind (tru rem) (truncate number divisor)
- (if (and (not (zerop rem))
- (if (minusp divisor)
- (plusp number)
- (minusp number)))
- (values (1- tru) (+ rem divisor))
- (values tru rem))))
-
-(defun ceiling (number &optional (divisor 1))
- #!+sb-doc
- "Returns the smallest integer not less than number, or number/divisor.
- The second returned value is the remainder."
- ;; If the numbers do not divide exactly and the result of
- ;; (/ NUMBER DIVISOR) would be positive then increment the quotient
- ;; and decrement the remainder by the divisor.
- (multiple-value-bind (tru rem) (truncate number divisor)
- (if (and (not (zerop rem))
- (if (minusp divisor)
- (minusp number)
- (plusp number)))
- (values (+ tru 1) (- rem divisor))
- (values tru rem))))
-
-(defun round (number &optional (divisor 1))
- #!+sb-doc
- "Rounds number (or number/divisor) to nearest integer.
- The second returned value is the remainder."
- (if (eql divisor 1)
- (round number)
- (multiple-value-bind (tru rem) (truncate number divisor)
- (let ((thresh (/ (abs divisor) 2)))
- (cond ((or (> rem thresh)
- (and (= rem thresh) (oddp tru)))
- (if (minusp divisor)
- (values (- tru 1) (+ rem divisor))
- (values (+ tru 1) (- rem divisor))))
- ((let ((-thresh (- thresh)))
- (or (< rem -thresh)
- (and (= rem -thresh) (oddp tru))))
- (if (minusp divisor)
- (values (+ tru 1) (- rem divisor))
- (values (- tru 1) (+ rem divisor))))
- (t (values tru rem)))))))
-
-(defun rem (number divisor)
- #!+sb-doc
- "Returns second result of TRUNCATE."
- (multiple-value-bind (tru rem) (truncate number divisor)
- (declare (ignore tru))
- rem))
-
-(defun mod (number divisor)
- #!+sb-doc
- "Returns second result of FLOOR."
- (let ((rem (rem number divisor)))
- (if (and (not (zerop rem))
- (if (minusp divisor)
- (plusp number)
- (minusp number)))
- (+ rem divisor)
- rem)))
-
-(macrolet ((def-frob (name op doc)
- `(defun ,name (number &optional (divisor 1))
- ,doc
- (multiple-value-bind (res rem) (,op number divisor)
- (values (float res (if (floatp rem) rem 1.0)) rem)))))
- (def-frob ffloor floor
- "Same as FLOOR, but returns first value as a float.")
- (def-frob fceiling ceiling
- "Same as CEILING, but returns first value as a float." )
- (def-frob ftruncate truncate
- "Same as TRUNCATE, but returns first value as a float.")
- (def-frob fround round
- "Same as ROUND, but returns first value as a float."))
-\f
-;;;; comparisons
-
-(defun = (number &rest more-numbers)
- #!+sb-doc
- "Returns T if all of its arguments are numerically equal, NIL otherwise."
- (do ((nlist more-numbers (cdr nlist)))
- ((atom nlist) T)
- (declare (list nlist))
- (if (not (= (car nlist) number)) (return nil))))
-
-(defun /= (number &rest more-numbers)
- #!+sb-doc
- "Returns T if no two of its arguments are numerically equal, NIL otherwise."
- (do* ((head number (car nlist))
- (nlist more-numbers (cdr nlist)))
- ((atom nlist) t)
- (declare (list nlist))
- (unless (do* ((nl nlist (cdr nl)))
- ((atom nl) T)
- (declare (list nl))
- (if (= head (car nl)) (return nil)))
- (return nil))))
-
-(defun < (number &rest more-numbers)
- #!+sb-doc
- "Returns T if its arguments are in strictly increasing order, NIL otherwise."
- (do* ((n number (car nlist))
- (nlist more-numbers (cdr nlist)))
- ((atom nlist) t)
- (declare (list nlist))
- (if (not (< n (car nlist))) (return nil))))
-
-(defun > (number &rest more-numbers)
- #!+sb-doc
- "Returns T if its arguments are in strictly decreasing order, NIL otherwise."
- (do* ((n number (car nlist))
- (nlist more-numbers (cdr nlist)))
- ((atom nlist) t)
- (declare (list nlist))
- (if (not (> n (car nlist))) (return nil))))
-
-(defun <= (number &rest more-numbers)
- #!+sb-doc
- "Returns T if arguments are in strictly non-decreasing order, NIL otherwise."
- (do* ((n number (car nlist))
- (nlist more-numbers (cdr nlist)))
- ((atom nlist) t)
- (declare (list nlist))
- (if (not (<= n (car nlist))) (return nil))))
-
-(defun >= (number &rest more-numbers)
- #!+sb-doc
- "Returns T if arguments are in strictly non-increasing order, NIL otherwise."
- (do* ((n number (car nlist))
- (nlist more-numbers (cdr nlist)))
- ((atom nlist) t)
- (declare (list nlist))
- (if (not (>= n (car nlist))) (return nil))))
-
-(defun max (number &rest more-numbers)
- #!+sb-doc
- "Returns the greatest of its arguments."
- (do ((nlist more-numbers (cdr nlist))
- (result number))
- ((null nlist) (return result))
- (declare (list nlist))
- (if (> (car nlist) result) (setq result (car nlist)))))
-
-(defun min (number &rest more-numbers)
- #!+sb-doc
- "Returns the least of its arguments."
- (do ((nlist more-numbers (cdr nlist))
- (result number))
- ((null nlist) (return result))
- (declare (list nlist))
- (if (< (car nlist) result) (setq result (car nlist)))))
-
-(eval-when (:compile-toplevel :execute)
-
-;;; The INFINITE-X-FINITE-Y and INFINITE-Y-FINITE-X args tell us how
-;;; to handle the case when X or Y is a floating-point infinity and
-;;; the other arg is a rational. (Section 12.1.4.1 of the ANSI spec
-;;; says that comparisons are done by converting the float to a
-;;; rational when comparing with a rational, but infinities can't be
-;;; converted to a rational, so we show some initiative and do it this
-;;; way instead.)
-(defun basic-compare (op &key infinite-x-finite-y infinite-y-finite-x)
- `(((fixnum fixnum) (,op x y))
-
- ((single-float single-float) (,op x y))
- #!+long-float
- (((foreach single-float double-float long-float) long-float)
- (,op (coerce x 'long-float) y))
- #!+long-float
- ((long-float (foreach single-float double-float))
- (,op x (coerce y 'long-float)))
- (((foreach single-float double-float) double-float)
- (,op (coerce x 'double-float) y))
- ((double-float single-float)
- (,op x (coerce y 'double-float)))
- (((foreach single-float double-float #!+long-float long-float) rational)
- (if (eql y 0)
- (,op x (coerce 0 '(dispatch-type x)))
- (if (float-infinity-p x)
- ,infinite-x-finite-y
- (,op (rational x) y))))
- (((foreach bignum fixnum ratio) float)
- (if (float-infinity-p y)
- ,infinite-y-finite-x
- (,op x (rational y))))))
-) ; EVAL-WHEN
-
-(macrolet ((def-two-arg-</> (name op ratio-arg1 ratio-arg2 &rest cases)
- `(defun ,name (x y)
- (number-dispatch ((x real) (y real))
- (basic-compare
- ,op
- :infinite-x-finite-y
- (,op x (coerce 0 '(dispatch-type x)))
- :infinite-y-finite-x
- (,op (coerce 0 '(dispatch-type y)) y))
- (((foreach fixnum bignum) ratio)
- (,op x (,ratio-arg2 (numerator y)
- (denominator y))))
- ((ratio integer)
- (,op (,ratio-arg1 (numerator x)
- (denominator x))
- y))
- ((ratio ratio)
- (,op (* (numerator (truly-the ratio x))
- (denominator (truly-the ratio y)))
- (* (numerator (truly-the ratio y))
- (denominator (truly-the ratio x)))))
- ,@cases))))
- (def-two-arg-</> two-arg-< < floor ceiling
- ((fixnum bignum)
- (bignum-plus-p y))
- ((bignum fixnum)
- (not (bignum-plus-p x)))
- ((bignum bignum)
- (minusp (bignum-compare x y))))
- (def-two-arg-</> two-arg-> > ceiling floor
- ((fixnum bignum)
- (not (bignum-plus-p y)))
- ((bignum fixnum)
- (bignum-plus-p x))
- ((bignum bignum)
- (plusp (bignum-compare x y)))))
-
-(defun two-arg-= (x y)
- (number-dispatch ((x number) (y number))
- (basic-compare =
- ;; An infinite value is never equal to a finite value.
- :infinite-x-finite-y nil
- :infinite-y-finite-x nil)
- ((fixnum (or bignum ratio)) nil)
-
- ((bignum (or fixnum ratio)) nil)
- ((bignum bignum)
- (zerop (bignum-compare x y)))
-
- ((ratio integer) nil)
- ((ratio ratio)
- (and (eql (numerator x) (numerator y))
- (eql (denominator x) (denominator y))))
-
- ((complex complex)
- (and (= (realpart x) (realpart y))
- (= (imagpart x) (imagpart y))))
- (((foreach fixnum bignum ratio single-float double-float
- #!+long-float long-float) complex)
- (and (= x (realpart y))
- (zerop (imagpart y))))
- ((complex (or float rational))
- (and (= (realpart x) y)
- (zerop (imagpart x))))))
-
-(defun eql (obj1 obj2)
- #!+sb-doc
- "Return T if OBJ1 and OBJ2 represent the same object, otherwise NIL."
- (or (eq obj1 obj2)
- (if (or (typep obj2 'fixnum)
- (not (typep obj2 'number)))
- nil
- (macrolet ((foo (&rest stuff)
- `(typecase obj2
- ,@(mapcar #'(lambda (foo)
- (let ((type (car foo))
- (fn (cadr foo)))
- `(,type
- (and (typep obj1 ',type)
- (,fn obj1 obj2)))))
- stuff))))
- (foo
- (single-float eql)
- (double-float eql)
- #!+long-float
- (long-float eql)
- (bignum
- (lambda (x y)
- (zerop (bignum-compare x y))))
- (ratio
- (lambda (x y)
- (and (eql (numerator x) (numerator y))
- (eql (denominator x) (denominator y)))))
- (complex
- (lambda (x y)
- (and (eql (realpart x) (realpart y))
- (eql (imagpart x) (imagpart y))))))))))
-\f
-;;;; logicals
-
-(defun logior (&rest integers)
- #!+sb-doc
- "Returns the bit-wise or of its arguments. Args must be integers."
- (declare (list integers))
- (if integers
- (do ((result (pop integers) (logior result (pop integers))))
- ((null integers) result))
- 0))
-
-(defun logxor (&rest integers)
- #!+sb-doc
- "Returns the bit-wise exclusive or of its arguments. Args must be integers."
- (declare (list integers))
- (if integers
- (do ((result (pop integers) (logxor result (pop integers))))
- ((null integers) result))
- 0))
-
-(defun logand (&rest integers)
- #!+sb-doc
- "Returns the bit-wise and of its arguments. Args must be integers."
- (declare (list integers))
- (if integers
- (do ((result (pop integers) (logand result (pop integers))))
- ((null integers) result))
- -1))
-
-(defun logeqv (&rest integers)
- #!+sb-doc
- "Returns the bit-wise equivalence of its arguments. Args must be integers."
- (declare (list integers))
- (if integers
- (do ((result (pop integers) (logeqv result (pop integers))))
- ((null integers) result))
- -1))
-
-(defun lognand (integer1 integer2)
- #!+sb-doc
- "Returns the complement of the logical AND of integer1 and integer2."
- (lognand integer1 integer2))
-
-(defun lognor (integer1 integer2)
- #!+sb-doc
- "Returns the complement of the logical OR of integer1 and integer2."
- (lognor integer1 integer2))
-
-(defun logandc1 (integer1 integer2)
- #!+sb-doc
- "Returns the logical AND of (LOGNOT integer1) and integer2."
- (logandc1 integer1 integer2))
-
-(defun logandc2 (integer1 integer2)
- #!+sb-doc
- "Returns the logical AND of integer1 and (LOGNOT integer2)."
- (logandc2 integer1 integer2))
-
-(defun logorc1 (integer1 integer2)
- #!+sb-doc
- "Returns the logical OR of (LOGNOT integer1) and integer2."
- (logorc1 integer1 integer2))
-
-(defun logorc2 (integer1 integer2)
- #!+sb-doc
- "Returns the logical OR of integer1 and (LOGNOT integer2)."
- (logorc2 integer1 integer2))
-
-(defun lognot (number)
- #!+sb-doc
- "Returns the bit-wise logical not of integer."
- (etypecase number
- (fixnum (lognot (truly-the fixnum number)))
- (bignum (bignum-logical-not number))))
-
-(macrolet ((def-frob (name op big-op)
- `(defun ,name (x y)
- (number-dispatch ((x integer) (y integer))
- (bignum-cross-fixnum ,op ,big-op)))))
- (def-frob two-arg-and logand bignum-logical-and)
- (def-frob two-arg-ior logior bignum-logical-ior)
- (def-frob two-arg-xor logxor bignum-logical-xor))
-
-(defun logcount (integer)
- #!+sb-doc
- "Count the number of 1 bits if INTEGER is positive, and the number of 0 bits
- if INTEGER is negative."
- (etypecase integer
- (fixnum
- (logcount (truly-the (integer 0 #.(max most-positive-fixnum
- (lognot most-negative-fixnum)))
- (if (minusp (truly-the fixnum integer))
- (lognot (truly-the fixnum integer))
- integer))))
- (bignum
- (bignum-logcount integer))))
-
-(defun logtest (integer1 integer2)
- #!+sb-doc
- "Predicate which returns T if logand of integer1 and integer2 is not zero."
- (logtest integer1 integer2))
-
-(defun logbitp (index integer)
- #!+sb-doc
- "Predicate returns T if bit index of integer is a 1."
- (logbitp index integer))
-
-(defun ash (integer count)
- #!+sb-doc
- "Shifts integer left by count places preserving sign. - count shifts right."
- (declare (integer integer count))
- (etypecase integer
- (fixnum
- (cond ((zerop integer)
- 0)
- ((fixnump count)
- (let ((length (integer-length (truly-the fixnum integer)))
- (count (truly-the fixnum count)))
- (declare (fixnum length count))
- (cond ((and (plusp count)
- (> (+ length count)
- (integer-length most-positive-fixnum)))
- (bignum-ashift-left (make-small-bignum integer) count))
- (t
- (truly-the fixnum
- (ash (truly-the fixnum integer) count))))))
- ((minusp count)
- (if (minusp integer) -1 0))
- (t
- (bignum-ashift-left (make-small-bignum integer) count))))
- (bignum
- (if (plusp count)
- (bignum-ashift-left integer count)
- (bignum-ashift-right integer (- count))))))
-
-(defun integer-length (integer)
- #!+sb-doc
- "Returns the number of significant bits in the absolute value of integer."
- (etypecase integer
- (fixnum
- (integer-length (truly-the fixnum integer)))
- (bignum
- (bignum-integer-length integer))))
-\f
-;;;; BYTE, bytespecs, and related operations
-
-(defun byte (size position)
- #!+sb-doc
- "Returns a byte specifier which may be used by other byte functions."
- (byte size position))
-
-(defun byte-size (bytespec)
- #!+sb-doc
- "Returns the size part of the byte specifier bytespec."
- (byte-size bytespec))
-
-(defun byte-position (bytespec)
- #!+sb-doc
- "Returns the position part of the byte specifier bytespec."
- (byte-position bytespec))
-
-(defun ldb (bytespec integer)
- #!+sb-doc
- "Extract the specified byte from integer, and right justify result."
- (ldb bytespec integer))
-
-(defun ldb-test (bytespec integer)
- #!+sb-doc
- "Returns T if any of the specified bits in integer are 1's."
- (ldb-test bytespec integer))
-
-(defun mask-field (bytespec integer)
- #!+sb-doc
- "Extract the specified byte from integer, but do not right justify result."
- (mask-field bytespec integer))
-
-(defun dpb (newbyte bytespec integer)
- #!+sb-doc
- "Returns new integer with newbyte in specified position, newbyte is right justified."
- (dpb newbyte bytespec integer))
-
-(defun deposit-field (newbyte bytespec integer)
- #!+sb-doc
- "Returns new integer with newbyte in specified position, newbyte is not right justified."
- (deposit-field newbyte bytespec integer))
-
-(defun %ldb (size posn integer)
- (logand (ash integer (- posn))
- (1- (ash 1 size))))
-
-(defun %mask-field (size posn integer)
- (logand integer (ash (1- (ash 1 size)) posn)))
-
-(defun %dpb (newbyte size posn integer)
- (let ((mask (1- (ash 1 size))))
- (logior (logand integer (lognot (ash mask posn)))
- (ash (logand newbyte mask) posn))))
-
-(defun %deposit-field (newbyte size posn integer)
- (let ((mask (ash (ldb (byte size 0) -1) posn)))
- (logior (logand newbyte mask)
- (logand integer (lognot mask)))))
-\f
-;;;; BOOLE
-
-;;; The boole function dispaches to any logic operation depending on
-;;; the value of a variable. Presently, legal selector values are [0..15].
-;;; boole is open coded for calls with a constant selector. or with calls
-;;; using any of the constants declared below.
-
-(defconstant boole-clr 0
- #!+sb-doc
- "Boole function op, makes BOOLE return 0.")
-
-(defconstant boole-set 1
- #!+sb-doc
- "Boole function op, makes BOOLE return -1.")
-
-(defconstant boole-1 2
- #!+sb-doc
- "Boole function op, makes BOOLE return integer1.")
-
-(defconstant boole-2 3
- #!+sb-doc
- "Boole function op, makes BOOLE return integer2.")
-
-(defconstant boole-c1 4
- #!+sb-doc
- "Boole function op, makes BOOLE return complement of integer1.")
-
-(defconstant boole-c2 5
- #!+sb-doc
- "Boole function op, makes BOOLE return complement of integer2.")
-
-(defconstant boole-and 6
- #!+sb-doc
- "Boole function op, makes BOOLE return logand of integer1 and integer2.")
-
-(defconstant boole-ior 7
- #!+sb-doc
- "Boole function op, makes BOOLE return logior of integer1 and integer2.")
-
-(defconstant boole-xor 8
- #!+sb-doc
- "Boole function op, makes BOOLE return logxor of integer1 and integer2.")
-
-(defconstant boole-eqv 9
- #!+sb-doc
- "Boole function op, makes BOOLE return logeqv of integer1 and integer2.")
-
-(defconstant boole-nand 10
- #!+sb-doc
- "Boole function op, makes BOOLE return log nand of integer1 and integer2.")
-
-(defconstant boole-nor 11
- #!+sb-doc
- "Boole function op, makes BOOLE return lognor of integer1 and integer2.")
-
-(defconstant boole-andc1 12
- #!+sb-doc
- "Boole function op, makes BOOLE return logandc1 of integer1 and integer2.")
-
-(defconstant boole-andc2 13
- #!+sb-doc
- "Boole function op, makes BOOLE return logandc2 of integer1 and integer2.")
-
-(defconstant boole-orc1 14
- #!+sb-doc
- "Boole function op, makes BOOLE return logorc1 of integer1 and integer2.")
-
-(defconstant boole-orc2 15
- #!+sb-doc
- "Boole function op, makes BOOLE return logorc2 of integer1 and integer2.")
-
-(defun boole (op integer1 integer2)
- #!+sb-doc
- "Bit-wise boolean function on two integers. Function chosen by OP:
- 0 BOOLE-CLR
- 1 BOOLE-SET
- 2 BOOLE-1
- 3 BOOLE-2
- 4 BOOLE-C1
- 5 BOOLE-C2
- 6 BOOLE-AND
- 7 BOOLE-IOR
- 8 BOOLE-XOR
- 9 BOOLE-EQV
- 10 BOOLE-NAND
- 11 BOOLE-NOR
- 12 BOOLE-ANDC1
- 13 BOOLE-ANDC2
- 14 BOOLE-ORC1
- 15 BOOLE-ORC2"
- (case op
- (0 (boole 0 integer1 integer2))
- (1 (boole 1 integer1 integer2))
- (2 (boole 2 integer1 integer2))
- (3 (boole 3 integer1 integer2))
- (4 (boole 4 integer1 integer2))
- (5 (boole 5 integer1 integer2))
- (6 (boole 6 integer1 integer2))
- (7 (boole 7 integer1 integer2))
- (8 (boole 8 integer1 integer2))
- (9 (boole 9 integer1 integer2))
- (10 (boole 10 integer1 integer2))
- (11 (boole 11 integer1 integer2))
- (12 (boole 12 integer1 integer2))
- (13 (boole 13 integer1 integer2))
- (14 (boole 14 integer1 integer2))
- (15 (boole 15 integer1 integer2))
- (t (error "~S is not of type (mod 16)." op))))
-\f
-;;;; GCD and LCM
-
-(defun gcd (&rest numbers)
- #!+sb-doc
- "Returns the greatest common divisor of the arguments, which must be
- integers. Gcd with no arguments is defined to be 0."
- (cond ((null numbers) 0)
- ((null (cdr numbers)) (abs (the integer (car numbers))))
- (t
- (do ((gcd (the integer (car numbers))
- (gcd gcd (the integer (car rest))))
- (rest (cdr numbers) (cdr rest)))
- ((null rest) gcd)
- (declare (integer gcd)
- (list rest))))))
-
-(defun lcm (&rest numbers)
- #!+sb-doc
- "Returns the least common multiple of one or more integers. LCM of no
- arguments is defined to be 1."
- (cond ((null numbers) 1)
- ((null (cdr numbers)) (abs (the integer (car numbers))))
- (t
- (do ((lcm (the integer (car numbers))
- (lcm lcm (the integer (car rest))))
- (rest (cdr numbers) (cdr rest)))
- ((null rest) lcm)
- (declare (integer lcm) (list rest))))))
-
-(defun two-arg-lcm (n m)
- (declare (integer n m))
- (* (truncate (max n m) (gcd n m)) (min n m)))
-
-;;; Do the GCD of two integer arguments. With fixnum arguments, we use the
-;;; binary GCD algorithm from Knuth's seminumerical algorithms (slightly
-;;; structurified), otherwise we call BIGNUM-GCD. We pick off the special case
-;;; of 0 before the dispatch so that the bignum code doesn't have to worry
-;;; about "small bignum" zeros.
-(defun two-arg-gcd (u v)
- (cond ((eql u 0) v)
- ((eql v 0) u)
- (t
- (number-dispatch ((u integer) (v integer))
- ((fixnum fixnum)
- (locally
- (declare (optimize (speed 3) (safety 0)))
- (do ((k 0 (1+ k))
- (u (abs u) (ash u -1))
- (v (abs v) (ash v -1)))
- ((oddp (logior u v))
- (do ((temp (if (oddp u) (- v) (ash u -1))
- (ash temp -1)))
- (nil)
- (declare (fixnum temp))
- (when (oddp temp)
- (if (plusp temp)
- (setq u temp)
- (setq v (- temp)))
- (setq temp (- u v))
- (when (zerop temp)
- (let ((res (ash u k)))
- (declare (type (signed-byte 31) res)
- (optimize (inhibit-warnings 3)))
- (return res))))))
- (declare (type (mod 30) k)
- (type (signed-byte 31) u v)))))
- ((bignum bignum)
- (bignum-gcd u v))
- ((bignum fixnum)
- (bignum-gcd u (make-small-bignum v)))
- ((fixnum bignum)
- (bignum-gcd (make-small-bignum u) v))))))
-\f
-;;; From discussion on comp.lang.lisp and Akira Kurihara.
-(defun isqrt (n)
- #!+sb-doc
- "Returns the root of the nearest integer less than n which is a perfect
- square."
- (declare (type unsigned-byte n) (values unsigned-byte))
- ;; Theoretically (> n 7), i.e., n-len-quarter > 0.
- (if (and (fixnump n) (<= n 24))
- (cond ((> n 15) 4)
- ((> n 8) 3)
- ((> n 3) 2)
- ((> n 0) 1)
- (t 0))
- (let* ((n-len-quarter (ash (integer-length n) -2))
- (n-half (ash n (- (ash n-len-quarter 1))))
- (n-half-isqrt (isqrt n-half))
- (init-value (ash (1+ n-half-isqrt) n-len-quarter)))
- (loop
- (let ((iterated-value
- (ash (+ init-value (truncate n init-value)) -1)))
- (unless (< iterated-value init-value)
- (return init-value))
- (setq init-value iterated-value))))))
-\f
-;;;; miscellaneous number predicates
-
-(macrolet ((def-frob (name doc)
- `(defun ,name (number) ,doc (,name number))))
- (def-frob zerop "Returns T if number = 0, NIL otherwise.")
- (def-frob plusp "Returns T if number > 0, NIL otherwise.")
- (def-frob minusp "Returns T if number < 0, NIL otherwise.")
- (def-frob oddp "Returns T if number is odd, NIL otherwise.")
- (def-frob evenp "Returns T if number is even, NIL otherwise."))
#!-sb-fluid (declaim (freeze-type logical-pathname logical-host))
\f
-;;; host methods
-
-(def!method print-object ((host host) stream)
- (print-unreadable-object (host stream :type t :identity t)))
+;;;; UNIX-HOST stuff
+
+(def!struct (unix-host
+ (:make-load-form-fun make-unix-host-load-form)
+ (:include host
+ (parse #'parse-unix-namestring)
+ (unparse #'unparse-unix-namestring)
+ (unparse-host #'unparse-unix-host)
+ (unparse-directory #'unparse-unix-directory)
+ (unparse-file #'unparse-unix-file)
+ (unparse-enough #'unparse-unix-enough)
+ (customary-case :lower))))
+
+(defvar *unix-host* (make-unix-host))
+
+(defun make-unix-host-load-form (host)
+ (declare (ignore host))
+ '*unix-host*)
+
+;;; Return a value suitable, e.g., for preinitializing
+;;; *DEFAULT-PATHNAME-DEFAULTS* before *DEFAULT-PATHNAME-DEFAULTS* is
+;;; initialized (at which time we can't safely call e.g. #'PATHNAME).
+(defun make-trivial-default-pathname ()
+ (%make-pathname *unix-host* nil nil nil nil :newest))
\f
;;; pathname methods
--- /dev/null
+;;;; the usual place for DEF-IR1-TRANSLATOR forms (and their
+;;;; close personal friends)
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!C")
+\f
+;;;; control special forms
+
+(def-ir1-translator progn ((&rest forms) start cont)
+ #!+sb-doc
+ "Progn Form*
+ Evaluates each Form in order, returning the values of the last form. With no
+ forms, returns NIL."
+ (ir1-convert-progn-body start cont forms))
+
+(def-ir1-translator if ((test then &optional else) start cont)
+ #!+sb-doc
+ "If Predicate Then [Else]
+ If Predicate evaluates to non-null, evaluate Then and returns its values,
+ otherwise evaluate Else and return its values. Else defaults to NIL."
+ (let* ((pred (make-continuation))
+ (then-cont (make-continuation))
+ (then-block (continuation-starts-block then-cont))
+ (else-cont (make-continuation))
+ (else-block (continuation-starts-block else-cont))
+ (dummy-cont (make-continuation))
+ (node (make-if :test pred
+ :consequent then-block
+ :alternative else-block)))
+ (setf (continuation-dest pred) node)
+ (ir1-convert start pred test)
+ (prev-link node pred)
+ (use-continuation node dummy-cont)
+
+ (let ((start-block (continuation-block pred)))
+ (setf (block-last start-block) node)
+ (continuation-starts-block cont)
+
+ (link-blocks start-block then-block)
+ (link-blocks start-block else-block)
+
+ (ir1-convert then-cont cont then)
+ (ir1-convert else-cont cont else))))
+\f
+;;;; BLOCK and TAGBODY
+
+;;;; We make an Entry node to mark the start and a :Entry cleanup to
+;;;; mark its extent. When doing GO or RETURN-FROM, we emit an Exit
+;;;; node.
+
+;;; Make a :ENTRY cleanup and emit an ENTRY node, then convert the
+;;; body in the modified environment. We make CONT start a block now,
+;;; since if it was done later, the block would be in the wrong
+;;; environment.
+(def-ir1-translator block ((name &rest forms) start cont)
+ #!+sb-doc
+ "Block Name Form*
+ Evaluate the Forms as a PROGN. Within the lexical scope of the body,
+ (RETURN-FROM Name Value-Form) can be used to exit the form, returning the
+ result of Value-Form."
+ (unless (symbolp name)
+ (compiler-error "The block name ~S is not a symbol." name))
+ (continuation-starts-block cont)
+ (let* ((dummy (make-continuation))
+ (entry (make-entry))
+ (cleanup (make-cleanup :kind :block
+ :mess-up entry)))
+ (push entry (lambda-entries (lexenv-lambda *lexenv*)))
+ (setf (entry-cleanup entry) cleanup)
+ (prev-link entry start)
+ (use-continuation entry dummy)
+
+ (let* ((env-entry (list entry cont))
+ (*lexenv* (make-lexenv :blocks (list (cons name env-entry))
+ :cleanup cleanup)))
+ (push env-entry (continuation-lexenv-uses cont))
+ (ir1-convert-progn-body dummy cont forms))))
+
+
+;;; We make CONT start a block just so that it will have a block
+;;; assigned. People assume that when they pass a continuation into
+;;; IR1-CONVERT as CONT, it will have a block when it is done.
+(def-ir1-translator return-from ((name &optional value)
+ start cont)
+ #!+sb-doc
+ "Return-From Block-Name Value-Form
+ Evaluate the Value-Form, returning its values from the lexically enclosing
+ BLOCK Block-Name. This is constrained to be used only within the dynamic
+ extent of the BLOCK."
+ (continuation-starts-block cont)
+ (let* ((found (or (lexenv-find name blocks)
+ (compiler-error "return for unknown block: ~S" name)))
+ (value-cont (make-continuation))
+ (entry (first found))
+ (exit (make-exit :entry entry
+ :value value-cont)))
+ (push exit (entry-exits entry))
+ (setf (continuation-dest value-cont) exit)
+ (ir1-convert start value-cont value)
+ (prev-link exit value-cont)
+ (use-continuation exit (second found))))
+
+;;; Return a list of the segments of a TAGBODY. Each segment looks
+;;; like (<tag> <form>* (go <next tag>)). That is, we break up the
+;;; tagbody into segments of non-tag statements, and explicitly
+;;; represent the drop-through with a GO. The first segment has a
+;;; dummy NIL tag, since it represents code before the first tag. The
+;;; last segment (which may also be the first segment) ends in NIL
+;;; rather than a GO.
+(defun parse-tagbody (body)
+ (declare (list body))
+ (collect ((segments))
+ (let ((current (cons nil body)))
+ (loop
+ (let ((tag-pos (position-if (complement #'listp) current :start 1)))
+ (unless tag-pos
+ (segments `(,@current nil))
+ (return))
+ (let ((tag (elt current tag-pos)))
+ (when (assoc tag (segments))
+ (compiler-error
+ "The tag ~S appears more than once in the tagbody."
+ tag))
+ (unless (or (symbolp tag) (integerp tag))
+ (compiler-error "~S is not a legal tagbody statement." tag))
+ (segments `(,@(subseq current 0 tag-pos) (go ,tag))))
+ (setq current (nthcdr tag-pos current)))))
+ (segments)))
+
+;;; Set up the cleanup, emitting the entry node. Then make a block for
+;;; each tag, building up the tag list for LEXENV-TAGS as we go.
+;;; Finally, convert each segment with the precomputed Start and Cont
+;;; values.
+(def-ir1-translator tagbody ((&rest statements) start cont)
+ #!+sb-doc
+ "Tagbody {Tag | Statement}*
+ Define tags for used with GO. The Statements are evaluated in order
+ (skipping Tags) and NIL is returned. If a statement contains a GO to a
+ defined Tag within the lexical scope of the form, then control is transferred
+ to the next statement following that tag. A Tag must an integer or a
+ symbol. A statement must be a list. Other objects are illegal within the
+ body."
+ (continuation-starts-block cont)
+ (let* ((dummy (make-continuation))
+ (entry (make-entry))
+ (segments (parse-tagbody statements))
+ (cleanup (make-cleanup :kind :tagbody
+ :mess-up entry)))
+ (push entry (lambda-entries (lexenv-lambda *lexenv*)))
+ (setf (entry-cleanup entry) cleanup)
+ (prev-link entry start)
+ (use-continuation entry dummy)
+
+ (collect ((tags)
+ (starts)
+ (conts))
+ (starts dummy)
+ (dolist (segment (rest segments))
+ (let* ((tag-cont (make-continuation))
+ (tag (list (car segment) entry tag-cont)))
+ (conts tag-cont)
+ (starts tag-cont)
+ (continuation-starts-block tag-cont)
+ (tags tag)
+ (push (cdr tag) (continuation-lexenv-uses tag-cont))))
+ (conts cont)
+
+ (let ((*lexenv* (make-lexenv :cleanup cleanup :tags (tags))))
+ (mapc (lambda (segment start cont)
+ (ir1-convert-progn-body start cont (rest segment)))
+ segments (starts) (conts))))))
+
+;;; Emit an EXIT node without any value.
+(def-ir1-translator go ((tag) start cont)
+ #!+sb-doc
+ "Go Tag
+ Transfer control to the named Tag in the lexically enclosing TAGBODY. This
+ is constrained to be used only within the dynamic extent of the TAGBODY."
+ (continuation-starts-block cont)
+ (let* ((found (or (lexenv-find tag tags :test #'eql)
+ (compiler-error "Go to nonexistent tag: ~S." tag)))
+ (entry (first found))
+ (exit (make-exit :entry entry)))
+ (push exit (entry-exits entry))
+ (prev-link exit start)
+ (use-continuation exit (second found))))
+\f
+;;;; translators for compiler-magic special forms
+
+;;; This handles EVAL-WHEN in non-top-level forms. (EVAL-WHENs in
+;;; top-level forms are picked off and handled by PROCESS-TOP-LEVEL-FORM,
+;;; so that they're never seen at this level.)
+;;;
+;;; ANSI "3.2.3.1 Processing of Top Level Forms" says that processing
+;;; of non-top-level EVAL-WHENs is very simple:
+;;; EVAL-WHEN forms cause compile-time evaluation only at top level.
+;;; Both :COMPILE-TOPLEVEL and :LOAD-TOPLEVEL situation specifications
+;;; are ignored for non-top-level forms. For non-top-level forms, an
+;;; eval-when specifying the :EXECUTE situation is treated as an
+;;; implicit PROGN including the forms in the body of the EVAL-WHEN
+;;; form; otherwise, the forms in the body are ignored.
+(def-ir1-translator eval-when ((situations &rest forms) start cont)
+ #!+sb-doc
+ "EVAL-WHEN (Situation*) Form*
+ Evaluate the Forms in the specified Situations (any of :COMPILE-TOPLEVEL,
+ :LOAD-TOPLEVEL, or :EXECUTE, or (deprecated) COMPILE, LOAD, or EVAL)."
+ (multiple-value-bind (ct lt e) (parse-eval-when-situations situations)
+ (declare (ignore ct lt))
+ (ir1-convert-progn-body start cont (and e forms)))
+ (values))
+
+;;; common logic for MACROLET and SYMBOL-MACROLET
+;;;
+;;; Call DEFINITIONIZE-FUN on each element of DEFINITIONS to find its
+;;; in-lexenv representation, stuff the results into *LEXENV*, and
+;;; call FUN (with no arguments).
+(defun %funcall-in-foomacrolet-lexenv (definitionize-fun
+ definitionize-keyword
+ definitions
+ fun)
+ (declare (type function definitionize-fun fun))
+ (declare (type (member :variables :functions) definitionize-keyword))
+ (declare (type list definitions))
+ (unless (= (length definitions)
+ (length (remove-duplicates definitions :key #'first)))
+ (compiler-style-warning "duplicate definitions in ~S" definitions))
+ (let* ((processed-definitions (mapcar definitionize-fun definitions))
+ (*lexenv* (make-lexenv definitionize-keyword processed-definitions)))
+ (funcall fun)))
+
+;;; Tweak *LEXENV* to include the DEFINITIONS from a MACROLET, then
+;;; call FUN (with no arguments).
+;;;
+;;; This is split off from the IR1 convert method so that it can be
+;;; shared by the special-case top-level MACROLET processing code.
+(defun funcall-in-macrolet-lexenv (definitions fun)
+ (%funcall-in-foomacrolet-lexenv
+ (lambda (definition)
+ (unless (list-of-length-at-least-p definition 2)
+ (compiler-error
+ "The list ~S is too short to be a legal local macro definition."
+ definition))
+ (destructuring-bind (name arglist &body body) definition
+ (unless (symbolp name)
+ (compiler-error "The local macro name ~S is not a symbol." name))
+ (let ((whole (gensym "WHOLE"))
+ (environment (gensym "ENVIRONMENT")))
+ (multiple-value-bind (body local-decls)
+ (parse-defmacro arglist whole body name 'macrolet
+ :environment environment)
+ `(,name macro .
+ ,(compile nil
+ `(lambda (,whole ,environment)
+ ,@local-decls
+ (block ,name ,body))))))))
+ :functions
+ definitions
+ fun))
+
+(def-ir1-translator macrolet ((definitions &rest body) start cont)
+ #!+sb-doc
+ "MACROLET ({(Name Lambda-List Form*)}*) Body-Form*
+ Evaluate the Body-Forms in an environment with the specified local macros
+ defined. Name is the local macro name, Lambda-List is the DEFMACRO style
+ destructuring lambda list, and the Forms evaluate to the expansion. The
+ Forms are evaluated in the null environment."
+ (funcall-in-macrolet-lexenv definitions
+ (lambda ()
+ (ir1-translate-locally body start cont))))
+
+(defun funcall-in-symbol-macrolet-lexenv (definitions fun)
+ (%funcall-in-foomacrolet-lexenv
+ (lambda (definition)
+ (unless (proper-list-of-length-p definition 2)
+ (compiler-error "malformed symbol/expansion pair: ~S" definition))
+ (destructuring-bind (name expansion) definition
+ (unless (symbolp name)
+ (compiler-error
+ "The local symbol macro name ~S is not a symbol."
+ name))
+ `(,name . (MACRO . ,expansion))))
+ :variables
+ definitions
+ fun))
+
+(def-ir1-translator symbol-macrolet ((macrobindings &body body) start cont)
+ #!+sb-doc
+ "SYMBOL-MACROLET ({(Name Expansion)}*) Decl* Form*
+ Define the Names as symbol macros with the given Expansions. Within the
+ body, references to a Name will effectively be replaced with the Expansion."
+ (funcall-in-symbol-macrolet-lexenv
+ macrobindings
+ (lambda ()
+ (ir1-translate-locally body start cont))))
+
+;;; not really a special form, but..
+(def-ir1-translator declare ((&rest stuff) start cont)
+ (declare (ignore stuff))
+ ;; We ignore START and CONT too, but we can't use DECLARE IGNORE to
+ ;; tell the compiler about it here, because the DEF-IR1-TRANSLATOR
+ ;; macro would put the DECLARE in the wrong place, so..
+ start cont
+ (compiler-error "misplaced declaration"))
+\f
+;;;; %PRIMITIVE
+;;;;
+;;;; Uses of %PRIMITIVE are either expanded into Lisp code or turned
+;;;; into a funny function.
+
+;;; Carefully evaluate a list of forms, returning a list of the results.
+(defun eval-info-args (args)
+ (declare (list args))
+ (handler-case (mapcar #'eval args)
+ (error (condition)
+ (compiler-error "Lisp error during evaluation of info args:~%~A"
+ condition))))
+
+;;; If there is a primitive translator, then we expand the call.
+;;; Otherwise, we convert to the %%PRIMITIVE funny function. The first
+;;; argument is the template, the second is a list of the results of
+;;; any codegen-info args, and the remaining arguments are the runtime
+;;; arguments.
+;;;
+;;; We do a bunch of error checking now so that we don't bomb out with
+;;; a fatal error during IR2 conversion.
+;;;
+;;; KLUDGE: It's confusing having multiple names floating around for
+;;; nearly the same concept: PRIMITIVE, TEMPLATE, VOP. Now that CMU
+;;; CL's *PRIMITIVE-TRANSLATORS* stuff is gone, we could call
+;;; primitives VOPs, rename TEMPLATE to VOP-TEMPLATE, rename
+;;; BACKEND-TEMPLATE-NAMES to BACKEND-VOPS, and rename %PRIMITIVE to
+;;; VOP or %VOP.. -- WHN 2001-06-11
+;;; FIXME: Look at doing this ^, it doesn't look too hard actually.
+(def-ir1-translator %primitive ((name &rest args) start cont)
+ (unless (symbolp name)
+ (compiler-error "The primitive name ~S is not a symbol." name))
+
+ (let* ((template (or (gethash name *backend-template-names*)
+ (compiler-error
+ "The primitive name ~A is not defined."
+ name)))
+ (required (length (template-arg-types template)))
+ (info (template-info-arg-count template))
+ (min (+ required info))
+ (nargs (length args)))
+ (if (template-more-args-type template)
+ (when (< nargs min)
+ (compiler-error "Primitive ~A was called with ~R argument~:P, ~
+ but wants at least ~R."
+ name
+ nargs
+ min))
+ (unless (= nargs min)
+ (compiler-error "Primitive ~A was called with ~R argument~:P, ~
+ but wants exactly ~R."
+ name
+ nargs
+ min)))
+
+ (when (eq (template-result-types template) :conditional)
+ (compiler-error
+ "%PRIMITIVE was used with a conditional template."))
+
+ (when (template-more-results-type template)
+ (compiler-error
+ "%PRIMITIVE was used with an unknown values template."))
+
+ (ir1-convert start
+ cont
+ `(%%primitive ',template
+ ',(eval-info-args
+ (subseq args required min))
+ ,@(subseq args 0 required)
+ ,@(subseq args min)))))
+\f
+;;;; QUOTE and FUNCTION
+
+(def-ir1-translator quote ((thing) start cont)
+ #!+sb-doc
+ "QUOTE Value
+ Return Value without evaluating it."
+ (reference-constant start cont thing))
+
+(def-ir1-translator function ((thing) start cont)
+ #!+sb-doc
+ "FUNCTION Name
+ Return the lexically apparent definition of the function Name. Name may also
+ be a lambda."
+ (if (consp thing)
+ (case (car thing)
+ ((lambda)
+ (reference-leaf start cont (ir1-convert-lambda thing)))
+ ((setf)
+ (let ((var (find-lexically-apparent-function
+ thing "as the argument to FUNCTION")))
+ (reference-leaf start cont var)))
+ ((instance-lambda)
+ (let ((res (ir1-convert-lambda `(lambda ,@(cdr thing)))))
+ (setf (getf (functional-plist res) :fin-function) t)
+ (reference-leaf start cont res)))
+ (t
+ (compiler-error "~S is not a legal function name." thing)))
+ (let ((var (find-lexically-apparent-function
+ thing "as the argument to FUNCTION")))
+ (reference-leaf start cont var))))
+\f
+;;;; FUNCALL
+
+;;; FUNCALL is implemented on %FUNCALL, which can only call functions
+;;; (not symbols). %FUNCALL is used directly in some places where the
+;;; call should always be open-coded even if FUNCALL is :NOTINLINE.
+(deftransform funcall ((function &rest args) * * :when :both)
+ (let ((arg-names (make-gensym-list (length args))))
+ `(lambda (function ,@arg-names)
+ (%funcall ,(if (csubtypep (continuation-type function)
+ (specifier-type 'function))
+ 'function
+ '(%coerce-callable-to-function function))
+ ,@arg-names))))
+
+(def-ir1-translator %funcall ((function &rest args) start cont)
+ (let ((fun-cont (make-continuation)))
+ (ir1-convert start fun-cont function)
+ (assert-continuation-type fun-cont (specifier-type 'function))
+ (ir1-convert-combination-args fun-cont cont args)))
+
+;;; This source transform exists to reduce the amount of work for the
+;;; compiler. If the called function is a FUNCTION form, then convert
+;;; directly to %FUNCALL, instead of waiting around for type
+;;; inference.
+(def-source-transform funcall (function &rest args)
+ (if (and (consp function) (eq (car function) 'function))
+ `(%funcall ,function ,@args)
+ (values nil t)))
+
+(deftransform %coerce-callable-to-function ((thing) (function) *
+ :when :both
+ :important t)
+ "optimize away possible call to FDEFINITION at runtime"
+ 'thing)
+\f
+;;;; LET and LET*
+;;;;
+;;;; (LET and LET* can't be implemented as macros due to the fact that
+;;;; any pervasive declarations also affect the evaluation of the
+;;;; arguments.)
+
+;;; Given a list of binding specifiers in the style of Let, return:
+;;; 1. The list of var structures for the variables bound.
+;;; 2. The initial value form for each variable.
+;;;
+;;; The variable names are checked for legality and globally special
+;;; variables are marked as such. Context is the name of the form, for
+;;; error reporting purposes.
+(declaim (ftype (function (list symbol) (values list list list))
+ extract-let-variables))
+(defun extract-let-variables (bindings context)
+ (collect ((vars)
+ (vals)
+ (names))
+ (flet ((get-var (name)
+ (varify-lambda-arg name
+ (if (eq context 'let*)
+ nil
+ (names)))))
+ (dolist (spec bindings)
+ (cond ((atom spec)
+ (let ((var (get-var spec)))
+ (vars var)
+ (names (cons spec var))
+ (vals nil)))
+ (t
+ (unless (proper-list-of-length-p spec 1 2)
+ (compiler-error "The ~S binding spec ~S is malformed."
+ context
+ spec))
+ (let* ((name (first spec))
+ (var (get-var name)))
+ (vars var)
+ (names name)
+ (vals (second spec)))))))
+
+ (values (vars) (vals) (names))))
+
+(def-ir1-translator let ((bindings &body body)
+ start cont)
+ #!+sb-doc
+ "LET ({(Var [Value]) | Var}*) Declaration* Form*
+ During evaluation of the Forms, bind the Vars to the result of evaluating the
+ Value forms. The variables are bound in parallel after all of the Values are
+ evaluated."
+ (multiple-value-bind (forms decls) (sb!sys:parse-body body nil)
+ (multiple-value-bind (vars values) (extract-let-variables bindings 'let)
+ (let* ((*lexenv* (process-decls decls vars nil cont))
+ (fun-cont (make-continuation))
+ (fun (ir1-convert-lambda-body forms vars)))
+ (reference-leaf start fun-cont fun)
+ (ir1-convert-combination-args fun-cont cont values)))))
+
+(def-ir1-translator let* ((bindings &body body)
+ start cont)
+ #!+sb-doc
+ "LET* ({(Var [Value]) | Var}*) Declaration* Form*
+ Similar to LET, but the variables are bound sequentially, allowing each Value
+ form to reference any of the previous Vars."
+ (multiple-value-bind (forms decls) (sb!sys:parse-body body nil)
+ (multiple-value-bind (vars values) (extract-let-variables bindings 'let*)
+ (let ((*lexenv* (process-decls decls vars nil cont)))
+ (ir1-convert-aux-bindings start cont forms vars values)))))
+
+;;; logic shared between IR1 translators for LOCALLY, MACROLET,
+;;; and SYMBOL-MACROLET
+;;;
+;;; Note that all these things need to preserve top-level-formness,
+;;; but we don't need to worry about that within an IR1 translator,
+;;; since top-level-formness is picked off by PROCESS-TOP-LEVEL-FOO
+;;; forms before we hit the IR1 transform level.
+(defun ir1-translate-locally (body start cont)
+ (declare (type list body) (type continuation start cont))
+ (multiple-value-bind (forms decls) (sb!sys:parse-body body nil)
+ (let ((*lexenv* (process-decls decls nil nil cont)))
+ (ir1-convert-aux-bindings start cont forms nil nil))))
+
+(def-ir1-translator locally ((&body body) start cont)
+ #!+sb-doc
+ "LOCALLY Declaration* Form*
+ Sequentially evaluate the Forms in a lexical environment where the
+ the Declarations have effect. If LOCALLY is a top-level form, then
+ the Forms are also processed as top-level forms."
+ (ir1-translate-locally body start cont))
+\f
+;;;; FLET and LABELS
+
+;;; Given a list of local function specifications in the style of
+;;; FLET, return lists of the function names and of the lambdas which
+;;; are their definitions.
+;;;
+;;; The function names are checked for legality. CONTEXT is the name
+;;; of the form, for error reporting.
+(declaim (ftype (function (list symbol) (values list list))
+ extract-flet-variables))
+(defun extract-flet-variables (definitions context)
+ (collect ((names)
+ (defs))
+ (dolist (def definitions)
+ (when (or (atom def) (< (length def) 2))
+ (compiler-error "The ~S definition spec ~S is malformed." context def))
+
+ (let ((name (check-function-name (first def))))
+ (names name)
+ (multiple-value-bind (forms decls) (sb!sys:parse-body (cddr def))
+ (defs `(lambda ,(second def)
+ ,@decls
+ (block ,(function-name-block-name name)
+ . ,forms))))))
+ (values (names) (defs))))
+
+(def-ir1-translator flet ((definitions &body body)
+ start cont)
+ #!+sb-doc
+ "FLET ({(Name Lambda-List Declaration* Form*)}*) Declaration* Body-Form*
+ Evaluate the Body-Forms with some local function definitions. The bindings
+ do not enclose the definitions; any use of Name in the Forms will refer to
+ the lexically apparent function definition in the enclosing environment."
+ (multiple-value-bind (forms decls) (sb!sys:parse-body body nil)
+ (multiple-value-bind (names defs)
+ (extract-flet-variables definitions 'flet)
+ (let* ((fvars (mapcar (lambda (n d)
+ (ir1-convert-lambda d n))
+ names defs))
+ (*lexenv* (make-lexenv
+ :default (process-decls decls nil fvars cont)
+ :functions (pairlis names fvars))))
+ (ir1-convert-progn-body start cont forms)))))
+
+;;; For LABELS, we have to create dummy function vars and add them to
+;;; the function namespace while converting the functions. We then
+;;; modify all the references to these leaves so that they point to
+;;; the real functional leaves. We also backpatch the FENV so that if
+;;; the lexical environment is used for inline expansion we will get
+;;; the right functions.
+(def-ir1-translator labels ((definitions &body body) start cont)
+ #!+sb-doc
+ "LABELS ({(Name Lambda-List Declaration* Form*)}*) Declaration* Body-Form*
+ Evaluate the Body-Forms with some local function definitions. The bindings
+ enclose the new definitions, so the defined functions can call themselves or
+ each other."
+ (multiple-value-bind (forms decls) (sb!sys:parse-body body nil)
+ (multiple-value-bind (names defs)
+ (extract-flet-variables definitions 'labels)
+ (let* ((new-fenv (loop for name in names
+ collect (cons name (make-functional :name name))))
+ (real-funs
+ (let ((*lexenv* (make-lexenv :functions new-fenv)))
+ (mapcar (lambda (n d)
+ (ir1-convert-lambda d n))
+ names defs))))
+
+ (loop for real in real-funs and env in new-fenv do
+ (let ((dum (cdr env)))
+ (substitute-leaf real dum)
+ (setf (cdr env) real)))
+
+ (let ((*lexenv* (make-lexenv
+ :default (process-decls decls nil real-funs cont)
+ :functions (pairlis names real-funs))))
+ (ir1-convert-progn-body start cont forms))))))
+\f
+;;;; THE
+
+;;; Do stuff to recognize a THE or VALUES declaration. CONT is the
+;;; continuation that the assertion applies to, TYPE is the type
+;;; specifier and Lexenv is the current lexical environment. NAME is
+;;; the name of the declaration we are doing, for use in error
+;;; messages.
+;;;
+;;; This is somewhat involved, since a type assertion may only be made
+;;; on a continuation, not on a node. We can't just set the
+;;; continuation asserted type and let it go at that, since there may
+;;; be parallel THE's for the same continuation, i.e.:
+;;; (if ...
+;;; (the foo ...)
+;;; (the bar ...))
+;;;
+;;; In this case, our representation can do no better than the union
+;;; of these assertions. And if there is a branch with no assertion,
+;;; we have nothing at all. We really need to recognize scoping, since
+;;; we need to be able to discern between parallel assertions (which
+;;; we union) and nested ones (which we intersect).
+;;;
+;;; We represent the scoping by throwing our innermost (intersected)
+;;; assertion on CONT into the TYPE-RESTRICTIONS. As we go down, we
+;;; intersect our assertions together. If CONT has no uses yet, we
+;;; have not yet bottomed out on the first COND branch; in this case
+;;; we optimistically assume that this type will be the one we end up
+;;; with, and set the ASSERTED-TYPE to it. We can never get better
+;;; than the type that we have the first time we bottom out. Later
+;;; THE's (or the absence thereof) can only weaken this result.
+;;;
+;;; We make this work by getting USE-CONTINUATION to do the unioning
+;;; across COND branches. We can't do it here, since we don't know how
+;;; many branches there are going to be.
+(defun do-the-stuff (type cont lexenv name)
+ (declare (type continuation cont) (type lexenv lexenv))
+ (let* ((ctype (values-specifier-type type))
+ (old-type (or (lexenv-find cont type-restrictions)
+ *wild-type*))
+ (intersects (values-types-equal-or-intersect old-type ctype))
+ (int (values-type-intersection old-type ctype))
+ (new (if intersects int old-type)))
+ (when (null (find-uses cont))
+ (setf (continuation-asserted-type cont) new))
+ (when (and (not intersects)
+ (not (policy *lexenv*
+ (= inhibit-warnings 3)))) ;FIXME: really OK to suppress?
+ (compiler-warning
+ "The type ~S in ~S declaration conflicts with an enclosing assertion:~% ~S"
+ (type-specifier ctype)
+ name
+ (type-specifier old-type)))
+ (make-lexenv :type-restrictions `((,cont . ,new))
+ :default lexenv)))
+
+;;; Assert that FORM evaluates to the specified type (which may be a
+;;; VALUES type).
+;;;
+;;; FIXME: In a version of CMU CL that I used at Cadabra ca. 20000101,
+;;; this didn't seem to expand into an assertion, at least for ALIEN
+;;; values. Check that SBCL doesn't have this problem.
+(def-ir1-translator the ((type value) start cont)
+ (let ((*lexenv* (do-the-stuff type cont *lexenv* 'the)))
+ (ir1-convert start cont value)))
+
+;;; This is like the THE special form, except that it believes
+;;; whatever you tell it. It will never generate a type check, but
+;;; will cause a warning if the compiler can prove the assertion is
+;;; wrong.
+;;;
+;;; Since the CONTINUATION-DERIVED-TYPE is computed as the union of
+;;; its uses's types, setting it won't work. Instead we must intersect
+;;; the type with the uses's DERIVED-TYPE.
+(def-ir1-translator truly-the ((type value) start cont)
+ #!+sb-doc
+ (declare (inline member))
+ (let ((type (values-specifier-type type))
+ (old (find-uses cont)))
+ (ir1-convert start cont value)
+ (do-uses (use cont)
+ (unless (member use old :test #'eq)
+ (derive-node-type use type)))))
+\f
+;;;; SETQ
+
+;;; If there is a definition in LEXENV-VARIABLES, just set that,
+;;; otherwise look at the global information. If the name is for a
+;;; constant, then error out.
+(def-ir1-translator setq ((&whole source &rest things) start cont)
+ (let ((len (length things)))
+ (when (oddp len)
+ (compiler-error "odd number of args to SETQ: ~S" source))
+ (if (= len 2)
+ (let* ((name (first things))
+ (leaf (or (lexenv-find name variables)
+ (find-free-variable name))))
+ (etypecase leaf
+ (leaf
+ (when (or (constant-p leaf)
+ (and (global-var-p leaf)
+ (eq (global-var-kind leaf) :constant)))
+ (compiler-error "~S is a constant and thus can't be set." name))
+ (when (and (lambda-var-p leaf)
+ (lambda-var-ignorep leaf))
+ ;; ANSI's definition of "Declaration IGNORE, IGNORABLE"
+ ;; requires that this be a STYLE-WARNING, not a full warning.
+ (compiler-style-warning
+ "~S is being set even though it was declared to be ignored."
+ name))
+ (set-variable start cont leaf (second things)))
+ (cons
+ (aver (eq (car leaf) 'MACRO))
+ (ir1-convert start cont `(setf ,(cdr leaf) ,(second things))))
+ (heap-alien-info
+ (ir1-convert start cont
+ `(%set-heap-alien ',leaf ,(second things))))))
+ (collect ((sets))
+ (do ((thing things (cddr thing)))
+ ((endp thing)
+ (ir1-convert-progn-body start cont (sets)))
+ (sets `(setq ,(first thing) ,(second thing))))))))
+
+;;; This is kind of like REFERENCE-LEAF, but we generate a SET node.
+;;; This should only need to be called in SETQ.
+(defun set-variable (start cont var value)
+ (declare (type continuation start cont) (type basic-var var))
+ (let ((dest (make-continuation)))
+ (setf (continuation-asserted-type dest) (leaf-type var))
+ (ir1-convert start dest value)
+ (let ((res (make-set :var var :value dest)))
+ (setf (continuation-dest dest) res)
+ (setf (leaf-ever-used var) t)
+ (push res (basic-var-sets var))
+ (prev-link res dest)
+ (use-continuation res cont))))
+\f
+;;;; CATCH, THROW and UNWIND-PROTECT
+
+;;; We turn THROW into a multiple-value-call of a magical function,
+;;; since as as far as IR1 is concerned, it has no interesting
+;;; properties other than receiving multiple-values.
+(def-ir1-translator throw ((tag result) start cont)
+ #!+sb-doc
+ "Throw Tag Form
+ Do a non-local exit, return the values of Form from the CATCH whose tag
+ evaluates to the same thing as Tag."
+ (ir1-convert start cont
+ `(multiple-value-call #'%throw ,tag ,result)))
+
+;;; This is a special special form used to instantiate a cleanup as
+;;; the current cleanup within the body. KIND is a the kind of cleanup
+;;; to make, and MESS-UP is a form that does the mess-up action. We
+;;; make the MESS-UP be the USE of the MESS-UP form's continuation,
+;;; and introduce the cleanup into the lexical environment. We
+;;; back-patch the ENTRY-CLEANUP for the current cleanup to be the new
+;;; cleanup, since this inner cleanup is the interesting one.
+(def-ir1-translator %within-cleanup ((kind mess-up &body body) start cont)
+ (let ((dummy (make-continuation))
+ (dummy2 (make-continuation)))
+ (ir1-convert start dummy mess-up)
+ (let* ((mess-node (continuation-use dummy))
+ (cleanup (make-cleanup :kind kind
+ :mess-up mess-node))
+ (old-cup (lexenv-cleanup *lexenv*))
+ (*lexenv* (make-lexenv :cleanup cleanup)))
+ (setf (entry-cleanup (cleanup-mess-up old-cup)) cleanup)
+ (ir1-convert dummy dummy2 '(%cleanup-point))
+ (ir1-convert-progn-body dummy2 cont body))))
+
+;;; This is a special special form that makes an "escape function"
+;;; which returns unknown values from named block. We convert the
+;;; function, set its kind to :ESCAPE, and then reference it. The
+;;; :Escape kind indicates that this function's purpose is to
+;;; represent a non-local control transfer, and that it might not
+;;; actually have to be compiled.
+;;;
+;;; Note that environment analysis replaces references to escape
+;;; functions with references to the corresponding NLX-INFO structure.
+(def-ir1-translator %escape-function ((tag) start cont)
+ (let ((fun (ir1-convert-lambda
+ `(lambda ()
+ (return-from ,tag (%unknown-values))))))
+ (setf (functional-kind fun) :escape)
+ (reference-leaf start cont fun)))
+
+;;; Yet another special special form. This one looks up a local
+;;; function and smashes it to a :CLEANUP function, as well as
+;;; referencing it.
+(def-ir1-translator %cleanup-function ((name) start cont)
+ (let ((fun (lexenv-find name functions)))
+ (aver (lambda-p fun))
+ (setf (functional-kind fun) :cleanup)
+ (reference-leaf start cont fun)))
+
+;;; We represent the possibility of the control transfer by making an
+;;; "escape function" that does a lexical exit, and instantiate the
+;;; cleanup using %WITHIN-CLEANUP.
+(def-ir1-translator catch ((tag &body body) start cont)
+ #!+sb-doc
+ "Catch Tag Form*
+ Evaluates Tag and instantiates it as a catcher while the body forms are
+ evaluated in an implicit PROGN. If a THROW is done to Tag within the dynamic
+ scope of the body, then control will be transferred to the end of the body
+ and the thrown values will be returned."
+ (ir1-convert
+ start cont
+ (let ((exit-block (gensym "EXIT-BLOCK-")))
+ `(block ,exit-block
+ (%within-cleanup
+ :catch
+ (%catch (%escape-function ,exit-block) ,tag)
+ ,@body)))))
+
+;;; UNWIND-PROTECT is similar to CATCH, but more hairy. We make the
+;;; cleanup forms into a local function so that they can be referenced
+;;; both in the case where we are unwound and in any local exits. We
+;;; use %CLEANUP-FUNCTION on this to indicate that reference by
+;;; %UNWIND-PROTECT ISN'T "real", and thus doesn't cause creation of
+;;; an XEP.
+(def-ir1-translator unwind-protect ((protected &body cleanup) start cont)
+ #!+sb-doc
+ "Unwind-Protect Protected Cleanup*
+ Evaluate the form Protected, returning its values. The cleanup forms are
+ evaluated whenever the dynamic scope of the Protected form is exited (either
+ due to normal completion or a non-local exit such as THROW)."
+ (ir1-convert
+ start cont
+ (let ((cleanup-fun (gensym "CLEANUP-FUN-"))
+ (drop-thru-tag (gensym "DROP-THRU-TAG-"))
+ (exit-tag (gensym "EXIT-TAG-"))
+ (next (gensym "NEXT"))
+ (start (gensym "START"))
+ (count (gensym "COUNT")))
+ `(flet ((,cleanup-fun () ,@cleanup nil))
+ ;; FIXME: If we ever get DYNAMIC-EXTENT working, then
+ ;; ,CLEANUP-FUN should probably be declared DYNAMIC-EXTENT,
+ ;; and something can be done to make %ESCAPE-FUNCTION have
+ ;; dynamic extent too.
+ (block ,drop-thru-tag
+ (multiple-value-bind (,next ,start ,count)
+ (block ,exit-tag
+ (%within-cleanup
+ :unwind-protect
+ (%unwind-protect (%escape-function ,exit-tag)
+ (%cleanup-function ,cleanup-fun))
+ (return-from ,drop-thru-tag ,protected)))
+ (,cleanup-fun)
+ (%continue-unwind ,next ,start ,count)))))))
+\f
+;;;; multiple-value stuff
+
+;;; If there are arguments, MULTIPLE-VALUE-CALL turns into an
+;;; MV-COMBINATION.
+;;;
+;;; If there are no arguments, then we convert to a normal
+;;; combination, ensuring that a MV-COMBINATION always has at least
+;;; one argument. This can be regarded as an optimization, but it is
+;;; more important for simplifying compilation of MV-COMBINATIONS.
+(def-ir1-translator multiple-value-call ((fun &rest args) start cont)
+ #!+sb-doc
+ "MULTIPLE-VALUE-CALL Function Values-Form*
+ Call Function, passing all the values of each Values-Form as arguments,
+ values from the first Values-Form making up the first argument, etc."
+ (let* ((fun-cont (make-continuation))
+ (node (if args
+ (make-mv-combination fun-cont)
+ (make-combination fun-cont))))
+ (ir1-convert start fun-cont
+ (if (and (consp fun) (eq (car fun) 'function))
+ fun
+ `(%coerce-callable-to-function ,fun)))
+ (setf (continuation-dest fun-cont) node)
+ (assert-continuation-type fun-cont
+ (specifier-type '(or function symbol)))
+ (collect ((arg-conts))
+ (let ((this-start fun-cont))
+ (dolist (arg args)
+ (let ((this-cont (make-continuation node)))
+ (ir1-convert this-start this-cont arg)
+ (setq this-start this-cont)
+ (arg-conts this-cont)))
+ (prev-link node this-start)
+ (use-continuation node cont)
+ (setf (basic-combination-args node) (arg-conts))))))
+
+;;; MULTIPLE-VALUE-PROG1 is represented implicitly in IR1 by having a
+;;; the result code use result continuation (CONT), but transfer
+;;; control to the evaluation of the body. In other words, the result
+;;; continuation isn't IMMEDIATELY-USED-P by the nodes that compute
+;;; the result.
+;;;
+;;; In order to get the control flow right, we convert the result with
+;;; a dummy result continuation, then convert all the uses of the
+;;; dummy to be uses of CONT. If a use is an EXIT, then we also
+;;; substitute CONT for the dummy in the corresponding ENTRY node so
+;;; that they are consistent. Note that this doesn't amount to
+;;; changing the exit target, since the control destination of an exit
+;;; is determined by the block successor; we are just indicating the
+;;; continuation that the result is delivered to.
+;;;
+;;; We then convert the body, using another dummy continuation in its
+;;; own block as the result. After we are done converting the body, we
+;;; move all predecessors of the dummy end block to CONT's block.
+;;;
+;;; Note that we both exploit and maintain the invariant that the CONT
+;;; to an IR1 convert method either has no block or starts the block
+;;; that control should transfer to after completion for the form.
+;;; Nested MV-PROG1's work because during conversion of the result
+;;; form, we use dummy continuation whose block is the true control
+;;; destination.
+(def-ir1-translator multiple-value-prog1 ((result &rest forms) start cont)
+ #!+sb-doc
+ "MULTIPLE-VALUE-PROG1 Values-Form Form*
+ Evaluate Values-Form and then the Forms, but return all the values of
+ Values-Form."
+ (continuation-starts-block cont)
+ (let* ((dummy-result (make-continuation))
+ (dummy-start (make-continuation))
+ (cont-block (continuation-block cont)))
+ (continuation-starts-block dummy-start)
+ (ir1-convert start dummy-start result)
+
+ (substitute-continuation-uses cont dummy-start)
+
+ (continuation-starts-block dummy-result)
+ (ir1-convert-progn-body dummy-start dummy-result forms)
+ (let ((end-block (continuation-block dummy-result)))
+ (dolist (pred (block-pred end-block))
+ (unlink-blocks pred end-block)
+ (link-blocks pred cont-block))
+ (aver (not (continuation-dest dummy-result)))
+ (delete-continuation dummy-result)
+ (remove-from-dfo end-block))))
+\f
+;;;; interface to defining macros
+
+;;;; FIXME:
+;;;; classic CMU CL comment:
+;;;; DEFMACRO and DEFUN expand into calls to %DEFxxx functions
+;;;; so that we get a chance to see what is going on. We define
+;;;; IR1 translators for these functions which look at the
+;;;; definition and then generate a call to the %%DEFxxx function.
+;;;; Alas, this implementation doesn't do the right thing for
+;;;; non-toplevel uses of these forms, so this should probably
+;;;; be changed to use EVAL-WHEN instead.
+
+;;; Return a new source path with any stuff intervening between the
+;;; current path and the first form beginning with NAME stripped off.
+;;; This is used to hide the guts of DEFmumble macros to prevent
+;;; annoying error messages.
+(defun revert-source-path (name)
+ (do ((path *current-path* (cdr path)))
+ ((null path) *current-path*)
+ (let ((first (first path)))
+ (when (or (eq first name)
+ (eq first 'original-source-start))
+ (return path)))))
+
+;;; Warn about incompatible or illegal definitions and add the macro
+;;; to the compiler environment.
+;;;
+;;; Someday we could check for macro arguments being incompatibly
+;;; redefined. Doing this right will involve finding the old macro
+;;; lambda-list and comparing it with the new one.
+(def-ir1-translator %defmacro ((qname qdef lambda-list doc) start cont
+ :kind :function)
+ (let (;; QNAME is typically a quoted name. I think the idea is to
+ ;; let %DEFMACRO work as an ordinary function when
+ ;; interpreting. Whatever the reason the quote is there, we
+ ;; don't want it any more. -- WHN 19990603
+ (name (eval qname))
+ ;; QDEF should be a sharp-quoted definition. We don't want to
+ ;; make a function of it just yet, so we just drop the
+ ;; sharp-quote.
+ (def (progn
+ (aver (eq 'function (first qdef)))
+ (aver (proper-list-of-length-p qdef 2))
+ (second qdef))))
+
+ (/show "doing IR1 translator for %DEFMACRO" name)
+
+ (unless (symbolp name)
+ (compiler-error "The macro name ~S is not a symbol." name))
+
+ (ecase (info :function :kind name)
+ ((nil))
+ (:function
+ (remhash name *free-functions*)
+ (undefine-function-name name)
+ (compiler-warning
+ "~S is being redefined as a macro when it was ~
+ previously ~(~A~) to be a function."
+ name
+ (info :function :where-from name)))
+ (:macro)
+ (:special-form
+ (compiler-error "The special form ~S can't be redefined as a macro."
+ name)))
+
+ (setf (info :function :kind name) :macro
+ (info :function :where-from name) :defined
+ (info :function :macro-function name) (coerce def 'function))
+
+ (let* ((*current-path* (revert-source-path 'defmacro))
+ (fun (ir1-convert-lambda def name)))
+ (setf (leaf-name fun)
+ (concatenate 'string "DEFMACRO " (symbol-name name)))
+ (setf (functional-arg-documentation fun) (eval lambda-list))
+
+ (ir1-convert start cont `(%%defmacro ',name ,fun ,doc)))
+
+ (when sb!xc:*compile-print*
+ ;; FIXME: It would be nice to convert this, and the other places
+ ;; which create compiler diagnostic output prefixed by
+ ;; semicolons, to use some common utility which automatically
+ ;; prefixes all its output with semicolons. (The addition of
+ ;; semicolon prefixes was introduced ca. sbcl-0.6.8.10 as the
+ ;; "MNA compiler message patch", and implemented by modifying a
+ ;; bunch of output statements on a case-by-case basis, which
+ ;; seems unnecessarily error-prone and unclear, scattering
+ ;; implicit information about output style throughout the
+ ;; system.) Starting by rewriting COMPILER-MUMBLE to add
+ ;; semicolon prefixes would be a good start, and perhaps also:
+ ;; * Add semicolon prefixes for "FOO assembled" messages emitted
+ ;; when e.g. src/assembly/x86/assem-rtns.lisp is processed.
+ ;; * At least some debugger output messages deserve semicolon
+ ;; prefixes too:
+ ;; ** restarts table
+ ;; ** "Within the debugger, you can type HELP for help."
+ (compiler-mumble "~&; converted ~S~%" name))))
+
+(def-ir1-translator %define-compiler-macro ((name def lambda-list doc)
+ start cont
+ :kind :function)
+ (let ((name (eval name))
+ (def (second def))) ; We don't want to make a function just yet...
+
+ (when (eq (info :function :kind name) :special-form)
+ (compiler-error "attempt to define a compiler-macro for special form ~S"
+ name))
+
+ (setf (info :function :compiler-macro-function name)
+ (coerce def 'function))
+
+ (let* ((*current-path* (revert-source-path 'define-compiler-macro))
+ (fun (ir1-convert-lambda def name)))
+ (setf (leaf-name fun)
+ (let ((*print-case* :upcase))
+ (format nil "DEFINE-COMPILER-MACRO ~S" name)))
+ (setf (functional-arg-documentation fun) (eval lambda-list))
+
+ (ir1-convert start cont `(%%define-compiler-macro ',name ,fun ,doc)))
+
+ (when sb!xc:*compile-print*
+ (compiler-mumble "~&; converted ~S~%" name))))
--- /dev/null
+;;;; machinery for reporting errors/warnings/notes/whatnot from
+;;;; the compiler
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!C")
+\f
+;;;; compiler error context determination
+
+(declaim (special *current-path*))
+
+;;; We bind print level and length when printing out messages so that
+;;; we don't dump huge amounts of garbage.
+;;;
+;;; FIXME: It's not possible to get the defaults right for everyone.
+;;; So: Should these variables be in the SB-EXT package? Or should we
+;;; just get rid of them completely and just use the bare
+;;; CL:*PRINT-FOO* variables instead?
+(declaim (type (or unsigned-byte null)
+ *compiler-error-print-level*
+ *compiler-error-print-length*
+ *compiler-error-print-lines*))
+(defvar *compiler-error-print-level* 5
+ #!+sb-doc
+ "the value for *PRINT-LEVEL* when printing compiler error messages")
+(defvar *compiler-error-print-length* 10
+ #!+sb-doc
+ "the value for *PRINT-LENGTH* when printing compiler error messages")
+(defvar *compiler-error-print-lines* 12
+ #!+sb-doc
+ "the value for *PRINT-LINES* when printing compiler error messages")
+
+(defvar *enclosing-source-cutoff* 1
+ #!+sb-doc
+ "The maximum number of enclosing non-original source forms (i.e. from
+ macroexpansion) that we print in full. For additional enclosing forms, we
+ print only the CAR.")
+(declaim (type unsigned-byte *enclosing-source-cutoff*))
+
+;;; We separate the determination of compiler error contexts from the
+;;; actual signalling of those errors by objectifying the error
+;;; context. This allows postponement of the determination of how (and
+;;; if) to signal the error.
+;;;
+;;; We take care not to reference any of the IR1 so that pending
+;;; potential error messages won't prevent the IR1 from being GC'd. To
+;;; this end, we convert source forms to strings so that source forms
+;;; that contain IR1 references (e.g. %DEFUN) don't hold onto the IR.
+(defstruct (compiler-error-context
+ #-no-ansi-print-object
+ (:print-object (lambda (x stream)
+ (print-unreadable-object (x stream :type t))))
+ (:copier nil))
+ ;; a list of the stringified CARs of the enclosing non-original source forms
+ ;; exceeding the *enclosing-source-cutoff*
+ (enclosing-source nil :type list)
+ ;; a list of stringified enclosing non-original source forms
+ (source nil :type list)
+ ;; the stringified form in the original source that expanded into SOURCE
+ (original-source (required-argument) :type simple-string)
+ ;; a list of prefixes of "interesting" forms that enclose original-source
+ (context nil :type list)
+ ;; the FILE-INFO-NAME for the relevant FILE-INFO
+ (file-name (required-argument)
+ :type (or pathname (member :lisp :stream)))
+ ;; the file position at which the top-level form starts, if applicable
+ (file-position nil :type (or index null))
+ ;; the original source part of the source path
+ (original-source-path nil :type list))
+
+;;; If true, this is the node which is used as context in compiler warning
+;;; messages.
+(declaim (type (or null compiler-error-context node) *compiler-error-context*))
+(defvar *compiler-error-context* nil)
+
+;;; a hashtable mapping macro names to source context parsers. Each parser
+;;; function returns the source-context list for that form.
+(defvar *source-context-methods* (make-hash-table))
+
+;;; documentation originally from cmu-user.tex:
+;;; This macro defines how to extract an abbreviated source context from
+;;; the \var{name}d form when it appears in the compiler input.
+;;; \var{lambda-list} is a \code{defmacro} style lambda-list used to
+;;; parse the arguments. The \var{body} should return a list of
+;;; subforms that can be printed on about one line. There are
+;;; predefined methods for \code{defstruct}, \code{defmethod}, etc. If
+;;; no method is defined, then the first two subforms are returned.
+;;; Note that this facility implicitly determines the string name
+;;; associated with anonymous functions.
+;;; So even though SBCL itself only uses this macro within this file,
+;;; it's a reasonable thing to put in SB-EXT in case some dedicated
+;;; user wants to do some heavy tweaking to make SBCL give more
+;;; informative output about his code.
+(defmacro def-source-context (name lambda-list &body body)
+ #!+sb-doc
+ "DEF-SOURCE-CONTEXT Name Lambda-List Form*
+ This macro defines how to extract an abbreviated source context from the
+ Named form when it appears in the compiler input. Lambda-List is a DEFMACRO
+ style lambda-list used to parse the arguments. The Body should return a
+ list of subforms suitable for a \"~{~S ~}\" format string."
+ (let ((n-whole (gensym)))
+ `(setf (gethash ',name *source-context-methods*)
+ #'(lambda (,n-whole)
+ (destructuring-bind ,lambda-list ,n-whole ,@body)))))
+
+(def-source-context defstruct (name-or-options &rest slots)
+ (declare (ignore slots))
+ `(defstruct ,(if (consp name-or-options)
+ (car name-or-options)
+ name-or-options)))
+
+(def-source-context function (thing)
+ (if (and (consp thing) (eq (first thing) 'lambda) (consp (rest thing)))
+ `(lambda ,(second thing))
+ `(function ,thing)))
+
+;;; Return the first two elements of FORM if FORM is a list. Take the
+;;; CAR of the second form if appropriate.
+(defun source-form-context (form)
+ (cond ((atom form) nil)
+ ((>= (length form) 2)
+ (funcall (gethash (first form) *source-context-methods*
+ #'(lambda (x)
+ (declare (ignore x))
+ (list (first form) (second form))))
+ (rest form)))
+ (t
+ form)))
+
+;;; Given a source path, return the original source form and a
+;;; description of the interesting aspects of the context in which it
+;;; appeared. The context is a list of lists, one sublist per context
+;;; form. The sublist is a list of some of the initial subforms of the
+;;; context form.
+;;;
+;;; For now, we use the first two subforms of each interesting form. A
+;;; form is interesting if the first element is a symbol beginning
+;;; with "DEF" and it is not the source form. If there is no
+;;; DEF-mumble, then we use the outermost containing form. If the
+;;; second subform is a list, then in some cases we return the CAR of
+;;; that form rather than the whole form (i.e. don't show DEFSTRUCT
+;;; options, etc.)
+(defun find-original-source (path)
+ (declare (list path))
+ (let* ((rpath (reverse (source-path-original-source path)))
+ (tlf (first rpath))
+ (root (find-source-root tlf *source-info*)))
+ (collect ((context))
+ (let ((form root)
+ (current (rest rpath)))
+ (loop
+ (when (atom form)
+ (aver (null current))
+ (return))
+ (let ((head (first form)))
+ (when (symbolp head)
+ (let ((name (symbol-name head)))
+ (when (and (>= (length name) 3) (string= name "DEF" :end1 3))
+ (context (source-form-context form))))))
+ (when (null current) (return))
+ (setq form (nth (pop current) form)))
+
+ (cond ((context)
+ (values form (context)))
+ ((and path root)
+ (let ((c (source-form-context root)))
+ (values form (if c (list c) nil))))
+ (t
+ (values '(unable to locate source)
+ '((some strange place)))))))))
+
+;;; Convert a source form to a string, suitably formatted for use in
+;;; compiler warnings.
+(defun stringify-form (form &optional (pretty t))
+ (let ((*print-level* *compiler-error-print-level*)
+ (*print-length* *compiler-error-print-length*)
+ (*print-lines* *compiler-error-print-lines*)
+ (*print-pretty* pretty))
+ (if pretty
+ (format nil "~<~@; ~S~:>" (list form))
+ (prin1-to-string form))))
+
+;;; Return a COMPILER-ERROR-CONTEXT structure describing the current
+;;; error context, or NIL if we can't figure anything out. ARGS is a
+;;; list of things that are going to be printed out in the error
+;;; message, and can thus be blown off when they appear in the source
+;;; context.
+(defun find-error-context (args)
+ (let ((context *compiler-error-context*))
+ (if (compiler-error-context-p context)
+ context
+ (let ((path (or (and (boundp '*current-path*) *current-path*)
+ (if context
+ (node-source-path context)
+ nil))))
+ (when (and *source-info* path)
+ (multiple-value-bind (form src-context) (find-original-source path)
+ (collect ((full nil cons)
+ (short nil cons))
+ (let ((forms (source-path-forms path))
+ (n 0))
+ (dolist (src (if (member (first forms) args)
+ (rest forms)
+ forms))
+ (if (>= n *enclosing-source-cutoff*)
+ (short (stringify-form (if (consp src)
+ (car src)
+ src)
+ nil))
+ (full (stringify-form src)))
+ (incf n)))
+
+ (let* ((tlf (source-path-tlf-number path))
+ (file-info (source-info-file-info *source-info*)))
+ (make-compiler-error-context
+ :enclosing-source (short)
+ :source (full)
+ :original-source (stringify-form form)
+ :context src-context
+ :file-name (file-info-name file-info)
+ :file-position
+ (multiple-value-bind (ignore pos)
+ (find-source-root tlf *source-info*)
+ (declare (ignore ignore))
+ pos)
+ :original-source-path
+ (source-path-original-source path))))))))))
+\f
+;;;; printing error messages
+
+;;; We save the context information that we printed out most recently
+;;; so that we don't print it out redundantly.
+
+;;; The last COMPILER-ERROR-CONTEXT that we printed.
+(defvar *last-error-context* nil)
+(declaim (type (or compiler-error-context null) *last-error-context*))
+
+;;; The format string and args for the last error we printed.
+(defvar *last-format-string* nil)
+(defvar *last-format-args* nil)
+(declaim (type (or string null) *last-format-string*))
+(declaim (type list *last-format-args*))
+
+;;; The number of times that the last error message has been emitted,
+;;; so that we can compress duplicate error messages.
+(defvar *last-message-count* 0)
+(declaim (type index *last-message-count*))
+
+;;; If the last message was given more than once, then print out an
+;;; indication of how many times it was repeated. We reset the message
+;;; count when we are done.
+(defun note-message-repeats (&optional (terpri t))
+ (cond ((= *last-message-count* 1)
+ (when terpri (terpri *error-output*)))
+ ((> *last-message-count* 1)
+ (format *error-output* "~&; [Last message occurs ~D times.]~2%"
+ *last-message-count*)))
+ (setq *last-message-count* 0))
+
+;;; Print out the message, with appropriate context if we can find it.
+;;; If the context is different from the context of the last message
+;;; we printed, then we print the context. If the original source is
+;;; different from the source we are working on, then we print the
+;;; current source in addition to the original source.
+;;;
+;;; We suppress printing of messages identical to the previous, but
+;;; record the number of times that the message is repeated.
+(defun print-compiler-message (format-string format-args)
+
+ (declare (type simple-string format-string))
+ (declare (type list format-args))
+
+ (let ((stream *error-output*)
+ (context (find-error-context format-args)))
+ (cond
+ (context
+ (let ((file (compiler-error-context-file-name context))
+ (in (compiler-error-context-context context))
+ (form (compiler-error-context-original-source context))
+ (enclosing (compiler-error-context-enclosing-source context))
+ (source (compiler-error-context-source context))
+ (last *last-error-context*))
+
+ (unless (and last
+ (equal file (compiler-error-context-file-name last)))
+ (when (pathnamep file)
+ (note-message-repeats)
+ (setq last nil)
+ (format stream "~2&; file: ~A~%" (namestring file))))
+
+ (unless (and last
+ (equal in (compiler-error-context-context last)))
+ (note-message-repeats)
+ (setq last nil)
+ (format stream "~&")
+ (pprint-logical-block (stream nil :per-line-prefix "; ")
+ (format stream "in:~{~<~% ~4:;~{ ~S~}~>~^ =>~}" in))
+ (format stream "~%"))
+
+
+ (unless (and last
+ (string= form
+ (compiler-error-context-original-source last)))
+ (note-message-repeats)
+ (setq last nil)
+ (format stream "~&")
+ (pprint-logical-block (stream nil :per-line-prefix "; ")
+ (format stream " ~A" form))
+ (format stream "~&"))
+
+ (unless (and last
+ (equal enclosing
+ (compiler-error-context-enclosing-source last)))
+ (when enclosing
+ (note-message-repeats)
+ (setq last nil)
+ (format stream "~&; --> ~{~<~%; --> ~1:;~A~> ~}~%" enclosing)))
+
+ (unless (and last
+ (equal source (compiler-error-context-source last)))
+ (setq *last-format-string* nil)
+ (when source
+ (note-message-repeats)
+ (dolist (src source)
+ (format stream "~&")
+ (write-string "; ==>" stream)
+ (format stream "~&")
+ (pprint-logical-block (stream nil :per-line-prefix "; ")
+ (write-string src stream)))))))
+ (t
+ (format stream "~&")
+ (note-message-repeats)
+ (setq *last-format-string* nil)
+ (format stream "~&")))
+
+ (setq *last-error-context* context)
+
+ (unless (and (equal format-string *last-format-string*)
+ (tree-equal format-args *last-format-args*))
+ (note-message-repeats nil)
+ (setq *last-format-string* format-string)
+ (setq *last-format-args* format-args)
+ (let ((*print-level* *compiler-error-print-level*)
+ (*print-length* *compiler-error-print-length*)
+ (*print-lines* *compiler-error-print-lines*))
+ (format stream "~&")
+ (pprint-logical-block (stream nil :per-line-prefix "; ")
+ (format stream "~&~?" format-string format-args))
+ (format stream "~&"))))
+
+ (incf *last-message-count*)
+ (values))
+
+(defun print-compiler-condition (condition)
+ (declare (type condition condition))
+ (let (;; These different classes of conditions have different
+ ;; effects on the return codes of COMPILE-FILE, so it's nice
+ ;; for users to be able to pick them out by lexical search
+ ;; through the output.
+ (what (etypecase condition
+ (style-warning 'style-warning)
+ (warning 'warning)
+ (error 'error))))
+ (multiple-value-bind (format-string format-args)
+ (if (typep condition 'simple-condition)
+ (values (simple-condition-format-control condition)
+ (simple-condition-format-arguments condition))
+ (values "~A"
+ (list (with-output-to-string (s)
+ (princ condition s)))))
+ (print-compiler-message (format nil
+ "caught ~S:~% ~A"
+ what
+ format-string)
+ format-args)))
+ (values))
+
+;;; COMPILER-NOTE is vaguely like COMPILER-ERROR and the other
+;;; condition-signalling functions, but it just writes some output
+;;; instead of signalling. (In CMU CL, it did signal a condition, but
+;;; this didn't seem to work all that well; it was weird to have
+;;; COMPILE-FILE return with WARNINGS-P set when the only problem was
+;;; that the compiler couldn't figure out how to compile something as
+;;; efficiently as it liked.)
+(defun compiler-note (format-string &rest format-args)
+ (unless (if *compiler-error-context*
+ (policy *compiler-error-context* (= inhibit-warnings 3))
+ (policy *lexenv* (= inhibit-warnings 3)))
+ (incf *compiler-note-count*)
+ (print-compiler-message (format nil "note: ~A" format-string)
+ format-args))
+ (values))
+
+;;; Issue a note when we might or might not be in the compiler.
+(defun maybe-compiler-note (&rest rest)
+ (if (boundp '*lexenv*) ; if we're in the compiler
+ (apply #'compiler-note rest)
+ (let ((stream *error-output*))
+ (pprint-logical-block (stream nil :per-line-prefix ";")
+
+ (format stream " note: ~3I~_")
+ (pprint-logical-block (stream nil)
+ (apply #'format stream rest)))
+ (fresh-line stream)))) ; (outside logical block, no per-line-prefix)
+
+;;; The politically correct way to print out progress messages and
+;;; such like. We clear the current error context so that we know that
+;;; it needs to be reprinted, and we also Force-Output so that the
+;;; message gets seen right away.
+(declaim (ftype (function (string &rest t) (values)) compiler-mumble))
+(defun compiler-mumble (format-string &rest format-args)
+ (note-message-repeats)
+ (setq *last-error-context* nil)
+ (apply #'format *error-output* format-string format-args)
+ (force-output *error-output*)
+ (values))
+
+;;; Return a string that somehow names the code in COMPONENT. We use
+;;; the source path for the bind node for an arbitrary entry point to
+;;; find the source context, then return that as a string.
+(declaim (ftype (function (component) simple-string) find-component-name))
+(defun find-component-name (component)
+ (let ((ep (first (block-succ (component-head component)))))
+ (aver ep) ; else no entry points??
+ (multiple-value-bind (form context)
+ (find-original-source
+ (node-source-path (continuation-next (block-start ep))))
+ (declare (ignore form))
+ (let ((*print-level* 2)
+ (*print-pretty* nil))
+ (format nil "~{~{~S~^ ~}~^ => ~}" context)))))
+\f
+;;;; condition system interface
+
+;;; Keep track of how many times each kind of condition happens.
+(defvar *compiler-error-count*)
+(defvar *compiler-warning-count*)
+(defvar *compiler-style-warning-count*)
+(defvar *compiler-note-count*)
+
+;;; Keep track of whether any surrounding COMPILE or COMPILE-FILE call
+;;; should return WARNINGS-P or FAILURE-P.
+(defvar *failure-p*)
+(defvar *warnings-p*)
+
+;;; condition handlers established by the compiler. We re-signal the
+;;; condition, then if it isn't handled, we increment our warning
+;;; counter and print the error message.
+(defun compiler-error-handler (condition)
+ (signal condition)
+ (incf *compiler-error-count*)
+ (setf *warnings-p* t
+ *failure-p* t)
+ (print-compiler-condition condition)
+ (continue condition))
+(defun compiler-warning-handler (condition)
+ (signal condition)
+ (incf *compiler-warning-count*)
+ (setf *warnings-p* t
+ *failure-p* t)
+ (print-compiler-condition condition)
+ (muffle-warning condition))
+(defun compiler-style-warning-handler (condition)
+ (signal condition)
+ (incf *compiler-style-warning-count*)
+ (setf *warnings-p* t)
+ (print-compiler-condition condition)
+ (muffle-warning condition))
+\f
+;;;; undefined warnings
+
+(defvar *undefined-warning-limit* 3
+ #!+sb-doc
+ "If non-null, then an upper limit on the number of unknown function or type
+ warnings that the compiler will print for any given name in a single
+ compilation. This prevents excessive amounts of output when the real
+ problem is a missing definition (as opposed to a typo in the use.)")
+
+;;; Make an entry in the *UNDEFINED-WARNINGS* describing a reference
+;;; to NAME of the specified KIND. If we have exceeded the warning
+;;; limit, then just increment the count, otherwise note the current
+;;; error context.
+;;;
+;;; Undefined types are noted by a condition handler in
+;;; WITH-COMPILATION-UNIT, which can potentially be invoked outside
+;;; the compiler, hence the BOUNDP check.
+(defun note-undefined-reference (name kind)
+ (unless (and
+ ;; Check for boundness so we don't blow up if we're called
+ ;; when IR1 conversion isn't going on.
+ (boundp '*lexenv*)
+ ;; FIXME: I'm pretty sure the INHIBIT-WARNINGS test below
+ ;; isn't a good idea; we should have INHIBIT-WARNINGS
+ ;; affect compiler notes, not STYLE-WARNINGs. And I'm not
+ ;; sure what the BOUNDP '*LEXENV* test above is for; it's
+ ;; likely a good idea, but it probably deserves an
+ ;; explanatory comment.
+ (policy *lexenv* (= inhibit-warnings 3)))
+ (let* ((found (dolist (warning *undefined-warnings* nil)
+ (when (and (equal (undefined-warning-name warning) name)
+ (eq (undefined-warning-kind warning) kind))
+ (return warning))))
+ (res (or found
+ (make-undefined-warning :name name :kind kind))))
+ (unless found (push res *undefined-warnings*))
+ (when (or (not *undefined-warning-limit*)
+ (< (undefined-warning-count res) *undefined-warning-limit*))
+ (push (find-error-context (list name))
+ (undefined-warning-warnings res)))
+ (incf (undefined-warning-count res))))
+ (values))
(declaim (hash-table *source-paths*))
(defvar *source-paths*)
-;;; *CURRENT-COMPONENT* is the Component structure which we link
+;;; *CURRENT-COMPONENT* is the COMPONENT structure which we link
;;; blocks into as we generate them. This just serves to glue the
;;; emitted blocks together until local call analysis and flow graph
;;; canonicalization figure out what is really going on. We need to
(setf (leaf-name res) name)
res))))
\f
-;;; FIXME: This file is rather long, and contains two distinct sections,
-;;; transform machinery above this point and transforms themselves below this
-;;; point. Why not split it in two? (ir1translate.lisp and
-;;; ir1translators.lisp?) Then consider byte-compiling the translators, too.
-\f
-;;;; control special forms
-
-(def-ir1-translator progn ((&rest forms) start cont)
- #!+sb-doc
- "Progn Form*
- Evaluates each Form in order, returning the values of the last form. With no
- forms, returns NIL."
- (ir1-convert-progn-body start cont forms))
-
-(def-ir1-translator if ((test then &optional else) start cont)
- #!+sb-doc
- "If Predicate Then [Else]
- If Predicate evaluates to non-null, evaluate Then and returns its values,
- otherwise evaluate Else and return its values. Else defaults to NIL."
- (let* ((pred (make-continuation))
- (then-cont (make-continuation))
- (then-block (continuation-starts-block then-cont))
- (else-cont (make-continuation))
- (else-block (continuation-starts-block else-cont))
- (dummy-cont (make-continuation))
- (node (make-if :test pred
- :consequent then-block
- :alternative else-block)))
- (setf (continuation-dest pred) node)
- (ir1-convert start pred test)
- (prev-link node pred)
- (use-continuation node dummy-cont)
-
- (let ((start-block (continuation-block pred)))
- (setf (block-last start-block) node)
- (continuation-starts-block cont)
-
- (link-blocks start-block then-block)
- (link-blocks start-block else-block)
-
- (ir1-convert then-cont cont then)
- (ir1-convert else-cont cont else))))
-\f
-;;;; BLOCK and TAGBODY
-
-;;;; We make an Entry node to mark the start and a :Entry cleanup to
-;;;; mark its extent. When doing GO or RETURN-FROM, we emit an Exit
-;;;; node.
-
-;;; Make a :ENTRY cleanup and emit an ENTRY node, then convert the
-;;; body in the modified environment. We make CONT start a block now,
-;;; since if it was done later, the block would be in the wrong
-;;; environment.
-(def-ir1-translator block ((name &rest forms) start cont)
- #!+sb-doc
- "Block Name Form*
- Evaluate the Forms as a PROGN. Within the lexical scope of the body,
- (RETURN-FROM Name Value-Form) can be used to exit the form, returning the
- result of Value-Form."
- (unless (symbolp name)
- (compiler-error "The block name ~S is not a symbol." name))
- (continuation-starts-block cont)
- (let* ((dummy (make-continuation))
- (entry (make-entry))
- (cleanup (make-cleanup :kind :block
- :mess-up entry)))
- (push entry (lambda-entries (lexenv-lambda *lexenv*)))
- (setf (entry-cleanup entry) cleanup)
- (prev-link entry start)
- (use-continuation entry dummy)
-
- (let* ((env-entry (list entry cont))
- (*lexenv* (make-lexenv :blocks (list (cons name env-entry))
- :cleanup cleanup)))
- (push env-entry (continuation-lexenv-uses cont))
- (ir1-convert-progn-body dummy cont forms))))
-
-
-;;; We make CONT start a block just so that it will have a block
-;;; assigned. People assume that when they pass a continuation into
-;;; IR1-CONVERT as CONT, it will have a block when it is done.
-(def-ir1-translator return-from ((name &optional value)
- start cont)
- #!+sb-doc
- "Return-From Block-Name Value-Form
- Evaluate the Value-Form, returning its values from the lexically enclosing
- BLOCK Block-Name. This is constrained to be used only within the dynamic
- extent of the BLOCK."
- (continuation-starts-block cont)
- (let* ((found (or (lexenv-find name blocks)
- (compiler-error "return for unknown block: ~S" name)))
- (value-cont (make-continuation))
- (entry (first found))
- (exit (make-exit :entry entry
- :value value-cont)))
- (push exit (entry-exits entry))
- (setf (continuation-dest value-cont) exit)
- (ir1-convert start value-cont value)
- (prev-link exit value-cont)
- (use-continuation exit (second found))))
-
-;;; Return a list of the segments of a TAGBODY. Each segment looks
-;;; like (<tag> <form>* (go <next tag>)). That is, we break up the
-;;; tagbody into segments of non-tag statements, and explicitly
-;;; represent the drop-through with a GO. The first segment has a
-;;; dummy NIL tag, since it represents code before the first tag. The
-;;; last segment (which may also be the first segment) ends in NIL
-;;; rather than a GO.
-(defun parse-tagbody (body)
- (declare (list body))
- (collect ((segments))
- (let ((current (cons nil body)))
- (loop
- (let ((tag-pos (position-if (complement #'listp) current :start 1)))
- (unless tag-pos
- (segments `(,@current nil))
- (return))
- (let ((tag (elt current tag-pos)))
- (when (assoc tag (segments))
- (compiler-error
- "The tag ~S appears more than once in the tagbody."
- tag))
- (unless (or (symbolp tag) (integerp tag))
- (compiler-error "~S is not a legal tagbody statement." tag))
- (segments `(,@(subseq current 0 tag-pos) (go ,tag))))
- (setq current (nthcdr tag-pos current)))))
- (segments)))
-
-;;; Set up the cleanup, emitting the entry node. Then make a block for
-;;; each tag, building up the tag list for LEXENV-TAGS as we go.
-;;; Finally, convert each segment with the precomputed Start and Cont
-;;; values.
-(def-ir1-translator tagbody ((&rest statements) start cont)
- #!+sb-doc
- "Tagbody {Tag | Statement}*
- Define tags for used with GO. The Statements are evaluated in order
- (skipping Tags) and NIL is returned. If a statement contains a GO to a
- defined Tag within the lexical scope of the form, then control is transferred
- to the next statement following that tag. A Tag must an integer or a
- symbol. A statement must be a list. Other objects are illegal within the
- body."
- (continuation-starts-block cont)
- (let* ((dummy (make-continuation))
- (entry (make-entry))
- (segments (parse-tagbody statements))
- (cleanup (make-cleanup :kind :tagbody
- :mess-up entry)))
- (push entry (lambda-entries (lexenv-lambda *lexenv*)))
- (setf (entry-cleanup entry) cleanup)
- (prev-link entry start)
- (use-continuation entry dummy)
-
- (collect ((tags)
- (starts)
- (conts))
- (starts dummy)
- (dolist (segment (rest segments))
- (let* ((tag-cont (make-continuation))
- (tag (list (car segment) entry tag-cont)))
- (conts tag-cont)
- (starts tag-cont)
- (continuation-starts-block tag-cont)
- (tags tag)
- (push (cdr tag) (continuation-lexenv-uses tag-cont))))
- (conts cont)
-
- (let ((*lexenv* (make-lexenv :cleanup cleanup :tags (tags))))
- (mapc (lambda (segment start cont)
- (ir1-convert-progn-body start cont (rest segment)))
- segments (starts) (conts))))))
-
-;;; Emit an EXIT node without any value.
-(def-ir1-translator go ((tag) start cont)
- #!+sb-doc
- "Go Tag
- Transfer control to the named Tag in the lexically enclosing TAGBODY. This
- is constrained to be used only within the dynamic extent of the TAGBODY."
- (continuation-starts-block cont)
- (let* ((found (or (lexenv-find tag tags :test #'eql)
- (compiler-error "Go to nonexistent tag: ~S." tag)))
- (entry (first found))
- (exit (make-exit :entry entry)))
- (push exit (entry-exits entry))
- (prev-link exit start)
- (use-continuation exit (second found))))
-\f
-;;;; translators for compiler-magic special forms
-
-;;; This handles EVAL-WHEN in non-top-level forms. (EVAL-WHENs in
-;;; top-level forms are picked off and handled by PROCESS-TOP-LEVEL-FORM,
-;;; so that they're never seen at this level.)
-;;;
-;;; ANSI "3.2.3.1 Processing of Top Level Forms" says that processing
-;;; of non-top-level EVAL-WHENs is very simple:
-;;; EVAL-WHEN forms cause compile-time evaluation only at top level.
-;;; Both :COMPILE-TOPLEVEL and :LOAD-TOPLEVEL situation specifications
-;;; are ignored for non-top-level forms. For non-top-level forms, an
-;;; eval-when specifying the :EXECUTE situation is treated as an
-;;; implicit PROGN including the forms in the body of the EVAL-WHEN
-;;; form; otherwise, the forms in the body are ignored.
-(def-ir1-translator eval-when ((situations &rest forms) start cont)
- #!+sb-doc
- "EVAL-WHEN (Situation*) Form*
- Evaluate the Forms in the specified Situations (any of :COMPILE-TOPLEVEL,
- :LOAD-TOPLEVEL, or :EXECUTE, or (deprecated) COMPILE, LOAD, or EVAL)."
- (multiple-value-bind (ct lt e) (parse-eval-when-situations situations)
- (declare (ignore ct lt))
- (ir1-convert-progn-body start cont (and e forms)))
- (values))
-
-;;; common logic for MACROLET and SYMBOL-MACROLET
-;;;
-;;; Call DEFINITIONIZE-FUN on each element of DEFINITIONS to find its
-;;; in-lexenv representation, stuff the results into *LEXENV*, and
-;;; call FUN (with no arguments).
-(defun %funcall-in-foomacrolet-lexenv (definitionize-fun
- definitionize-keyword
- definitions
- fun)
- (declare (type function definitionize-fun fun))
- (declare (type (member :variables :functions) definitionize-keyword))
- (declare (type list definitions))
- (unless (= (length definitions)
- (length (remove-duplicates definitions :key #'first)))
- (compiler-style-warning "duplicate definitions in ~S" definitions))
- (let* ((processed-definitions (mapcar definitionize-fun definitions))
- (*lexenv* (make-lexenv definitionize-keyword processed-definitions)))
- (funcall fun)))
-
-;;; Tweak *LEXENV* to include the DEFINITIONS from a MACROLET, then
-;;; call FUN (with no arguments).
-;;;
-;;; This is split off from the IR1 convert method so that it can be
-;;; shared by the special-case top-level MACROLET processing code.
-(defun funcall-in-macrolet-lexenv (definitions fun)
- (%funcall-in-foomacrolet-lexenv
- (lambda (definition)
- (unless (list-of-length-at-least-p definition 2)
- (compiler-error
- "The list ~S is too short to be a legal local macro definition."
- definition))
- (destructuring-bind (name arglist &body body) definition
- (unless (symbolp name)
- (compiler-error "The local macro name ~S is not a symbol." name))
- (let ((whole (gensym "WHOLE"))
- (environment (gensym "ENVIRONMENT")))
- (multiple-value-bind (body local-decls)
- (parse-defmacro arglist whole body name 'macrolet
- :environment environment)
- `(,name macro .
- ,(compile nil
- `(lambda (,whole ,environment)
- ,@local-decls
- (block ,name ,body))))))))
- :functions
- definitions
- fun))
-
-(def-ir1-translator macrolet ((definitions &rest body) start cont)
- #!+sb-doc
- "MACROLET ({(Name Lambda-List Form*)}*) Body-Form*
- Evaluate the Body-Forms in an environment with the specified local macros
- defined. Name is the local macro name, Lambda-List is the DEFMACRO style
- destructuring lambda list, and the Forms evaluate to the expansion. The
- Forms are evaluated in the null environment."
- (funcall-in-macrolet-lexenv definitions
- (lambda ()
- (ir1-translate-locally body start cont))))
-
-(defun funcall-in-symbol-macrolet-lexenv (definitions fun)
- (%funcall-in-foomacrolet-lexenv
- (lambda (definition)
- (unless (proper-list-of-length-p definition 2)
- (compiler-error "malformed symbol/expansion pair: ~S" definition))
- (destructuring-bind (name expansion) definition
- (unless (symbolp name)
- (compiler-error
- "The local symbol macro name ~S is not a symbol."
- name))
- `(,name . (MACRO . ,expansion))))
- :variables
- definitions
- fun))
-
-(def-ir1-translator symbol-macrolet ((macrobindings &body body) start cont)
- #!+sb-doc
- "SYMBOL-MACROLET ({(Name Expansion)}*) Decl* Form*
- Define the Names as symbol macros with the given Expansions. Within the
- body, references to a Name will effectively be replaced with the Expansion."
- (funcall-in-symbol-macrolet-lexenv
- macrobindings
- (lambda ()
- (ir1-translate-locally body start cont))))
-
-;;; not really a special form, but..
-(def-ir1-translator declare ((&rest stuff) start cont)
- (declare (ignore stuff))
- ;; We ignore START and CONT too, but we can't use DECLARE IGNORE to
- ;; tell the compiler about it here, because the DEF-IR1-TRANSLATOR
- ;; macro would put the DECLARE in the wrong place, so..
- start cont
- (compiler-error "misplaced declaration"))
-\f
-;;;; %PRIMITIVE
-;;;;
-;;;; Uses of %PRIMITIVE are either expanded into Lisp code or turned
-;;;; into a funny function.
-
-;;; Carefully evaluate a list of forms, returning a list of the results.
-(defun eval-info-args (args)
- (declare (list args))
- (handler-case (mapcar #'eval args)
- (error (condition)
- (compiler-error "Lisp error during evaluation of info args:~%~A"
- condition))))
-
-;;; If there is a primitive translator, then we expand the call.
-;;; Otherwise, we convert to the %%PRIMITIVE funny function. The first
-;;; argument is the template, the second is a list of the results of
-;;; any codegen-info args, and the remaining arguments are the runtime
-;;; arguments.
-;;;
-;;; We do a bunch of error checking now so that we don't bomb out with
-;;; a fatal error during IR2 conversion.
-;;;
-;;; KLUDGE: It's confusing having multiple names floating around for
-;;; nearly the same concept: PRIMITIVE, TEMPLATE, VOP. Now that CMU
-;;; CL's *PRIMITIVE-TRANSLATORS* stuff is gone, we could call
-;;; primitives VOPs, rename TEMPLATE to VOP-TEMPLATE, rename
-;;; BACKEND-TEMPLATE-NAMES to BACKEND-VOPS, and rename %PRIMITIVE to
-;;; VOP or %VOP.. -- WHN 2001-06-11
-;;; FIXME: Look at doing this ^, it doesn't look too hard actually.
-(def-ir1-translator %primitive ((name &rest args) start cont)
- (unless (symbolp name)
- (compiler-error "The primitive name ~S is not a symbol." name))
-
- (let* ((template (or (gethash name *backend-template-names*)
- (compiler-error
- "The primitive name ~A is not defined."
- name)))
- (required (length (template-arg-types template)))
- (info (template-info-arg-count template))
- (min (+ required info))
- (nargs (length args)))
- (if (template-more-args-type template)
- (when (< nargs min)
- (compiler-error "Primitive ~A was called with ~R argument~:P, ~
- but wants at least ~R."
- name
- nargs
- min))
- (unless (= nargs min)
- (compiler-error "Primitive ~A was called with ~R argument~:P, ~
- but wants exactly ~R."
- name
- nargs
- min)))
-
- (when (eq (template-result-types template) :conditional)
- (compiler-error
- "%PRIMITIVE was used with a conditional template."))
-
- (when (template-more-results-type template)
- (compiler-error
- "%PRIMITIVE was used with an unknown values template."))
-
- (ir1-convert start
- cont
- `(%%primitive ',template
- ',(eval-info-args
- (subseq args required min))
- ,@(subseq args 0 required)
- ,@(subseq args min)))))
-\f
-;;;; QUOTE and FUNCTION
-
-(def-ir1-translator quote ((thing) start cont)
- #!+sb-doc
- "QUOTE Value
- Return Value without evaluating it."
- (reference-constant start cont thing))
-
-(def-ir1-translator function ((thing) start cont)
- #!+sb-doc
- "FUNCTION Name
- Return the lexically apparent definition of the function Name. Name may also
- be a lambda."
- (if (consp thing)
- (case (car thing)
- ((lambda)
- (reference-leaf start cont (ir1-convert-lambda thing)))
- ((setf)
- (let ((var (find-lexically-apparent-function
- thing "as the argument to FUNCTION")))
- (reference-leaf start cont var)))
- ((instance-lambda)
- (let ((res (ir1-convert-lambda `(lambda ,@(cdr thing)))))
- (setf (getf (functional-plist res) :fin-function) t)
- (reference-leaf start cont res)))
- (t
- (compiler-error "~S is not a legal function name." thing)))
- (let ((var (find-lexically-apparent-function
- thing "as the argument to FUNCTION")))
- (reference-leaf start cont var))))
-\f
-;;;; FUNCALL
-
-;;; FUNCALL is implemented on %FUNCALL, which can only call functions
-;;; (not symbols). %FUNCALL is used directly in some places where the
-;;; call should always be open-coded even if FUNCALL is :NOTINLINE.
-(deftransform funcall ((function &rest args) * * :when :both)
- (let ((arg-names (make-gensym-list (length args))))
- `(lambda (function ,@arg-names)
- (%funcall ,(if (csubtypep (continuation-type function)
- (specifier-type 'function))
- 'function
- '(%coerce-callable-to-function function))
- ,@arg-names))))
-
-(def-ir1-translator %funcall ((function &rest args) start cont)
- (let ((fun-cont (make-continuation)))
- (ir1-convert start fun-cont function)
- (assert-continuation-type fun-cont (specifier-type 'function))
- (ir1-convert-combination-args fun-cont cont args)))
-
-;;; This source transform exists to reduce the amount of work for the
-;;; compiler. If the called function is a FUNCTION form, then convert
-;;; directly to %FUNCALL, instead of waiting around for type
-;;; inference.
-(def-source-transform funcall (function &rest args)
- (if (and (consp function) (eq (car function) 'function))
- `(%funcall ,function ,@args)
- (values nil t)))
-
-(deftransform %coerce-callable-to-function ((thing) (function) *
- :when :both
- :important t)
- "optimize away possible call to FDEFINITION at runtime"
- 'thing)
-\f
-;;;; LET and LET*
-;;;;
-;;;; (LET and LET* can't be implemented as macros due to the fact that
-;;;; any pervasive declarations also affect the evaluation of the
-;;;; arguments.)
-
-;;; Given a list of binding specifiers in the style of Let, return:
-;;; 1. The list of var structures for the variables bound.
-;;; 2. The initial value form for each variable.
-;;;
-;;; The variable names are checked for legality and globally special
-;;; variables are marked as such. Context is the name of the form, for
-;;; error reporting purposes.
-(declaim (ftype (function (list symbol) (values list list list))
- extract-let-variables))
-(defun extract-let-variables (bindings context)
- (collect ((vars)
- (vals)
- (names))
- (flet ((get-var (name)
- (varify-lambda-arg name
- (if (eq context 'let*)
- nil
- (names)))))
- (dolist (spec bindings)
- (cond ((atom spec)
- (let ((var (get-var spec)))
- (vars var)
- (names (cons spec var))
- (vals nil)))
- (t
- (unless (proper-list-of-length-p spec 1 2)
- (compiler-error "The ~S binding spec ~S is malformed."
- context
- spec))
- (let* ((name (first spec))
- (var (get-var name)))
- (vars var)
- (names name)
- (vals (second spec)))))))
-
- (values (vars) (vals) (names))))
-
-(def-ir1-translator let ((bindings &body body)
- start cont)
- #!+sb-doc
- "LET ({(Var [Value]) | Var}*) Declaration* Form*
- During evaluation of the Forms, bind the Vars to the result of evaluating the
- Value forms. The variables are bound in parallel after all of the Values are
- evaluated."
- (multiple-value-bind (forms decls) (sb!sys:parse-body body nil)
- (multiple-value-bind (vars values) (extract-let-variables bindings 'let)
- (let* ((*lexenv* (process-decls decls vars nil cont))
- (fun-cont (make-continuation))
- (fun (ir1-convert-lambda-body forms vars)))
- (reference-leaf start fun-cont fun)
- (ir1-convert-combination-args fun-cont cont values)))))
-
-(def-ir1-translator let* ((bindings &body body)
- start cont)
- #!+sb-doc
- "LET* ({(Var [Value]) | Var}*) Declaration* Form*
- Similar to LET, but the variables are bound sequentially, allowing each Value
- form to reference any of the previous Vars."
- (multiple-value-bind (forms decls) (sb!sys:parse-body body nil)
- (multiple-value-bind (vars values) (extract-let-variables bindings 'let*)
- (let ((*lexenv* (process-decls decls vars nil cont)))
- (ir1-convert-aux-bindings start cont forms vars values)))))
-
-;;; logic shared between IR1 translators for LOCALLY, MACROLET,
-;;; and SYMBOL-MACROLET
-;;;
-;;; Note that all these things need to preserve top-level-formness,
-;;; but we don't need to worry about that within an IR1 translator,
-;;; since top-level-formness is picked off by PROCESS-TOP-LEVEL-FOO
-;;; forms before we hit the IR1 transform level.
-(defun ir1-translate-locally (body start cont)
- (declare (type list body) (type continuation start cont))
- (multiple-value-bind (forms decls) (sb!sys:parse-body body nil)
- (let ((*lexenv* (process-decls decls nil nil cont)))
- (ir1-convert-aux-bindings start cont forms nil nil))))
-
-(def-ir1-translator locally ((&body body) start cont)
- #!+sb-doc
- "LOCALLY Declaration* Form*
- Sequentially evaluate the Forms in a lexical environment where the
- the Declarations have effect. If LOCALLY is a top-level form, then
- the Forms are also processed as top-level forms."
- (ir1-translate-locally body start cont))
-\f
-;;;; FLET and LABELS
-
-;;; Given a list of local function specifications in the style of
-;;; FLET, return lists of the function names and of the lambdas which
-;;; are their definitions.
-;;;
-;;; The function names are checked for legality. CONTEXT is the name
-;;; of the form, for error reporting.
-(declaim (ftype (function (list symbol) (values list list))
- extract-flet-variables))
-(defun extract-flet-variables (definitions context)
- (collect ((names)
- (defs))
- (dolist (def definitions)
- (when (or (atom def) (< (length def) 2))
- (compiler-error "The ~S definition spec ~S is malformed." context def))
-
- (let ((name (check-function-name (first def))))
- (names name)
- (multiple-value-bind (forms decls) (sb!sys:parse-body (cddr def))
- (defs `(lambda ,(second def)
- ,@decls
- (block ,(function-name-block-name name)
- . ,forms))))))
- (values (names) (defs))))
-
-(def-ir1-translator flet ((definitions &body body)
- start cont)
- #!+sb-doc
- "FLET ({(Name Lambda-List Declaration* Form*)}*) Declaration* Body-Form*
- Evaluate the Body-Forms with some local function definitions. The bindings
- do not enclose the definitions; any use of Name in the Forms will refer to
- the lexically apparent function definition in the enclosing environment."
- (multiple-value-bind (forms decls) (sb!sys:parse-body body nil)
- (multiple-value-bind (names defs)
- (extract-flet-variables definitions 'flet)
- (let* ((fvars (mapcar (lambda (n d)
- (ir1-convert-lambda d n))
- names defs))
- (*lexenv* (make-lexenv
- :default (process-decls decls nil fvars cont)
- :functions (pairlis names fvars))))
- (ir1-convert-progn-body start cont forms)))))
-
-;;; For LABELS, we have to create dummy function vars and add them to
-;;; the function namespace while converting the functions. We then
-;;; modify all the references to these leaves so that they point to
-;;; the real functional leaves. We also backpatch the FENV so that if
-;;; the lexical environment is used for inline expansion we will get
-;;; the right functions.
-(def-ir1-translator labels ((definitions &body body) start cont)
- #!+sb-doc
- "LABELS ({(Name Lambda-List Declaration* Form*)}*) Declaration* Body-Form*
- Evaluate the Body-Forms with some local function definitions. The bindings
- enclose the new definitions, so the defined functions can call themselves or
- each other."
- (multiple-value-bind (forms decls) (sb!sys:parse-body body nil)
- (multiple-value-bind (names defs)
- (extract-flet-variables definitions 'labels)
- (let* ((new-fenv (loop for name in names
- collect (cons name (make-functional :name name))))
- (real-funs
- (let ((*lexenv* (make-lexenv :functions new-fenv)))
- (mapcar (lambda (n d)
- (ir1-convert-lambda d n))
- names defs))))
-
- (loop for real in real-funs and env in new-fenv do
- (let ((dum (cdr env)))
- (substitute-leaf real dum)
- (setf (cdr env) real)))
-
- (let ((*lexenv* (make-lexenv
- :default (process-decls decls nil real-funs cont)
- :functions (pairlis names real-funs))))
- (ir1-convert-progn-body start cont forms))))))
-\f
-;;;; THE
-
-;;; Do stuff to recognize a THE or VALUES declaration. CONT is the
-;;; continuation that the assertion applies to, TYPE is the type
-;;; specifier and Lexenv is the current lexical environment. NAME is
-;;; the name of the declaration we are doing, for use in error
-;;; messages.
-;;;
-;;; This is somewhat involved, since a type assertion may only be made
-;;; on a continuation, not on a node. We can't just set the
-;;; continuation asserted type and let it go at that, since there may
-;;; be parallel THE's for the same continuation, i.e.:
-;;; (if ...
-;;; (the foo ...)
-;;; (the bar ...))
-;;;
-;;; In this case, our representation can do no better than the union
-;;; of these assertions. And if there is a branch with no assertion,
-;;; we have nothing at all. We really need to recognize scoping, since
-;;; we need to be able to discern between parallel assertions (which
-;;; we union) and nested ones (which we intersect).
-;;;
-;;; We represent the scoping by throwing our innermost (intersected)
-;;; assertion on CONT into the TYPE-RESTRICTIONS. As we go down, we
-;;; intersect our assertions together. If CONT has no uses yet, we
-;;; have not yet bottomed out on the first COND branch; in this case
-;;; we optimistically assume that this type will be the one we end up
-;;; with, and set the ASSERTED-TYPE to it. We can never get better
-;;; than the type that we have the first time we bottom out. Later
-;;; THE's (or the absence thereof) can only weaken this result.
-;;;
-;;; We make this work by getting USE-CONTINUATION to do the unioning
-;;; across COND branches. We can't do it here, since we don't know how
-;;; many branches there are going to be.
-(defun do-the-stuff (type cont lexenv name)
- (declare (type continuation cont) (type lexenv lexenv))
- (let* ((ctype (values-specifier-type type))
- (old-type (or (lexenv-find cont type-restrictions)
- *wild-type*))
- (intersects (values-types-equal-or-intersect old-type ctype))
- (int (values-type-intersection old-type ctype))
- (new (if intersects int old-type)))
- (when (null (find-uses cont))
- (setf (continuation-asserted-type cont) new))
- (when (and (not intersects)
- (not (policy *lexenv*
- (= inhibit-warnings 3)))) ;FIXME: really OK to suppress?
- (compiler-warning
- "The type ~S in ~S declaration conflicts with an enclosing assertion:~% ~S"
- (type-specifier ctype)
- name
- (type-specifier old-type)))
- (make-lexenv :type-restrictions `((,cont . ,new))
- :default lexenv)))
-
-;;; Assert that FORM evaluates to the specified type (which may be a
-;;; VALUES type).
-;;;
-;;; FIXME: In a version of CMU CL that I used at Cadabra ca. 20000101,
-;;; this didn't seem to expand into an assertion, at least for ALIEN
-;;; values. Check that SBCL doesn't have this problem.
-(def-ir1-translator the ((type value) start cont)
- (let ((*lexenv* (do-the-stuff type cont *lexenv* 'the)))
- (ir1-convert start cont value)))
-
-;;; This is like the THE special form, except that it believes
-;;; whatever you tell it. It will never generate a type check, but
-;;; will cause a warning if the compiler can prove the assertion is
-;;; wrong.
-;;;
-;;; Since the CONTINUATION-DERIVED-TYPE is computed as the union of
-;;; its uses's types, setting it won't work. Instead we must intersect
-;;; the type with the uses's DERIVED-TYPE.
-(def-ir1-translator truly-the ((type value) start cont)
- #!+sb-doc
- (declare (inline member))
- (let ((type (values-specifier-type type))
- (old (find-uses cont)))
- (ir1-convert start cont value)
- (do-uses (use cont)
- (unless (member use old :test #'eq)
- (derive-node-type use type)))))
-\f
-;;;; SETQ
-
-;;; If there is a definition in LEXENV-VARIABLES, just set that,
-;;; otherwise look at the global information. If the name is for a
-;;; constant, then error out.
-(def-ir1-translator setq ((&whole source &rest things) start cont)
- (let ((len (length things)))
- (when (oddp len)
- (compiler-error "odd number of args to SETQ: ~S" source))
- (if (= len 2)
- (let* ((name (first things))
- (leaf (or (lexenv-find name variables)
- (find-free-variable name))))
- (etypecase leaf
- (leaf
- (when (or (constant-p leaf)
- (and (global-var-p leaf)
- (eq (global-var-kind leaf) :constant)))
- (compiler-error "~S is a constant and thus can't be set." name))
- (when (and (lambda-var-p leaf)
- (lambda-var-ignorep leaf))
- ;; ANSI's definition of "Declaration IGNORE, IGNORABLE"
- ;; requires that this be a STYLE-WARNING, not a full warning.
- (compiler-style-warning
- "~S is being set even though it was declared to be ignored."
- name))
- (set-variable start cont leaf (second things)))
- (cons
- (aver (eq (car leaf) 'MACRO))
- (ir1-convert start cont `(setf ,(cdr leaf) ,(second things))))
- (heap-alien-info
- (ir1-convert start cont
- `(%set-heap-alien ',leaf ,(second things))))))
- (collect ((sets))
- (do ((thing things (cddr thing)))
- ((endp thing)
- (ir1-convert-progn-body start cont (sets)))
- (sets `(setq ,(first thing) ,(second thing))))))))
-
-;;; This is kind of like REFERENCE-LEAF, but we generate a SET node.
-;;; This should only need to be called in SETQ.
-(defun set-variable (start cont var value)
- (declare (type continuation start cont) (type basic-var var))
- (let ((dest (make-continuation)))
- (setf (continuation-asserted-type dest) (leaf-type var))
- (ir1-convert start dest value)
- (let ((res (make-set :var var :value dest)))
- (setf (continuation-dest dest) res)
- (setf (leaf-ever-used var) t)
- (push res (basic-var-sets var))
- (prev-link res dest)
- (use-continuation res cont))))
-\f
-;;;; CATCH, THROW and UNWIND-PROTECT
-
-;;; We turn THROW into a multiple-value-call of a magical function,
-;;; since as as far as IR1 is concerned, it has no interesting
-;;; properties other than receiving multiple-values.
-(def-ir1-translator throw ((tag result) start cont)
- #!+sb-doc
- "Throw Tag Form
- Do a non-local exit, return the values of Form from the CATCH whose tag
- evaluates to the same thing as Tag."
- (ir1-convert start cont
- `(multiple-value-call #'%throw ,tag ,result)))
-
-;;; This is a special special form used to instantiate a cleanup as
-;;; the current cleanup within the body. KIND is a the kind of cleanup
-;;; to make, and MESS-UP is a form that does the mess-up action. We
-;;; make the MESS-UP be the USE of the MESS-UP form's continuation,
-;;; and introduce the cleanup into the lexical environment. We
-;;; back-patch the ENTRY-CLEANUP for the current cleanup to be the new
-;;; cleanup, since this inner cleanup is the interesting one.
-(def-ir1-translator %within-cleanup ((kind mess-up &body body) start cont)
- (let ((dummy (make-continuation))
- (dummy2 (make-continuation)))
- (ir1-convert start dummy mess-up)
- (let* ((mess-node (continuation-use dummy))
- (cleanup (make-cleanup :kind kind
- :mess-up mess-node))
- (old-cup (lexenv-cleanup *lexenv*))
- (*lexenv* (make-lexenv :cleanup cleanup)))
- (setf (entry-cleanup (cleanup-mess-up old-cup)) cleanup)
- (ir1-convert dummy dummy2 '(%cleanup-point))
- (ir1-convert-progn-body dummy2 cont body))))
-
-;;; This is a special special form that makes an "escape function"
-;;; which returns unknown values from named block. We convert the
-;;; function, set its kind to :ESCAPE, and then reference it. The
-;;; :Escape kind indicates that this function's purpose is to
-;;; represent a non-local control transfer, and that it might not
-;;; actually have to be compiled.
-;;;
-;;; Note that environment analysis replaces references to escape
-;;; functions with references to the corresponding NLX-INFO structure.
-(def-ir1-translator %escape-function ((tag) start cont)
- (let ((fun (ir1-convert-lambda
- `(lambda ()
- (return-from ,tag (%unknown-values))))))
- (setf (functional-kind fun) :escape)
- (reference-leaf start cont fun)))
-
-;;; Yet another special special form. This one looks up a local
-;;; function and smashes it to a :CLEANUP function, as well as
-;;; referencing it.
-(def-ir1-translator %cleanup-function ((name) start cont)
- (let ((fun (lexenv-find name functions)))
- (aver (lambda-p fun))
- (setf (functional-kind fun) :cleanup)
- (reference-leaf start cont fun)))
-
-;;; We represent the possibility of the control transfer by making an
-;;; "escape function" that does a lexical exit, and instantiate the
-;;; cleanup using %WITHIN-CLEANUP.
-(def-ir1-translator catch ((tag &body body) start cont)
- #!+sb-doc
- "Catch Tag Form*
- Evaluates Tag and instantiates it as a catcher while the body forms are
- evaluated in an implicit PROGN. If a THROW is done to Tag within the dynamic
- scope of the body, then control will be transferred to the end of the body
- and the thrown values will be returned."
- (ir1-convert
- start cont
- (let ((exit-block (gensym "EXIT-BLOCK-")))
- `(block ,exit-block
- (%within-cleanup
- :catch
- (%catch (%escape-function ,exit-block) ,tag)
- ,@body)))))
-
-;;; UNWIND-PROTECT is similar to CATCH, but more hairy. We make the
-;;; cleanup forms into a local function so that they can be referenced
-;;; both in the case where we are unwound and in any local exits. We
-;;; use %CLEANUP-FUNCTION on this to indicate that reference by
-;;; %UNWIND-PROTECT ISN'T "real", and thus doesn't cause creation of
-;;; an XEP.
-(def-ir1-translator unwind-protect ((protected &body cleanup) start cont)
- #!+sb-doc
- "Unwind-Protect Protected Cleanup*
- Evaluate the form Protected, returning its values. The cleanup forms are
- evaluated whenever the dynamic scope of the Protected form is exited (either
- due to normal completion or a non-local exit such as THROW)."
- (ir1-convert
- start cont
- (let ((cleanup-fun (gensym "CLEANUP-FUN-"))
- (drop-thru-tag (gensym "DROP-THRU-TAG-"))
- (exit-tag (gensym "EXIT-TAG-"))
- (next (gensym "NEXT"))
- (start (gensym "START"))
- (count (gensym "COUNT")))
- `(flet ((,cleanup-fun () ,@cleanup nil))
- ;; FIXME: If we ever get DYNAMIC-EXTENT working, then
- ;; ,CLEANUP-FUN should probably be declared DYNAMIC-EXTENT,
- ;; and something can be done to make %ESCAPE-FUNCTION have
- ;; dynamic extent too.
- (block ,drop-thru-tag
- (multiple-value-bind (,next ,start ,count)
- (block ,exit-tag
- (%within-cleanup
- :unwind-protect
- (%unwind-protect (%escape-function ,exit-tag)
- (%cleanup-function ,cleanup-fun))
- (return-from ,drop-thru-tag ,protected)))
- (,cleanup-fun)
- (%continue-unwind ,next ,start ,count)))))))
-\f
-;;;; multiple-value stuff
-
-;;; If there are arguments, MULTIPLE-VALUE-CALL turns into an
-;;; MV-COMBINATION.
-;;;
-;;; If there are no arguments, then we convert to a normal
-;;; combination, ensuring that a MV-COMBINATION always has at least
-;;; one argument. This can be regarded as an optimization, but it is
-;;; more important for simplifying compilation of MV-COMBINATIONS.
-(def-ir1-translator multiple-value-call ((fun &rest args) start cont)
- #!+sb-doc
- "MULTIPLE-VALUE-CALL Function Values-Form*
- Call Function, passing all the values of each Values-Form as arguments,
- values from the first Values-Form making up the first argument, etc."
- (let* ((fun-cont (make-continuation))
- (node (if args
- (make-mv-combination fun-cont)
- (make-combination fun-cont))))
- (ir1-convert start fun-cont
- (if (and (consp fun) (eq (car fun) 'function))
- fun
- `(%coerce-callable-to-function ,fun)))
- (setf (continuation-dest fun-cont) node)
- (assert-continuation-type fun-cont
- (specifier-type '(or function symbol)))
- (collect ((arg-conts))
- (let ((this-start fun-cont))
- (dolist (arg args)
- (let ((this-cont (make-continuation node)))
- (ir1-convert this-start this-cont arg)
- (setq this-start this-cont)
- (arg-conts this-cont)))
- (prev-link node this-start)
- (use-continuation node cont)
- (setf (basic-combination-args node) (arg-conts))))))
-
-;;; MULTIPLE-VALUE-PROG1 is represented implicitly in IR1 by having a
-;;; the result code use result continuation (CONT), but transfer
-;;; control to the evaluation of the body. In other words, the result
-;;; continuation isn't IMMEDIATELY-USED-P by the nodes that compute
-;;; the result.
-;;;
-;;; In order to get the control flow right, we convert the result with
-;;; a dummy result continuation, then convert all the uses of the
-;;; dummy to be uses of CONT. If a use is an EXIT, then we also
-;;; substitute CONT for the dummy in the corresponding ENTRY node so
-;;; that they are consistent. Note that this doesn't amount to
-;;; changing the exit target, since the control destination of an exit
-;;; is determined by the block successor; we are just indicating the
-;;; continuation that the result is delivered to.
-;;;
-;;; We then convert the body, using another dummy continuation in its
-;;; own block as the result. After we are done converting the body, we
-;;; move all predecessors of the dummy end block to CONT's block.
-;;;
-;;; Note that we both exploit and maintain the invariant that the CONT
-;;; to an IR1 convert method either has no block or starts the block
-;;; that control should transfer to after completion for the form.
-;;; Nested MV-PROG1's work because during conversion of the result
-;;; form, we use dummy continuation whose block is the true control
-;;; destination.
-(def-ir1-translator multiple-value-prog1 ((result &rest forms) start cont)
- #!+sb-doc
- "MULTIPLE-VALUE-PROG1 Values-Form Form*
- Evaluate Values-Form and then the Forms, but return all the values of
- Values-Form."
- (continuation-starts-block cont)
- (let* ((dummy-result (make-continuation))
- (dummy-start (make-continuation))
- (cont-block (continuation-block cont)))
- (continuation-starts-block dummy-start)
- (ir1-convert start dummy-start result)
-
- (substitute-continuation-uses cont dummy-start)
-
- (continuation-starts-block dummy-result)
- (ir1-convert-progn-body dummy-start dummy-result forms)
- (let ((end-block (continuation-block dummy-result)))
- (dolist (pred (block-pred end-block))
- (unlink-blocks pred end-block)
- (link-blocks pred cont-block))
- (aver (not (continuation-dest dummy-result)))
- (delete-continuation dummy-result)
- (remove-from-dfo end-block))))
-\f
-;;;; interface to defining macros
-
-;;;; FIXME:
-;;;; classic CMU CL comment:
-;;;; DEFMACRO and DEFUN expand into calls to %DEFxxx functions
-;;;; so that we get a chance to see what is going on. We define
-;;;; IR1 translators for these functions which look at the
-;;;; definition and then generate a call to the %%DEFxxx function.
-;;;; Alas, this implementation doesn't do the right thing for
-;;;; non-toplevel uses of these forms, so this should probably
-;;;; be changed to use EVAL-WHEN instead.
-
-;;; Return a new source path with any stuff intervening between the
-;;; current path and the first form beginning with NAME stripped off.
-;;; This is used to hide the guts of DEFmumble macros to prevent
-;;; annoying error messages.
-(defun revert-source-path (name)
- (do ((path *current-path* (cdr path)))
- ((null path) *current-path*)
- (let ((first (first path)))
- (when (or (eq first name)
- (eq first 'original-source-start))
- (return path)))))
-
-;;; Warn about incompatible or illegal definitions and add the macro
-;;; to the compiler environment.
-;;;
-;;; Someday we could check for macro arguments being incompatibly
-;;; redefined. Doing this right will involve finding the old macro
-;;; lambda-list and comparing it with the new one.
-(def-ir1-translator %defmacro ((qname qdef lambda-list doc) start cont
- :kind :function)
- (let (;; QNAME is typically a quoted name. I think the idea is to
- ;; let %DEFMACRO work as an ordinary function when
- ;; interpreting. Whatever the reason the quote is there, we
- ;; don't want it any more. -- WHN 19990603
- (name (eval qname))
- ;; QDEF should be a sharp-quoted definition. We don't want to
- ;; make a function of it just yet, so we just drop the
- ;; sharp-quote.
- (def (progn
- (aver (eq 'function (first qdef)))
- (aver (proper-list-of-length-p qdef 2))
- (second qdef))))
-
- (/show "doing IR1 translator for %DEFMACRO" name)
-
- (unless (symbolp name)
- (compiler-error "The macro name ~S is not a symbol." name))
-
- (ecase (info :function :kind name)
- ((nil))
- (:function
- (remhash name *free-functions*)
- (undefine-function-name name)
- (compiler-warning
- "~S is being redefined as a macro when it was ~
- previously ~(~A~) to be a function."
- name
- (info :function :where-from name)))
- (:macro)
- (:special-form
- (compiler-error "The special form ~S can't be redefined as a macro."
- name)))
-
- (setf (info :function :kind name) :macro
- (info :function :where-from name) :defined
- (info :function :macro-function name) (coerce def 'function))
-
- (let* ((*current-path* (revert-source-path 'defmacro))
- (fun (ir1-convert-lambda def name)))
- (setf (leaf-name fun)
- (concatenate 'string "DEFMACRO " (symbol-name name)))
- (setf (functional-arg-documentation fun) (eval lambda-list))
-
- (ir1-convert start cont `(%%defmacro ',name ,fun ,doc)))
-
- (when sb!xc:*compile-print*
- ;; FIXME: It would be nice to convert this, and the other places
- ;; which create compiler diagnostic output prefixed by
- ;; semicolons, to use some common utility which automatically
- ;; prefixes all its output with semicolons. (The addition of
- ;; semicolon prefixes was introduced ca. sbcl-0.6.8.10 as the
- ;; "MNA compiler message patch", and implemented by modifying a
- ;; bunch of output statements on a case-by-case basis, which
- ;; seems unnecessarily error-prone and unclear, scattering
- ;; implicit information about output style throughout the
- ;; system.) Starting by rewriting COMPILER-MUMBLE to add
- ;; semicolon prefixes would be a good start, and perhaps also:
- ;; * Add semicolon prefixes for "FOO assembled" messages emitted
- ;; when e.g. src/assembly/x86/assem-rtns.lisp is processed.
- ;; * At least some debugger output messages deserve semicolon
- ;; prefixes too:
- ;; ** restarts table
- ;; ** "Within the debugger, you can type HELP for help."
- (compiler-mumble "~&; converted ~S~%" name))))
-
-(def-ir1-translator %define-compiler-macro ((name def lambda-list doc)
- start cont
- :kind :function)
- (let ((name (eval name))
- (def (second def))) ; We don't want to make a function just yet...
-
- (when (eq (info :function :kind name) :special-form)
- (compiler-error "attempt to define a compiler-macro for special form ~S"
- name))
-
- (setf (info :function :compiler-macro-function name)
- (coerce def 'function))
-
- (let* ((*current-path* (revert-source-path 'define-compiler-macro))
- (fun (ir1-convert-lambda def name)))
- (setf (leaf-name fun)
- (let ((*print-case* :upcase))
- (format nil "DEFINE-COMPILER-MACRO ~S" name)))
- (setf (functional-arg-documentation fun) (eval lambda-list))
-
- (ir1-convert start cont `(%%define-compiler-macro ',name ,fun ,doc)))
-
- (when sb!xc:*compile-print*
- (compiler-mumble "~&; converted ~S~%" name))))
-\f
;;;; defining global functions
;;; Convert FUN as a lambda in the null environment, but use the
"previous definition"))))
;;; Convert a lambda doing all the basic stuff we would do if we were
-;;; converting a DEFUN. This is used both by the %DEFUN translator and
-;;; for global inline expansion.
+;;; converting a DEFUN. In the old CMU CL system, this was used both
+;;; by the %DEFUN translator and for global inline expansion, but
+;;; since sbcl-0.pre7.something %DEFUN does things differently.
+;;; FIXME: And now it's probably worth rethinking whether this
+;;; function is a good idea.
;;;
;;; Unless a :INLINE function, we temporarily clobber the inline
;;; expansion. This prevents recursive inline expansion of
nil)
(t t))))
\f
-;;;; compiler error context determination
-
-(declaim (special *current-path*))
-
-;;; We bind print level and length when printing out messages so that
-;;; we don't dump huge amounts of garbage.
-;;;
-;;; FIXME: It's not possible to get the defaults right for everyone.
-;;; So: Should these variables be in the SB-EXT package? Or should we
-;;; just get rid of them completely and just use the bare
-;;; CL:*PRINT-FOO* variables instead?
-(declaim (type (or unsigned-byte null)
- *compiler-error-print-level*
- *compiler-error-print-length*
- *compiler-error-print-lines*))
-(defvar *compiler-error-print-level* 5
- #!+sb-doc
- "the value for *PRINT-LEVEL* when printing compiler error messages")
-(defvar *compiler-error-print-length* 10
- #!+sb-doc
- "the value for *PRINT-LENGTH* when printing compiler error messages")
-(defvar *compiler-error-print-lines* 12
- #!+sb-doc
- "the value for *PRINT-LINES* when printing compiler error messages")
-
-(defvar *enclosing-source-cutoff* 1
- #!+sb-doc
- "The maximum number of enclosing non-original source forms (i.e. from
- macroexpansion) that we print in full. For additional enclosing forms, we
- print only the CAR.")
-(declaim (type unsigned-byte *enclosing-source-cutoff*))
-
-;;; We separate the determination of compiler error contexts from the
-;;; actual signalling of those errors by objectifying the error
-;;; context. This allows postponement of the determination of how (and
-;;; if) to signal the error.
-;;;
-;;; We take care not to reference any of the IR1 so that pending
-;;; potential error messages won't prevent the IR1 from being GC'd. To
-;;; this end, we convert source forms to strings so that source forms
-;;; that contain IR1 references (e.g. %DEFUN) don't hold onto the IR.
-(defstruct (compiler-error-context
- #-no-ansi-print-object
- (:print-object (lambda (x stream)
- (print-unreadable-object (x stream :type t))))
- (:copier nil))
- ;; a list of the stringified CARs of the enclosing non-original source forms
- ;; exceeding the *enclosing-source-cutoff*
- (enclosing-source nil :type list)
- ;; a list of stringified enclosing non-original source forms
- (source nil :type list)
- ;; the stringified form in the original source that expanded into SOURCE
- (original-source (required-argument) :type simple-string)
- ;; a list of prefixes of "interesting" forms that enclose original-source
- (context nil :type list)
- ;; the FILE-INFO-NAME for the relevant FILE-INFO
- (file-name (required-argument)
- :type (or pathname (member :lisp :stream)))
- ;; the file position at which the top-level form starts, if applicable
- (file-position nil :type (or index null))
- ;; the original source part of the source path
- (original-source-path nil :type list))
-
-;;; If true, this is the node which is used as context in compiler warning
-;;; messages.
-(declaim (type (or null compiler-error-context node) *compiler-error-context*))
-(defvar *compiler-error-context* nil)
-
-;;; a hashtable mapping macro names to source context parsers. Each parser
-;;; function returns the source-context list for that form.
-(defvar *source-context-methods* (make-hash-table))
-
-;;; documentation originally from cmu-user.tex:
-;;; This macro defines how to extract an abbreviated source context from
-;;; the \var{name}d form when it appears in the compiler input.
-;;; \var{lambda-list} is a \code{defmacro} style lambda-list used to
-;;; parse the arguments. The \var{body} should return a list of
-;;; subforms that can be printed on about one line. There are
-;;; predefined methods for \code{defstruct}, \code{defmethod}, etc. If
-;;; no method is defined, then the first two subforms are returned.
-;;; Note that this facility implicitly determines the string name
-;;; associated with anonymous functions.
-;;; So even though SBCL itself only uses this macro within this file,
-;;; it's a reasonable thing to put in SB-EXT in case some dedicated
-;;; user wants to do some heavy tweaking to make SBCL give more
-;;; informative output about his code.
-(defmacro def-source-context (name lambda-list &body body)
- #!+sb-doc
- "DEF-SOURCE-CONTEXT Name Lambda-List Form*
- This macro defines how to extract an abbreviated source context from the
- Named form when it appears in the compiler input. Lambda-List is a DEFMACRO
- style lambda-list used to parse the arguments. The Body should return a
- list of subforms suitable for a \"~{~S ~}\" format string."
- (let ((n-whole (gensym)))
- `(setf (gethash ',name *source-context-methods*)
- #'(lambda (,n-whole)
- (destructuring-bind ,lambda-list ,n-whole ,@body)))))
-
-(def-source-context defstruct (name-or-options &rest slots)
- (declare (ignore slots))
- `(defstruct ,(if (consp name-or-options)
- (car name-or-options)
- name-or-options)))
-
-(def-source-context function (thing)
- (if (and (consp thing) (eq (first thing) 'lambda) (consp (rest thing)))
- `(lambda ,(second thing))
- `(function ,thing)))
-
-;;; Return the first two elements of FORM if FORM is a list. Take the
-;;; CAR of the second form if appropriate.
-(defun source-form-context (form)
- (cond ((atom form) nil)
- ((>= (length form) 2)
- (funcall (gethash (first form) *source-context-methods*
- #'(lambda (x)
- (declare (ignore x))
- (list (first form) (second form))))
- (rest form)))
- (t
- form)))
-
-;;; Given a source path, return the original source form and a
-;;; description of the interesting aspects of the context in which it
-;;; appeared. The context is a list of lists, one sublist per context
-;;; form. The sublist is a list of some of the initial subforms of the
-;;; context form.
-;;;
-;;; For now, we use the first two subforms of each interesting form. A
-;;; form is interesting if the first element is a symbol beginning
-;;; with "DEF" and it is not the source form. If there is no
-;;; DEF-mumble, then we use the outermost containing form. If the
-;;; second subform is a list, then in some cases we return the CAR of
-;;; that form rather than the whole form (i.e. don't show DEFSTRUCT
-;;; options, etc.)
-(defun find-original-source (path)
- (declare (list path))
- (let* ((rpath (reverse (source-path-original-source path)))
- (tlf (first rpath))
- (root (find-source-root tlf *source-info*)))
- (collect ((context))
- (let ((form root)
- (current (rest rpath)))
- (loop
- (when (atom form)
- (aver (null current))
- (return))
- (let ((head (first form)))
- (when (symbolp head)
- (let ((name (symbol-name head)))
- (when (and (>= (length name) 3) (string= name "DEF" :end1 3))
- (context (source-form-context form))))))
- (when (null current) (return))
- (setq form (nth (pop current) form)))
-
- (cond ((context)
- (values form (context)))
- ((and path root)
- (let ((c (source-form-context root)))
- (values form (if c (list c) nil))))
- (t
- (values '(unable to locate source)
- '((some strange place)))))))))
-
-;;; Convert a source form to a string, suitably formatted for use in
-;;; compiler warnings.
-(defun stringify-form (form &optional (pretty t))
- (let ((*print-level* *compiler-error-print-level*)
- (*print-length* *compiler-error-print-length*)
- (*print-lines* *compiler-error-print-lines*)
- (*print-pretty* pretty))
- (if pretty
- (format nil "~<~@; ~S~:>" (list form))
- (prin1-to-string form))))
-
-;;; Return a COMPILER-ERROR-CONTEXT structure describing the current
-;;; error context, or NIL if we can't figure anything out. ARGS is a
-;;; list of things that are going to be printed out in the error
-;;; message, and can thus be blown off when they appear in the source
-;;; context.
-(defun find-error-context (args)
- (let ((context *compiler-error-context*))
- (if (compiler-error-context-p context)
- context
- (let ((path (or (and (boundp '*current-path*) *current-path*)
- (if context
- (node-source-path context)
- nil))))
- (when (and *source-info* path)
- (multiple-value-bind (form src-context) (find-original-source path)
- (collect ((full nil cons)
- (short nil cons))
- (let ((forms (source-path-forms path))
- (n 0))
- (dolist (src (if (member (first forms) args)
- (rest forms)
- forms))
- (if (>= n *enclosing-source-cutoff*)
- (short (stringify-form (if (consp src)
- (car src)
- src)
- nil))
- (full (stringify-form src)))
- (incf n)))
-
- (let* ((tlf (source-path-tlf-number path))
- (file-info (source-info-file-info *source-info*)))
- (make-compiler-error-context
- :enclosing-source (short)
- :source (full)
- :original-source (stringify-form form)
- :context src-context
- :file-name (file-info-name file-info)
- :file-position
- (multiple-value-bind (ignore pos)
- (find-source-root tlf *source-info*)
- (declare (ignore ignore))
- pos)
- :original-source-path
- (source-path-original-source path))))))))))
-\f
-;;;; printing error messages
-
-;;; We save the context information that we printed out most recently
-;;; so that we don't print it out redundantly.
-
-;;; The last COMPILER-ERROR-CONTEXT that we printed.
-(defvar *last-error-context* nil)
-(declaim (type (or compiler-error-context null) *last-error-context*))
-
-;;; The format string and args for the last error we printed.
-(defvar *last-format-string* nil)
-(defvar *last-format-args* nil)
-(declaim (type (or string null) *last-format-string*))
-(declaim (type list *last-format-args*))
-
-;;; The number of times that the last error message has been emitted,
-;;; so that we can compress duplicate error messages.
-(defvar *last-message-count* 0)
-(declaim (type index *last-message-count*))
-
-;;; If the last message was given more than once, then print out an
-;;; indication of how many times it was repeated. We reset the message
-;;; count when we are done.
-(defun note-message-repeats (&optional (terpri t))
- (cond ((= *last-message-count* 1)
- (when terpri (terpri *error-output*)))
- ((> *last-message-count* 1)
- (format *error-output* "~&; [Last message occurs ~D times.]~2%"
- *last-message-count*)))
- (setq *last-message-count* 0))
-
-;;; Print out the message, with appropriate context if we can find it.
-;;; If the context is different from the context of the last message
-;;; we printed, then we print the context. If the original source is
-;;; different from the source we are working on, then we print the
-;;; current source in addition to the original source.
-;;;
-;;; We suppress printing of messages identical to the previous, but
-;;; record the number of times that the message is repeated.
-(defun print-compiler-message (format-string format-args)
-
- (declare (type simple-string format-string))
- (declare (type list format-args))
-
- (let ((stream *error-output*)
- (context (find-error-context format-args)))
- (cond
- (context
- (let ((file (compiler-error-context-file-name context))
- (in (compiler-error-context-context context))
- (form (compiler-error-context-original-source context))
- (enclosing (compiler-error-context-enclosing-source context))
- (source (compiler-error-context-source context))
- (last *last-error-context*))
-
- (unless (and last
- (equal file (compiler-error-context-file-name last)))
- (when (pathnamep file)
- (note-message-repeats)
- (setq last nil)
- (format stream "~2&; file: ~A~%" (namestring file))))
-
- (unless (and last
- (equal in (compiler-error-context-context last)))
- (note-message-repeats)
- (setq last nil)
- (format stream "~&")
- (pprint-logical-block (stream nil :per-line-prefix "; ")
- (format stream "in:~{~<~% ~4:;~{ ~S~}~>~^ =>~}" in))
- (format stream "~%"))
-
-
- (unless (and last
- (string= form
- (compiler-error-context-original-source last)))
- (note-message-repeats)
- (setq last nil)
- (format stream "~&")
- (pprint-logical-block (stream nil :per-line-prefix "; ")
- (format stream " ~A" form))
- (format stream "~&"))
-
- (unless (and last
- (equal enclosing
- (compiler-error-context-enclosing-source last)))
- (when enclosing
- (note-message-repeats)
- (setq last nil)
- (format stream "~&; --> ~{~<~%; --> ~1:;~A~> ~}~%" enclosing)))
-
- (unless (and last
- (equal source (compiler-error-context-source last)))
- (setq *last-format-string* nil)
- (when source
- (note-message-repeats)
- (dolist (src source)
- (format stream "~&")
- (write-string "; ==>" stream)
- (format stream "~&")
- (pprint-logical-block (stream nil :per-line-prefix "; ")
- (write-string src stream)))))))
- (t
- (format stream "~&")
- (note-message-repeats)
- (setq *last-format-string* nil)
- (format stream "~&")))
-
- (setq *last-error-context* context)
-
- (unless (and (equal format-string *last-format-string*)
- (tree-equal format-args *last-format-args*))
- (note-message-repeats nil)
- (setq *last-format-string* format-string)
- (setq *last-format-args* format-args)
- (let ((*print-level* *compiler-error-print-level*)
- (*print-length* *compiler-error-print-length*)
- (*print-lines* *compiler-error-print-lines*))
- (format stream "~&")
- (pprint-logical-block (stream nil :per-line-prefix "; ")
- (format stream "~&~?" format-string format-args))
- (format stream "~&"))))
-
- (incf *last-message-count*)
- (values))
-
-(defun print-compiler-condition (condition)
- (declare (type condition condition))
- (let (;; These different classes of conditions have different
- ;; effects on the return codes of COMPILE-FILE, so it's nice
- ;; for users to be able to pick them out by lexical search
- ;; through the output.
- (what (etypecase condition
- (style-warning 'style-warning)
- (warning 'warning)
- (error 'error))))
- (multiple-value-bind (format-string format-args)
- (if (typep condition 'simple-condition)
- (values (simple-condition-format-control condition)
- (simple-condition-format-arguments condition))
- (values "~A"
- (list (with-output-to-string (s)
- (princ condition s)))))
- (print-compiler-message (format nil
- "caught ~S:~% ~A"
- what
- format-string)
- format-args)))
- (values))
-
-;;; COMPILER-NOTE is vaguely like COMPILER-ERROR and the other
-;;; condition-signalling functions, but it just writes some output
-;;; instead of signalling. (In CMU CL, it did signal a condition, but
-;;; this didn't seem to work all that well; it was weird to have
-;;; COMPILE-FILE return with WARNINGS-P set when the only problem was
-;;; that the compiler couldn't figure out how to compile something as
-;;; efficiently as it liked.)
-(defun compiler-note (format-string &rest format-args)
- (unless (if *compiler-error-context*
- (policy *compiler-error-context* (= inhibit-warnings 3))
- (policy *lexenv* (= inhibit-warnings 3)))
- (incf *compiler-note-count*)
- (print-compiler-message (format nil "note: ~A" format-string)
- format-args))
- (values))
-
-;;; Issue a note when we might or might not be in the compiler.
-(defun maybe-compiler-note (&rest rest)
- (if (boundp '*lexenv*) ; if we're in the compiler
- (apply #'compiler-note rest)
- (let ((stream *error-output*))
- (pprint-logical-block (stream nil :per-line-prefix ";")
-
- (format stream " note: ~3I~_")
- (pprint-logical-block (stream nil)
- (apply #'format stream rest)))
- (fresh-line stream)))) ; (outside logical block, no per-line-prefix)
-
-;;; The politically correct way to print out progress messages and
-;;; such like. We clear the current error context so that we know that
-;;; it needs to be reprinted, and we also Force-Output so that the
-;;; message gets seen right away.
-(declaim (ftype (function (string &rest t) (values)) compiler-mumble))
-(defun compiler-mumble (format-string &rest format-args)
- (note-message-repeats)
- (setq *last-error-context* nil)
- (apply #'format *error-output* format-string format-args)
- (force-output *error-output*)
- (values))
-
-;;; Return a string that somehow names the code in COMPONENT. We use
-;;; the source path for the bind node for an arbitrary entry point to
-;;; find the source context, then return that as a string.
-(declaim (ftype (function (component) simple-string) find-component-name))
-(defun find-component-name (component)
- (let ((ep (first (block-succ (component-head component)))))
- (aver ep) ; else no entry points??
- (multiple-value-bind (form context)
- (find-original-source
- (node-source-path (continuation-next (block-start ep))))
- (declare (ignore form))
- (let ((*print-level* 2)
- (*print-pretty* nil))
- (format nil "~{~{~S~^ ~}~^ => ~}" context)))))
-\f
-;;;; condition system interface
-
-;;; Keep track of how many times each kind of condition happens.
-(defvar *compiler-error-count*)
-(defvar *compiler-warning-count*)
-(defvar *compiler-style-warning-count*)
-(defvar *compiler-note-count*)
-
-;;; Keep track of whether any surrounding COMPILE or COMPILE-FILE call
-;;; should return WARNINGS-P or FAILURE-P.
-(defvar *failure-p*)
-(defvar *warnings-p*)
-
-;;; condition handlers established by the compiler. We re-signal the
-;;; condition, then if it isn't handled, we increment our warning
-;;; counter and print the error message.
-(defun compiler-error-handler (condition)
- (signal condition)
- (incf *compiler-error-count*)
- (setf *warnings-p* t
- *failure-p* t)
- (print-compiler-condition condition)
- (continue condition))
-(defun compiler-warning-handler (condition)
- (signal condition)
- (incf *compiler-warning-count*)
- (setf *warnings-p* t
- *failure-p* t)
- (print-compiler-condition condition)
- (muffle-warning condition))
-(defun compiler-style-warning-handler (condition)
- (signal condition)
- (incf *compiler-style-warning-count*)
- (setf *warnings-p* t)
- (print-compiler-condition condition)
- (muffle-warning condition))
-\f
-;;;; undefined warnings
-
-(defvar *undefined-warning-limit* 3
- #!+sb-doc
- "If non-null, then an upper limit on the number of unknown function or type
- warnings that the compiler will print for any given name in a single
- compilation. This prevents excessive amounts of output when the real
- problem is a missing definition (as opposed to a typo in the use.)")
-
-;;; Make an entry in the *UNDEFINED-WARNINGS* describing a reference
-;;; to NAME of the specified KIND. If we have exceeded the warning
-;;; limit, then just increment the count, otherwise note the current
-;;; error context.
-;;;
-;;; Undefined types are noted by a condition handler in
-;;; WITH-COMPILATION-UNIT, which can potentially be invoked outside
-;;; the compiler, hence the BOUNDP check.
-(defun note-undefined-reference (name kind)
- (unless (and
- ;; Check for boundness so we don't blow up if we're called
- ;; when IR1 conversion isn't going on.
- (boundp '*lexenv*)
- ;; FIXME: I'm pretty sure the INHIBIT-WARNINGS test below
- ;; isn't a good idea; we should have INHIBIT-WARNINGS
- ;; affect compiler notes, not STYLE-WARNINGs. And I'm not
- ;; sure what the BOUNDP '*LEXENV* test above is for; it's
- ;; likely a good idea, but it probably deserves an
- ;; explanatory comment.
- (policy *lexenv* (= inhibit-warnings 3)))
- (let* ((found (dolist (warning *undefined-warnings* nil)
- (when (and (equal (undefined-warning-name warning) name)
- (eq (undefined-warning-kind warning) kind))
- (return warning))))
- (res (or found
- (make-undefined-warning :name name :kind kind))))
- (unless found (push res *undefined-warnings*))
- (when (or (not *undefined-warning-limit*)
- (< (undefined-warning-count res) *undefined-warning-limit*))
- (push (find-error-context (list name))
- (undefined-warning-warnings res)))
- (incf (undefined-warning-count res))))
- (values))
-\f
;;;; careful call
;;; Apply a function to some arguments, returning a list of the values
(link-blocks call-block bind-block)
next-block)))
-;;; Handle the environment semantics of LET conversion. We add the
-;;; lambda and its LETs to LETs for the CALL's home function. We merge
-;;; the calls for FUN with the calls for the home function, removing
-;;; FUN in the process. We also merge the ENTRIES.
-;;;
-;;; We also unlink the function head from the component head and set
-;;; COMPONENT-REANALYZE to true to indicate that the DFO should be
-;;; recomputed.
-(defun merge-lets (fun call)
-
- (declare (type clambda fun) (type basic-combination call))
-
- (let ((component (block-component (node-block call))))
- (unlink-blocks (component-head component) (node-block (lambda-bind fun)))
- (setf (component-lambdas component)
- (delete fun (component-lambdas component)))
- (setf (component-reanalyze component) t))
- (setf (lambda-call-lexenv fun) (node-lexenv call))
-
+;;; Remove FUN from the tail set of anything it used to be in the
+;;; same set as; but leave FUN with a valid tail set value of
+;;; its own, for the benefit of code which might try to pull
+;;; something out of it (e.g. return type).
+(defun depart-from-tail-set (fun)
;; Until sbcl-0.pre7.37.flaky5.2, we did
;; (LET ((TAILS (LAMBDA-TAIL-SET FUN)))
;; (SETF (TAIL-SET-FUNCTIONS TAILS)
;; To deal with this problem, we no longer NIL out
;; (LAMBDA-TAIL-SET FUN) here. Instead:
;; * If we're the only function in TAIL-SET-FUNCTIONS, it should
- ;; be safe to leave ourself linked to it, and vice versa.
+ ;; be safe to leave ourself linked to it, and it to you.
;; * If there are other functions in TAIL-SET-FUNCTIONS, then we're
;; afraid of future optimizations on those functions causing
;; the TAIL-SET object no longer to be valid to describe our
;; return value. Thus, we delete ourselves from that object;
- ;; but we save a copy of the object for ourselves, for the use of
- ;; later code (e.g. FINALIZE-XEP-DEFINITION) which might want to
+ ;; but we save a newly-allocated tail-set, derived from the old
+ ;; one, for ourselves, for the use of later code (e.g.
+ ;; FINALIZE-XEP-DEFINITION) which might want to
;; know about our return type.
(let* ((old-tail-set (lambda-tail-set fun))
(old-tail-set-functions (tail-set-functions old-tail-set)))
(let ((new-tail-set (copy-tail-set old-tail-set)))
(setf (lambda-tail-set fun) new-tail-set
(tail-set-functions new-tail-set) (list fun)))))
- ;; The documentation on TAIL-SET-INFO doesn't tell whether it
- ;; remains valid in this case, so we nuke it on the theory that
- ;; missing information is less dangerous than incorrect information.
- (setf (tail-set-info (lambda-tail-set fun)) nil)
+ ;; The documentation on TAIL-SET-INFO doesn't tell whether it could
+ ;; remain valid in this case, so we nuke it on the theory that
+ ;; missing information tends to be less dangerous than incorrect
+ ;; information.
+ (setf (tail-set-info (lambda-tail-set fun)) nil))
+
+;;; Handle the environment semantics of LET conversion. We add the
+;;; lambda and its LETs to LETs for the CALL's home function. We merge
+;;; the calls for FUN with the calls for the home function, removing
+;;; FUN in the process. We also merge the ENTRIES.
+;;;
+;;; We also unlink the function head from the component head and set
+;;; COMPONENT-REANALYZE to true to indicate that the DFO should be
+;;; recomputed.
+(defun merge-lets (fun call)
+
+ (declare (type clambda fun) (type basic-combination call))
+
+ (let ((component (block-component (node-block call))))
+ (unlink-blocks (component-head component) (node-block (lambda-bind fun)))
+ (setf (component-lambdas component)
+ (delete fun (component-lambdas component)))
+ (setf (component-reanalyze component) t))
+ (setf (lambda-call-lexenv fun) (node-lexenv call))
+
+ (depart-from-tail-set fun)
(let* ((home (node-home-lambda call))
(home-env (lambda-environment home)))
("src/code/defbangstruct")
+ ("src/code/funutils" :not-host)
+
;; This needs DEF!STRUCT, and is itself needed early so that structure
;; accessors and inline functions defined here can be compiled inline
;; later. (Avoiding full calls not only increases efficiency, but also
("src/code/target-signal" :not-host) ; needs OS-CONTEXT-T from x86-vm
- ("src/code/symbol" :not-host)
- ("src/code/bignum" :not-host)
- ("src/code/target-numbers" :not-host)
- ("src/code/float-trap" :not-host)
- ("src/code/float" :not-host)
- ("src/code/irrat" :not-host)
+ ("src/code/symbol" :not-host)
+ ("src/code/bignum" :not-host)
+ ("src/code/numbers" :not-host)
+ ("src/code/float-trap" :not-host)
+ ("src/code/float" :not-host)
+ ("src/code/irrat" :not-host)
("src/code/char")
("src/code/target-char" :not-host)
("src/compiler/main") ; needs DEFSTRUCT FASL-OUTPUT from dump.lisp
("src/compiler/target-main" :not-host)
("src/compiler/ir1tran")
+ ("src/compiler/ir1-translators")
("src/compiler/ir1util")
+ ("src/compiler/ir1report")
("src/compiler/ir1opt")
;; Compiling this file requires the macros SB!ASSEM:EMIT-LABEL and
;;; for internal versions, especially for internal versions off the
;;; main CVS branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.pre7.45"
+"0.pre7.46"
projects / sbcl.git / commitdiff