;; defines IR1-ATTRIBUTES macro, needed by proclaim.lisp
("src/compiler/knownfun")
+ ;; needs FUN-INFO structure slot setters, defined in knownfun.lisp
+ ("src/compiler/fun-info-funs")
+
;; stuff needed by "code/defstruct"
("src/code/cross-type" :not-target)
("src/compiler/generic/vm-type")
(let ((*backquote-count* (1+ *backquote-count*)))
(multiple-value-bind (flag thing)
(backquotify stream (read stream t nil t))
- (if (eq flag *bq-at-flag*)
- (%reader-error stream ",@ after backquote in ~S" thing))
- (if (eq flag *bq-dot-flag*)
- (%reader-error stream ",. after backquote in ~S" thing))
- (values (backquotify-1 flag thing) 'list))))
+ (when (eq flag *bq-at-flag*)
+ (%reader-error stream ",@ after backquote in ~S" thing))
+ (when (eq flag *bq-dot-flag*)
+ (%reader-error stream ",. after backquote in ~S" thing))
+ (backquotify-1 flag thing))))
(/show0 "backq.lisp 64")
(%reader-error stream "comma not inside a backquote"))
(let ((c (read-char stream))
(*backquote-count* (1- *backquote-count*)))
- (values
- (cond ((char= c #\@)
- (cons *bq-at-flag* (read stream t nil t)))
- ((char= c #\.)
- (cons *bq-dot-flag* (read stream t nil t)))
- (t (unread-char c stream)
- (cons *bq-comma-flag* (read stream t nil t))))
- 'list)))
+ (cond ((char= c #\@)
+ (cons *bq-at-flag* (read stream t nil t)))
+ ((char= c #\.)
+ (cons *bq-dot-flag* (read stream t nil t)))
+ (t (unread-char c stream)
+ (cons *bq-comma-flag* (read stream t nil t))))))
(/show0 "backq.lisp 83")
(values 'vector (backquotify-1 dflag d))))
(t (multiple-value-bind (aflag a) (backquotify stream (car code))
(multiple-value-bind (dflag d) (backquotify stream (cdr code))
- (if (eq dflag *bq-at-flag*)
- ;; Get the errors later.
- (%reader-error stream ",@ after dot in ~S" code))
- (if (eq dflag *bq-dot-flag*)
- (%reader-error stream ",. after dot in ~S" code))
+ (when (eq dflag *bq-at-flag*)
+ ;; Get the errors later.
+ (%reader-error stream ",@ after dot in ~S" code))
+ (when (eq dflag *bq-dot-flag*)
+ (%reader-error stream ",. after dot in ~S" code))
(cond
((eq aflag *bq-at-flag*)
(if (null dflag)
(defun simplified-compound-types (input-types %compound-type-p simplify2)
(let ((simplified-types (make-array (length input-types)
:fill-pointer 0
+ :adjustable t
:element-type 'ctype
;; (This INITIAL-ELEMENT shouldn't
;; matter, but helps avoid type
-;;;; patches to hide some implementation idiosyncrasies in our
+;;;; patches to work around implementation idiosyncrasies in our
;;;; cross-compilation host
;;;; This software is part of the SBCL system. See the README file for
(in-package :sb-cold)
+(defmacro munging-cl-package (&body body)
+ #-clisp `(progn ,@body)
+ #+clisp `(ext:without-package-lock ("CL")
+ ,@body))
+
;;; Do the exports of COMMON-LISP conform to the standard? If not, try
;;; to make them conform. (Of course, ANSI says that bashing symbols
;;; in the COMMON-LISP package like this is undefined, but then if the
(declare (ignore value))
(unless (gethash key standard-ht)
(warn "removing non-ANSI export from package CL: ~S" key)
- #+CLISP (ext:without-package-lock ("CL")
- (unexport (intern key cl) cl))
- #-CLISP (unexport (intern key cl) cl)))
+ (munging-cl-package
+ (unexport (intern key cl) cl))))
host-ht)
(maphash (lambda (key value)
(declare (ignore value))
(unless (gethash key host-ht)
(warn "adding required-by-ANSI export to package CL: ~S" key)
- #+CLISP (ext:without-package-lock ("CL")
- (export (intern key cl) cl))
- #-CLISP (export (intern key cl) cl))
+ (munging-cl-package
+ (export (intern key cl) cl)))
;; FIXME: My righteous indignation below was misplaced. ANSI sez
;; (in 11.1.2.1, "The COMMON-LISP Package") that it's OK for
(movable foldable flushable))
(defknown (%asin %atan)
- (double-float) (double-float #.(- (/ pi 2)) #.(/ pi 2))
+ (double-float)
+ (double-float #.(coerce (- (/ pi 2)) 'double-float)
+ #.(coerce (/ pi 2) 'double-float))
(movable foldable flushable))
(defknown (%acos)
- (double-float) (double-float 0.0d0 #.pi)
+ (double-float) (double-float 0.0d0 #.(coerce pi 'double-float))
(movable foldable flushable))
(defknown (%cosh)
(movable foldable flushable))
(defknown (%atan2)
- (double-float double-float) (double-float #.(- pi) #.pi)
+ (double-float double-float)
+ (double-float #.(coerce (- pi) 'double-float)
+ #.(coerce pi 'double-float))
(movable foldable flushable))
(defknown (%scalb)
--- /dev/null
+;;;; functions which have a build order dependency on FUN-INFO
+;;;; (because ANSI allows xc host structure slot setters to be
+;;;; implemented as SETF expanders instead of SETF functions, so we
+;;;; can't safely forward-reference them) and so have to be defined
+;;;; physically late instead of in a more logical place
+
+(in-package "SB!C")
+
+(defun %def-reffer (name offset lowtag)
+ (let ((fun-info (fun-info-or-lose name)))
+ (setf (fun-info-ir2-convert fun-info)
+ (lambda (node block)
+ (ir2-convert-reffer node block name offset lowtag))))
+ name)
+
+(defun %def-setter (name offset lowtag)
+ (let ((fun-info (fun-info-or-lose name)))
+ (setf (fun-info-ir2-convert fun-info)
+ (if (listp name)
+ (lambda (node block)
+ (ir2-convert-setfer node block name offset lowtag))
+ (lambda (node block)
+ (ir2-convert-setter node block name offset lowtag)))))
+ name)
+
+(defun %def-alloc (name words var-length header lowtag inits)
+ (let ((info (fun-info-or-lose name)))
+ (setf (fun-info-ir2-convert info)
+ (if var-length
+ (lambda (node block)
+ (ir2-convert-variable-allocation node block name words header
+ lowtag inits))
+ (lambda (node block)
+ (ir2-convert-fixed-allocation node block name words header
+ lowtag inits)))))
+ name)
name offset lowtag)
(move-continuation-result node block (list value-tn) (node-cont node))))
+;;; FIXME: Isn't there a name for this which looks less like a typo?
+;;; (The name IR2-CONVERT-SETTER is used for something else, just above.)
(defoptimizer ir2-convert-setfer ((value object) node block name offset lowtag)
(let ((value-tn (continuation-tn node block value)))
(vop set-slot node block (continuation-tn node block object) value-tn
(in-package "SB!C")
-(defun %def-reffer (name offset lowtag)
- (let ((info (fun-info-or-lose name)))
- (setf (fun-info-ir2-convert info)
- (lambda (node block)
- (ir2-convert-reffer node block name offset lowtag))))
- name)
-
(defmacro def-reffer (name offset lowtag)
`(%def-reffer ',name ,offset ,lowtag))
-
-(defun %def-setter (name offset lowtag)
- (let ((info (fun-info-or-lose name)))
- (setf (fun-info-ir2-convert info)
- (if (listp name)
- (lambda (node block)
- (ir2-convert-setfer node block name offset lowtag))
- (lambda (node block)
- (ir2-convert-setter node block name offset lowtag)))))
- name)
-
(defmacro def-setter (name offset lowtag)
`(%def-setter ',name ,offset ,lowtag))
-
-(defun %def-alloc (name words var-length header lowtag inits)
- (let ((info (fun-info-or-lose name)))
- (setf (fun-info-ir2-convert info)
- (if var-length
- (lambda (node block)
- (ir2-convert-variable-allocation node block name words header
- lowtag inits))
- (lambda (node block)
- (ir2-convert-fixed-allocation node block name words header
- lowtag inits)))))
- name)
-
(defmacro def-alloc (name words var-length header lowtag inits)
`(%def-alloc ',name ,words ,var-length ,header ,lowtag ,inits))
+;;; KLUDGE: The %DEF-FOO functions used to implement the macros here
+;;; are defined later in another file, since they use structure slot
+;;; setters defined later, and we can't have physical forward
+;;; references to structure slot setters because ANSI in its wisdom
+;;; allows the xc host CL to implement structure slot setters as SETF
+;;; expanders instead of SETF functions. -- WHN 2002-02-09
\f
;;;; some general constant definitions
;;; for internal versions, especially for internal versions off the
;;; main CVS branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.7.1.16"
+"0.7.1.17"
projects / sbcl.git / commitdiff