[Openmcl-cvs-notifications] r10942 - in /trunk/source: compiler/ compiler/X86/ level-1/ lib/ library/
gz at clozure.com
gz at clozure.com
Thu Oct 2 14:43:48 EDT 2008
Author: gz
Date: Thu Oct 2 14:43:48 2008
New Revision: 10942
Log:
Propagate r10938:r10941 (duplicate definition warnings) to trunk
Modified:
trunk/source/compiler/X86/x86-lap.lisp
trunk/source/compiler/nx-basic.lisp
trunk/source/compiler/nx0.lisp
trunk/source/compiler/nxenv.lisp
trunk/source/level-1/l1-application.lisp
trunk/source/level-1/l1-callbacks.lisp
trunk/source/level-1/l1-clos-boot.lisp
trunk/source/level-1/l1-clos.lisp
trunk/source/level-1/l1-dcode.lisp
trunk/source/level-1/l1-files.lisp
trunk/source/level-1/l1-format.lisp
trunk/source/level-1/l1-pathnames.lisp
trunk/source/level-1/l1-readloop.lisp
trunk/source/level-1/l1-streams.lisp
trunk/source/level-1/l1-typesys.lisp
trunk/source/level-1/l1-utils.lisp
trunk/source/level-1/sysutils.lisp
trunk/source/level-1/x86-trap-support.lisp
trunk/source/lib/arrays-fry.lisp
trunk/source/lib/ccl-export-syms.lisp
trunk/source/lib/compile-ccl.lisp
trunk/source/lib/defstruct-lds.lisp
trunk/source/lib/defstruct.lisp
trunk/source/lib/format.lisp
trunk/source/lib/macros.lisp
trunk/source/lib/method-combination.lisp
trunk/source/lib/misc.lisp
trunk/source/lib/nfcomp.lisp
trunk/source/lib/pprint.lisp
trunk/source/lib/sequences.lisp
trunk/source/library/lispequ.lisp
Modified: trunk/source/compiler/X86/x86-lap.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/compiler/X86/x86-lap.lisp (original)
+++ trunk/source/compiler/X86/x86-lap.lisp Thu Oct 2 14:43:48 2008
@@ -306,7 +306,7 @@
=
=
=
-(defstruct (frag-list (:include ccl::dll-header)))
+(defstruct (frag-list (:include ccl::dll-header) (:constructor nil)))
=
;;; ccl::dll-header-last is unit-time
(defun frag-list-current (frag-list)
Modified: trunk/source/compiler/nx-basic.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/compiler/nx-basic.lisp (original)
+++ trunk/source/compiler/nx-basic.lisp Thu Oct 2 14:43:48 2008
@@ -509,14 +509,27 @@
(:special-fbinding . "Attempt to bind compiler special name: ~s. Resul=
t undefined.")
(:lambda . "Suspicious lambda-list: ~s")
(:result-ignored . "Function result ignored in call to ~s")
+ (:duplicate-definition . report-compile-time-duplicate-definition)
(:program-error . "~a")))
=
+(defun report-compile-time-duplicate-definition (condition stream)
+ (destructuring-bind (name old-file new-file &optional from to) (compiler=
-warning-args condition)
+ (format stream
+ "Duplicate definitions of ~s~:[~*~;~:* (as a ~a and a ~a)~]~:[=
~;, in this file~:[~; and in ~s~]~]"
+ name from to
+ (and old-file new-file)
+ (neq old-file new-file)
+ old-file)))
=
(defun report-compiler-warning (condition stream)
(let* ((warning-type (compiler-warning-warning-type condition))
- (format-string (cdr (assq warning-type *compiler-warning-formats*=
))))
+ (format-string (cdr (assq warning-type *compiler-warning-formats*=
)))
+ (name (reverse (compiler-warning-function-name condition))))
(format stream "In ")
- (print-nested-name (reverse (compiler-warning-function-name condition)=
) stream)
+ (print-nested-name name stream)
+ (when (every #'null name)
+ (let ((position (compiler-warning-stream-position condition)))
+ (when position (format stream " at position ~s" position))))
(format stream ": ")
(if (typep format-string 'string)
(apply #'format stream format-string (compiler-warning-args conditio=
n))
Modified: trunk/source/compiler/nx0.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/compiler/nx0.lisp (original)
+++ trunk/source/compiler/nx0.lisp Thu Oct 2 14:43:48 2008
@@ -1081,16 +1081,16 @@
(if info (setq token afunc =
containing-env (afunc-environment afunc)
lambda-form (afunc-lambdaform afunc)))
- (let* ((defenv (definition-environment env)))
- (if (cdr (setq info (if defenv (cdr (assq sym (defenv.defined de=
fenv))))))
- (setq lambda-form (cdr info)
+ (setq info (cdr (retrieve-environment-function-info sym env)))
+ (if (def-info.lambda info)
+ (setq lambda-form (def-info.lambda info)
token sym
- containing-env (new-lexical-environment defenv))
+ containing-env (new-lexical-environment (definition-envi=
ronment env)))
(unless info
(if (cdr (setq info (assq sym *nx-globally-inline*)))
(setq lambda-form (%cdr info)
token sym
- containing-env (new-lexical-environment (new-definit=
ion-environment nil)))))))))
+ containing-env (new-lexical-environment (new-definit=
ion-environment nil))))))))
(values lambda-form (nx-closed-environment env containing-env) token)))
=
(defun nx-closed-environment (current-env target)
@@ -1921,12 +1921,13 @@
(multiple-value-bind (bits keyvect)
(case deftype
(:global-mismatch (innermost-lfun-bits-keyvect =
def))
- (:environment-mismatch (values (caadr def) (cda=
dr def)))
+ (:environment-mismatch
+ (values (def-info.lfbits (cdr def)) (def-inf=
o.keyvect (cdr def))))
(t (let* ((lambda-form (afunc-lambdaform def)))
(if (lambda-expression-p lambda-form)
(encode-lambda-list (cadr lambda-form)))=
)))
(when bits
- (unless (typep bits 'fixnum) (bug "Bad bits!"))
+ (unless (typep bits 'fixnum) (error "Bug: Bad bits ~s!" bits))
(let* ((nargs (length arglist))
(minargs (if spread-p (1- nargs) nargs))
(maxargs (if spread-p nil nargs))
Modified: trunk/source/compiler/nxenv.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/compiler/nxenv.lisp (original)
+++ trunk/source/compiler/nxenv.lisp Thu Oct 2 14:43:48 2008
@@ -29,7 +29,13 @@
#+x8632-target (require "X8632ENV")
#+x8664-target (require "X8664ENV")
=
-;
+#-BOOTSTRAPPED (unless (fboundp '%cons-def-info)
+ (fset '%cons-def-info (lambda (&rest args) args nil))
+ (fset 'def-info.lfbits (lambda (def-info) def-info nil))
+ (fset 'def-info.keyvect (lambda (def-info) def-info nil))
+ (fset 'def-info.lambda (lambda (def-info) def-info nil)))
+#-BOOTSTRAPPED (unless (fboundp 'retrieve-environment-function-info)
+ (fset 'retrieve-environment-function-info (lambda (name e=
nv) name env nil)))
=
(defconstant $vbittemporary 16) ; a compiler temporary
(defconstant $vbitreg 17) ; really wants to live in a register.
Modified: trunk/source/level-1/l1-application.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/level-1/l1-application.lisp (original)
+++ trunk/source/level-1/l1-application.lisp Thu Oct 2 14:43:48 2008
@@ -303,7 +303,3 @@
;; This is the init file loaded before cocoa.
#+unix '("home:ccl-init" "home:\\.ccl-init")
#+windows "home:ccl-init")
-
-(defmethod application-error ((a application) condition error-pointer)
- (declare (ignore condition error-pointer))
- (quit))
Modified: trunk/source/level-1/l1-callbacks.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/level-1/l1-callbacks.lisp (original)
+++ trunk/source/level-1/l1-callbacks.lisp Thu Oct 2 14:43:48 2008
@@ -20,22 +20,6 @@
=
(defstatic *callback-lock* (make-lock))
=
-
-;;; MacOS toolbox routines were once written mostly in Pascal, so some
-;;; code still refers to callbacks from foreign code as "pascal-callable
-;;; functions".
-
-; %Pascal-Functions% Entry
-(def-accessor-macros %svref
- pfe.routine-descriptor
- pfe.proc-info
- pfe.lisp-function
- pfe.sym
- pfe.without-interrupts
- pfe.trace-p)
-
-(defun %cons-pfe (routine-descriptor proc-info lisp-function sym without-i=
nterrupts)
- (vector routine-descriptor proc-info lisp-function sym without-interrupt=
s nil))
=
;;; (defcallback ...) expands into a call to this function.
(defun define-callback-function (lisp-function &optional doc-string (with=
out-interrupts t) monitor-exception-ports
Modified: trunk/source/level-1/l1-clos-boot.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/level-1/l1-clos-boot.lisp (original)
+++ trunk/source/level-1/l1-clos-boot.lisp Thu Oct 2 14:43:48 2008
@@ -172,9 +172,6 @@
(values nil nil)
(values t val))))
=
-
-(defun %slot-definition-class (slotd)
- (standard-slot-definition.class slotd))
=
(defun %slot-definition-location (slotd)
(standard-effective-slot-definition.location slotd))
@@ -275,27 +272,28 @@
=0C
=
;;; This becomes (apply #'make-instance <method-class> &rest args).
-(defun %make-method-instance (class &key
- qualifiers
- specializers
- function =
- name
- lambda-list
- &allow-other-keys)
- (let* ((method
- (%instance-vector (%class-own-wrapper class)
- qualifiers
- specializers
- function
- nil
- name
- lambda-list)))
- (when function
- (let* ((inner (closure-function function)))
- (unless (eq inner function)
- (copy-method-function-bits inner function)))
- (lfun-name function method))
- method))
+(fset '%make-method-instance
+ (nlambda bootstrapping-%make-method-instance (class &key
+ qualifiers
+ specializers
+ function
+ name
+ lambda-list
+ &allow-other-key=
s)
+ (let* ((method
+ (%instance-vector (%class-own-wrapper class)
+ qualifiers
+ specializers
+ function
+ nil
+ name
+ lambda-list)))
+ (when function
+ (let* ((inner (closure-function function)))
+ (unless (eq inner function)
+ (copy-method-function-bits inner function)))
+ (lfun-name function method))
+ method)))
=
=
=
@@ -868,9 +866,10 @@
(%add-standard-method-to-standard-gf gf method))
=
;; Redefined in l1-clos.lisp
-(defun maybe-remove-make-instance-optimization (gfn method)
- (declare (ignore gfn method))
- nil)
+(fset 'maybe-remove-make-instance-optimization
+ (nlambda bootstrapping-maybe-remove-make-instance-optimization (gfn =
method)
+ (declare (ignore gfn method))
+ nil))
=
(defun %add-standard-method-to-standard-gf (gfn method)
(when (%method-gf method)
@@ -1324,25 +1323,26 @@
(setf (%class-proper-name new-class) name)))
=
=
-(defun set-find-class (name class)
- (clear-type-cache)
- (let* ((cell (find-class-cell name t))
- (old-class (class-cell-class cell)))
- (when class
- (if (eq name (%class.name class))
- (setf (info-type-kind name) :instance)))
- (setf (class-cell-class cell) class)
- (update-class-proper-names name old-class class)
- class))
+(fset 'set-find-class (nfunction bootstrapping-set-find-class ; redefined =
below
+ (lambda (name class)
+ (clear-type-cache)
+ (let* ((cell (find-class-cell name t))
+ (old-class (class-cell-class cel=
l)))
+ (when class
+ (if (eq name (%class.name class))
+ (setf (info-type-kind name) :inst=
ance)))
+ (setf (class-cell-class cell) class)
+ (update-class-proper-names name old-c=
lass class)
+ class))))
=
=
;;; bootstrapping definition. real one is in "sysutils.lisp"
-
-(defun built-in-type-p (name)
- (or (type-predicate name)
- (memq name '(signed-byte unsigned-byte mod =
- values satisfies member and or not))
- (typep (find-class name nil) 'built-in-class)))
+(fset 'built-in-type-p (nfunction boostrapping-built-in-typep-p
+ (lambda (name)
+ (or (type-predicate name)
+ (memq name '(signed-byte unsigned-=
byte mod =
+ values satisfies memb=
er and or not))
+ (typep (find-class name nil) 'buil=
t-in-class)))))
=
=
=
@@ -2515,11 +2515,11 @@
=
;;; Bootstrapping version of union
(unless (fboundp 'union)
-(defun union (l1 l2)
- (dolist (e l1)
- (unless (memq e l2)
- (push e l2)))
- l2)
+ (fset 'union (nlambda bootstrapping-union (l1 l2)
+ (dolist (e l1)
+ (unless (memq e l2)
+ (push e l2)))
+ l2))
)
=
;; Stub to prevent errors when the user doesn't define types
Modified: trunk/source/level-1/l1-clos.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/level-1/l1-clos.lisp (original)
+++ trunk/source/level-1/l1-clos.lisp Thu Oct 2 14:43:48 2008
@@ -175,16 +175,17 @@
initargs))
=
;; Bootstrapping version, replaced in l1-typesys
-(defun standardized-type-specifier (spec)
- (when (and (consp spec)
- (memq (%car spec) '(and or))
- (consp (%cdr spec))
- (null (%cddr spec)))
- (setq spec (%cadr spec)))
- (if (consp spec)
- (cons (%car spec) (mapcar #'standardized-type-specifier (%cdr spec)))
- (or (cdr (assoc spec '((string . base-string))))
- spec)))
+(fset 'standardized-type-specifier
+ (nlambda bootstrapping-standardized-type-specifier (spec)
+ (when (and (consp spec)
+ (memq (%car spec) '(and or))
+ (consp (%cdr spec))
+ (null (%cddr spec)))
+ (setq spec (%cadr spec)))
+ (if (consp spec)
+ (cons (%car spec) (mapcar #'standardized-type-specifier (%cdr sp=
ec)))
+ (or (cdr (assoc spec '((string . base-string))))
+ spec))))
=
;;; The type of an effective slot definition is the intersection of
;;; the types of the direct slot definitions it's initialized from.
@@ -1184,9 +1185,9 @@
=
=
=
-;;; Fake method-combination
+;;; Fake method-combination, redefined in lib;method-combination.
(defclass method-combination (metaobject) =
- ((name :accessor method-combination-name :initarg :name)))
+ ((name :initarg :name)))
=
=
=
Modified: trunk/source/level-1/l1-dcode.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/level-1/l1-dcode.lisp (original)
+++ trunk/source/level-1/l1-dcode.lisp Thu Oct 2 14:43:48 2008
@@ -610,14 +610,6 @@
(defun %gf-method-combination (gf)
(sgf.method-combination gf))
=
-(defun %combined-method-methods (cm)
- (combined-method.thing cm))
-
-(defun %combined-method-dcode (cm)
- ;(require-type cm 'combined-method)
- (combined-method.dcode cm))
-
-
; need setters too
=
(defsetf %combined-method-methods %set-combined-method-methods)
Modified: trunk/source/level-1/l1-files.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/level-1/l1-files.lisp (original)
+++ trunk/source/level-1/l1-files.lisp Thu Oct 2 14:43:48 2008
@@ -127,14 +127,6 @@
:version nil))
=
=
-(defun %shrink-vector (vector to-size)
- (cond ((eq (length vector) to-size)
- vector)
- ((array-has-fill-pointer-p vector)
- (setf (fill-pointer vector) to-size)
- vector)
- (t (subseq vector 0 to-size))))
-
(defun namestring-unquote (name)
#+(and windows-target bogus)
(when (and (> (length name) 1)
@@ -257,13 +249,15 @@
=
=
=
-(defun pathname-host (thing) ; redefined later in this file
- (declare (ignore thing))
- :unspecific)
-
-(defun pathname-version (thing) ; redefined later in this file
- (declare (ignore thing))
- nil)
+(fset 'pathname-host (nfunction bootstrapping-pathname-host ; redefined =
later in this file
+ (lambda (thing)
+ (declare (ignore thing))
+ :unspecific)))
+
+(fset 'pathname-version (nfunction bootstrapping-pathname-version ; rede=
fined later in this file
+ (lambda (thing)
+ (declare (ignore thing))
+ nil)))
=
(defmethod print-object ((pathname pathname) stream)
(let ((flags (if (logical-pathname-p pathname) 4
Modified: trunk/source/level-1/l1-format.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/level-1/l1-format.lisp (original)
+++ trunk/source/level-1/l1-format.lisp Thu Oct 2 14:43:48 2008
@@ -47,10 +47,10 @@
=
(defun pop-format-arg (&aux (args *format-arguments*))
(if (null args)
- (format-error "Missing argument"))
- (progn
- (setq *format-arguments* (cdr args))
- (%car args)))
+ (format-error "Missing argument"))
+ (progn
+ (setq *format-arguments* (cdr args))
+ (%car args)))
=
;SUB-FORMAT parses (a range of) the control string, finding the directives
;and applying them to their parameters.
@@ -291,30 +291,33 @@
;;;Interim definitions
=
;;;This function is shadowed by CCL in order to use ~{ to print error mess=
ages.
-(defun format (stream control-string &rest format-arguments)
- (declare (dynamic-extent format-arguments))
- (when (null stream)
- (return-from format =
- (with-output-to-string (x)
- (apply #'format x control-string format-arguments))))
- (if (eq stream t)
- (setq stream *standard-output*)
- (unless (streamp stream) (report-bad-arg stream 'stream)))
- (if (functionp control-string)
- (apply control-string stream format-arguments)
- (progn
- (setq control-string (ensure-simple-string control-string))
- (let* ((*format-original-arguments* format-arguments)
- (*format-arguments* format-arguments)
- (*format-control-string* control-string))
- (catch 'format-escape
- (sub-format stream 0 (length control-string)))
- nil))))
-
-(defun format-error (&rest args)
- (format t "~&FORMAT error at position ~A in control string ~S "
- *format-index* *format-control-string*)
- (apply #'error args))
+(fset 'format =
+ (nlambda bootstrapping-format (stream control-string &rest format-ar=
guments)
+ (declare (dynamic-extent format-arguments))
+ (block format
+ (when (null stream)
+ (return-from format =
+ (with-output-to-string (x)
+ (apply #'format x control-string format-arguments))))
+ (if (eq stream t)
+ (setq stream *standard-output*)
+ (unless (streamp stream) (report-bad-arg stream 'stream)))
+ (if (functionp control-string)
+ (apply control-string stream format-arguments)
+ (progn
+ (setq control-string (ensure-simple-string control-string))
+ (let* ((*format-original-arguments* format-arguments)
+ (*format-arguments* format-arguments)
+ (*format-control-string* control-string))
+ (catch 'format-escape
+ (sub-format stream 0 (length control-string)))
+ nil))))))
+
+(fset 'format-error
+ (nlambda bootstrapping-format-error (&rest args)
+ (format t "~&FORMAT error at position ~A in control string ~S "
+ *format-index* *format-control-string*)
+ (apply #'error args)))
=
(defun format-no-flags (colon atsign)
(when (or colon atsign) (format-error "Flags not allowed")))
Modified: trunk/source/level-1/l1-pathnames.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/level-1/l1-pathnames.lisp (original)
+++ trunk/source/level-1/l1-pathnames.lisp Thu Oct 2 14:43:48 2008
@@ -433,37 +433,6 @@
(flet ((only-wild (dir)
(when (null (cdr dir))
(setq dir (car dir))
- (if (stringp dir)(string=3D dir "**")(eq dir :wild-i=
nferiors)))))
- (cond ((eq path wild) t)
- ((only-wild wild)
- t)
- (t (let ((result t))
- (block nil =
- (while (and path wild)
- (let ((pathstr (car path))
- (wildstr (car wild)))
- (case wildstr
- (:wild (setq wildstr "*"))
- (:wild-inferiors (setq wildstr "**")))
- (case pathstr
- (:wild (setq pathstr "*"))
- (:wild-inferiors (setq pathstr "**")))
- (when (not =
- (cond ((string=3D wildstr "**")
- (setq result (%pathname-match-dir1 path=
(cdr wild)))
- (return-from nil))
- ((%path-str*=3D pathstr wildstr))))
- (setq result nil)
- (return-from nil))
- (setq wild (cdr wild) path (cdr path))))
- (when (and (or path wild)(not (only-wild wild)))
- (setq result nil)))
- result)))))
-
-(defun %pathname-match-dir0 (path wild)
- (flet ((only-wild (dir)
- (when (null (cdr dir))
- (setq dir (car dir))
(when (consp dir) (setq dir (cadr dir)))
(if (stringp dir)(string=3D dir "**")(eq dir :wild-i=
nferiors)))))
(cond ((eq path wild) t)
Modified: trunk/source/level-1/l1-readloop.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/level-1/l1-readloop.lisp (original)
+++ trunk/source/level-1/l1-readloop.lisp Thu Oct 2 14:43:48 2008
@@ -403,25 +403,122 @@
(definition-environment env t))
lambda-expression))
=
+
+(defun %cons-def-info (type &optional lfbits keyvect lambda specializers q=
ualifiers)
+ (ecase type
+ (defun nil)
+ (defmacro (setq lambda '(macro) lfbits nil)) ;; some code assumes lfbi=
ts=3Dnil
+ (defgeneric (setq lambda (list :methods)))
+ (defmethod (setq lambda (list :methods (cons qualifiers specializers))=
)))
+ (vector lfbits keyvect *loading-file-source-file* lambda))
+
+(defun def-info.lfbits (def-info)
+ (and def-info (svref def-info 0)))
+
+(defun def-info.keyvect (def-info)
+ (and def-info (svref def-info 1)))
+
+(defun def-info.file (def-info)
+ (and def-info (svref def-info 2)))
+
+(defun def-info.lambda (def-info)
+ (let ((data (and def-info (svref def-info 3))))
+ (and (eq (car data) 'lambda) data)))
+
+(defun def-info.methods (def-info)
+ (let ((data (and def-info (svref def-info 3))))
+ (and (eq (car data) :methods) (%cdr data))))
+
+(defun def-info-with-new-methods (def-info new-methods)
+ (unless (eq (def-info.type def-info) 'defgeneric) (error "Bug: not metho=
d info: ~s" def-info))
+ (if (eq new-methods (def-info.methods def-info))
+ def-info
+ (let ((new (copy-seq def-info)))
+ (setf (svref new 3) (cons :methods new-methods))
+ new)))
+
+(defun def-info.macro-p (def-info)
+ (let ((data (and def-info (svref def-info 2))))
+ (eq (car data) 'macro)))
+
+(defun def-info.type (def-info)
+ (if (null def-info) nil ;; means FTYPE decl or lap function
+ (let ((data (svref def-info 3)))
+ (ecase (car data)
+ ((nil lambda) 'defun)
+ (:methods 'defgeneric)
+ (macro 'defmacro)))))
+
+(defparameter *one-arg-defun-def-info* (%cons-def-info 'defun (encode-lamb=
da-list '(x))))
+
+(defvar *compiler-warn-on-duplicate-definitions* t)
+
+(defun combine-function-infos (name old-info new-info)
+ (let ((old-type (def-info.type old-info))
+ (new-type (def-info.type new-info)))
+ (cond ((and (eq old-type 'defgeneric) (eq new-type 'defgeneric))
+ ;; TODO: Check compatibility of lfbits...
+ ;; TODO: check that all methods implement defgeneric keys
+ (let ((old-methods (def-info.methods old-info))
+ (new-methods (def-info.methods new-info)))
+ (loop for new-method in new-methods
+ do (if (member new-method old-methods :test #'equal)
+ (when *compiler-warn-on-duplicate-definitions*
+ (nx1-whine :duplicate-definition
+ `(method ,@(car new-method) ,name ,(c=
dr new-method))
+ (def-info.file old-info)
+ (def-info.file new-info)))
+ (push new-method old-methods)))
+ (def-info-with-new-methods old-info old-methods)))
+ ((or (eq (or old-type 'defun) (or new-type 'defun))
+ (eq (or old-type 'defgeneric) (or new-type 'defgeneric)))
+ (when (and old-type new-type *compiler-warn-on-duplicate-defini=
tions*)
+ (nx1-whine :duplicate-definition name (def-info.file old-info=
) (def-info.file new-info)))
+ (or new-info old-info))
+ (t
+ (when *compiler-warn-on-duplicate-definitions*
+ (apply #'nx1-whine :duplicate-definition
+ name
+ (def-info.file old-info)
+ (def-info.file new-info)
+ (cond ((eq old-type 'defmacro) '("macro" "function"))
+ ((eq new-type 'defmacro) '("function" "macro"))
+ ((eq old-type 'defgeneric) '("generic function" =
"function"))
+ (t '("function" "generic function")))))
+ new-info))))
+
+(defun record-function-info (name info env)
+ (let* ((definition-env (definition-environment env)))
+ (if definition-env
+ (let* ((defs (defenv.defined definition-env))
+ (already (if (listp defs) (assq name defs) (gethash name defs=
))))
+ (if already
+ (setf (%cdr already) (combine-function-infos name (%cdr already)=
info))
+ (let ((new (cons name info)))
+ (if (listp defs)
+ (setf (defenv.defined definition-env) (cons new defs))
+ (setf (gethash name defs) new))))
+ info))))
+
+
;;; This is different from AUGMENT-ENVIRONMENT.
-;;; If "info" is a lambda expression, then
-;;; record a cons whose CAR is (encoded-lfun-bits . keyvect) and whose cdr
-;;; is the lambda expression iff the function named by "name" is =
-;;; declared/proclaimed INLINE in env
(defun note-function-info (name lambda-expression env)
(let* ((info nil)
(name (maybe-setf-function-name name)))
(when (lambda-expression-p lambda-expression)
(multiple-value-bind (lfbits keyvect) (encode-lambda-list (cadr lamb=
da-expression) t)
- (setq info (cons (cons lfbits keyvect) =
- (retain-lambda-expression name lambda-expression =
env)))))
+ (setq info (%cons-def-info 'defun lfbits keyvect
+ (retain-lambda-expression name lambda-e=
xpression env)))))
(record-function-info name info env))
name)
=
; And this is different from FUNCTION-INFORMATION.
(defun retrieve-environment-function-info (name env)
(let ((defenv (definition-environment env)))
- (if defenv (assq (maybe-setf-function-name name) (defenv.defined defenv=
)))))
+ (when defenv
+ (let ((defs (defenv.defined defenv))
+ (sym (maybe-setf-function-name name)))
+ (if (listp defs) (assq sym defs) (gethash sym defs))))))
=
(defun maybe-setf-function-name (name)
(if (and (consp name) (eq (car name) 'setf))
Modified: trunk/source/level-1/l1-streams.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/level-1/l1-streams.lisp (original)
+++ trunk/source/level-1/l1-streams.lisp Thu Oct 2 14:43:48 2008
@@ -4296,8 +4296,6 @@
(incf (ioblock-charpos ioblock)))
(%string-push-extend char (string-stream-ioblock-string ioblock)))
=
-(defmethod stream-force-output ((stream string-output-stream)) nil)
-
(defun fill-pointer-string-output-stream-ioblock-write-simple-string (iobl=
ock string start-char num-chars)
(let* ((end (+ start-char num-chars))
(nlpos (position #\Newline string :start start-char :end end :fro=
m-end t)))
Modified: trunk/source/level-1/l1-typesys.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/level-1/l1-typesys.lisp (original)
+++ trunk/source/level-1/l1-typesys.lisp Thu Oct 2 14:43:48 2008
@@ -3436,7 +3436,6 @@
(member (istruct-type-name x)
'(args-ctype values-ctype function-ct=
ype))))
=
-(defun function-ctype-p (x) (istruct-typep x 'function-ctype))
(defun valuec-ctype-p (x) (istruct-typep x 'values-ctype))
=
(setf (type-predicate 'args-ctype) 'args-ctype-p
Modified: trunk/source/level-1/l1-utils.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/level-1/l1-utils.lisp (original)
+++ trunk/source/level-1/l1-utils.lisp Thu Oct 2 14:43:48 2008
@@ -91,14 +91,12 @@
;;; an actual method Remember to smash old methods with newer methods
;;; to avoid clutter - done
=
-(defun physical-pathname-p (file)(declare (ignore file)) nil) ; redefined =
later
+(fset 'physical-pathname-p (lambda (file)(declare (ignore file)) nil)) ; r=
edefined later
=
=
;(%defvar *enqueued-window-title* nil)
=
-(defun booted-probe-file (file)
- (declare (ignore file))
- nil)
+(fset 'booted-probe-file (lambda (file) (declare (ignore file)) nil))
=
(queue-fixup
(defun booted-probe-file (file)
Modified: trunk/source/level-1/sysutils.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/level-1/sysutils.lisp (original)
+++ trunk/source/level-1/sysutils.lisp Thu Oct 2 14:43:48 2008
@@ -525,22 +525,31 @@
=
(defparameter *outstanding-deferred-warnings* nil)
=
-
-(defun %defer-warnings (override &optional flags)
- (%istruct 'deferred-warnings (unless override *outstanding-deferred-warn=
ings*) nil nil flags))
+(defun call-with-compilation-unit (thunk &key override)
+ (let* ((*outstanding-deferred-warnings* (%defer-warnings override)))
+ (multiple-value-prog1 (funcall thunk)
+ (report-deferred-warnings))))
+
+(defun %defer-warnings (override &optional flags &aux (parent *outstanding=
-deferred-warnings*))
+ (%istruct 'deferred-warnings
+ (unless override parent)
+ nil
+ (if (or override (not parent))
+ (make-hash-table :test #'eq)
+ (deferred-warnings.defs parent))
+ flags))
=
(defun report-deferred-warnings ()
(let* ((current *outstanding-deferred-warnings*)
(parent (deferred-warnings.parent current))
- (defs (deferred-warnings.defs current))
(warnings (deferred-warnings.warnings current))
(any nil)
(harsh nil))
(if parent
(setf (deferred-warnings.warnings parent) (append warnings (deferred=
-warnings.warnings parent))
- (deferred-warnings.defs parent) (append defs (deferred-warning=
s.defs parent))
parent t)
(let* ((file nil)
+ (defs (deferred-warnings.defs current))
(init t))
(flet ((signal-warning (w)
(multiple-value-setq (harsh any file) (signal-compiler-wa=
rning w init file harsh any))
@@ -550,7 +559,7 @@
(wfname (car args))
(def nil))
(when (if (typep w 'undefined-function-reference)
- (not (setq def (or (assq wfname defs)
+ (not (setq def (or (gethash wfname defs)
(let* ((global (fboundp wfname)))
(if (typep global 'function)
global))))))
@@ -558,9 +567,7 @@
;; Check args in call to forward-referenced function.
(if (or (typep def 'function)
(and (consp def)
- (consp (cdr def))
- (consp (cadr def))
- (caadr def)))
+ (def-info.lfbits (cdr def))))
(when (cdr args)
(destructuring-bind (arglist spread-p)
(cdr args)
@@ -576,11 +583,7 @@
(setf (compiler-warning-stream-position w2)
(compiler-warning-stream-position w))
(signal-warning w2))))))
- (if (or (and (consp def)
- (consp (cdr def))
- (consp (cadr def))
- (eq (cdadr def) 'macro))
- (typep def 'simple-vector))
+ (if (def-info.macro-p (cdr def))
(let* ((w2 (make-condition
'macro-used-before-definition
:file-name (compiler-warning-file-name w)
Modified: trunk/source/level-1/x86-trap-support.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/level-1/x86-trap-support.lisp (original)
+++ trunk/source/level-1/x86-trap-support.lisp Thu Oct 2 14:43:48 2008
@@ -274,8 +274,6 @@
(%get-ptr (xp-gp-regs xp) (+ gp-regs-offset (ash igpr target::word-shift=
))))
(defun (setf indexed-gpr-macptr) (new xp igpr)
(setf (%get-ptr (xp-gp-regs xp) (+ gp-regs-offset (ash igpr target::word=
-shift))) new))
-(defun indexed-gpr-macptr (xp igpr)
- (%get-ptr (xp-gp-regs xp) (+ gp-regs-offset (ash igpr target::word-shift=
))))
(defun encoded-gpr-macptr (xp gpr)
(indexed-gpr-macptr xp (aref *encoded-gpr-to-indexed-gpr* gpr)))
(defun (setf encoded-gpr-macptr) (new xp gpr)
Modified: trunk/source/lib/arrays-fry.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/lib/arrays-fry.lisp (original)
+++ trunk/source/lib/arrays-fry.lisp Thu Oct 2 14:43:48 2008
@@ -216,7 +216,6 @@
(setf (fill-pointer vector) to-size)
vector)
(t (subseq vector 0 to-size))))
-
=
=
; this could be put into print-db as it was in ccl-pr-4.2
Modified: trunk/source/lib/ccl-export-syms.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/lib/ccl-export-syms.lisp (original)
+++ trunk/source/lib/ccl-export-syms.lisp Thu Oct 2 14:43:48 2008
@@ -101,6 +101,7 @@
*signal-printing-errors*
unignore
*warn-if-redefine-kernel*
+ without-duplicate-definition-warnings
require-type
dovector
debugging-function-name
Modified: trunk/source/lib/compile-ccl.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/lib/compile-ccl.lisp (original)
+++ trunk/source/lib/compile-ccl.lisp Thu Oct 2 14:43:48 2008
@@ -309,6 +309,7 @@
)
=
(defun compile-ccl (&optional force-compile)
+ (with-compilation-unit ()
(update-modules 'nxenv force-compile)
(update-modules *compiler-modules* force-compile)
(update-modules (target-compiler-modules) force-compile)
@@ -322,7 +323,7 @@
(update-modules other-lib force-compile)
(require-modules other-lib)
(require-update-modules *code-modules* force-compile))
- (compile-modules *aux-modules* force-compile))
+ (compile-modules *aux-modules* force-compile)))
=
=
=
@@ -352,6 +353,7 @@
;Compile but don't load
=
(defun xcompile-ccl (&optional force)
+ (with-compilation-unit ()
(compile-modules 'nxenv force)
(compile-modules *compiler-modules* force)
(compile-modules (target-compiler-modules) force)
@@ -361,7 +363,7 @@
(compile-modules (target-level-1-modules) force)
(compile-modules (target-other-lib-modules) force)
(compile-modules *code-modules* force)
- (compile-modules *aux-modules* force))
+ (compile-modules *aux-modules* force)))
=
(defun require-update-modules (modules &optional force-compile)
(if (not (listp modules)) (setq modules (list modules)))
@@ -370,13 +372,6 @@
(require-modules module)
(update-modules module force-compile))))
=
-(defun compile-level-1 (&optional force-compile)
- (compile-modules (target-level-1-modules (backend-name *host-backend*))
- force-compile))
-
-
-
- =
=
(defun target-xcompile-ccl (target &optional force)
(let* ((backend (or (find-backend target) *target-backend*))
Modified: trunk/source/lib/defstruct-lds.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/lib/defstruct-lds.lisp (original)
+++ trunk/source/lib/defstruct-lds.lisp Thu Oct 2 14:43:48 2008
@@ -243,11 +243,11 @@
(return
`(progn
(remove-structure-defs ',struct-name) ; lose any previous defs
- ,(defstruct-slot-defs sd refnames env)
+ ,.(defstruct-slot-defs sd refnames env)
,.(if constructor (list (defstruct-constructor sd constructor)))
,.(defstruct-boa-constructors sd boa-constructors)
- ,.(if copier (list (defstruct-copier sd copier env)))
- ,.(if predicate (defstruct-predicate sd named predicate))
+ ,.(if copier (defstruct-copier sd copier env))
+ ,.(if predicate (defstruct-predicate sd named predicate env))
(eval-when (:compile-toplevel)
(define-compile-time-structure =
',sd =
@@ -258,7 +258,7 @@
',sd
,(if (and predicate (null (sd-type sd))) `',predicate)
,.(if documentation (list documentation)))
- ,(%defstruct-compile sd refnames)
+ ,.(%defstruct-compile sd refnames env)
;; Wait until slot accessors are defined, to avoid
;; undefined function warnings in the print function/method.
(%defstruct-set-print-function
@@ -380,16 +380,16 @@
(t `(uvector ,slot , at values)))))
=
(defun defstruct-copier (sd copier env)
- `(progn
- (eval-when (:compile-toplevel)
- (record-function-info ',copier (list (list (encode-lambda-list '(x)=
))) ,env))
- (fset ',copier
- ,(if (eq (sd-type sd) 'list) '#'copy-list '#'copy-uvector))
- (record-source-file ',copier 'function)))
-; (put 'COPY-SHIP 'nx-alias 'copy-list)
-
-(defun defstruct-predicate (sd named predicate &aux (arg (gensym)))
- (let* ((sd-name (sd-name sd))
+ `((eval-when (:compile-toplevel)
+ (record-function-info ',copier ',*one-arg-defun-def-info* ,env))
+ (fset ',copier
+ ,(if (eq (sd-type sd) 'list) '#'copy-list '#'copy-uvector))
+ (record-source-file ',copier 'function)))
+
+(defun defstruct-predicate (sd named predicate env)
+ (declare (ignore env))
+ (let* ((arg (gensym))
+ (sd-name (sd-name sd))
(body
(case (sd-type sd)
((nil) `(structure-typep ,arg ',(find-class-cell sd-name t)))
@@ -397,7 +397,6 @@
(t `(and (uvector-subtype-p ,arg ,(defstruct-reftype (sd-type =
sd)))
(< ,named (uvsize ,arg))
(eq (uvref ,arg ,named) ',sd-name))))))
- `((setf (symbol-function ',predicate) #'(lambda (,arg) ,body))
- (record-source-file ',predicate 'function))))
+ `((defun ,predicate (,arg) ,body))))
=
; End of defstruct-lds.lisp
Modified: trunk/source/lib/defstruct.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/lib/defstruct.lisp (original)
+++ trunk/source/lib/defstruct.lisp Thu Oct 2 14:43:48 2008
@@ -20,9 +20,12 @@
=
(eval-when (eval compile)
(require 'defstruct-macros)
+
)
=
-
+#-BOOTSTRAPPED
+(unless (boundp '*one-arg-defun-def-info*)
+ (setq *one-arg-defun-def-info* nil))
=
(defvar %structure-refs% (make-hash-table :test #'eq))
(defvar %defstructs% (make-hash-table :test #'eq))
@@ -129,7 +132,7 @@
(ssd-offset slot))))))))))))
=
;;; return stuff for defstruct to compile
-(defun %defstruct-compile (sd refnames)
+(defun %defstruct-compile (sd refnames env)
(let ((stuff)) =
(dolist (slot (sd-slots sd))
(unless (fixnump (ssd-name slot))
@@ -141,13 +144,13 @@
; This should be a style-warning
(warn "Accessor ~s at different position than in included =
structure"
accessor)))
- (let ((fn (slot-accessor-fn slot accessor)))
+ (let ((fn (slot-accessor-fn slot accessor env)))
(push
`(progn
- ,fn
+ ,.fn
(puthash ',accessor %structure-refs% ',(ssd-type-and-ref=
info slot)))
stuff))))))
- `(progn ,@(nreverse stuff))))
+ (nreverse stuff)))
=
=
; no #. for cross compile
@@ -182,27 +185,33 @@
;;; PPC. So can use that space optimization iff host and target are
;;; the same.
=
-(defparameter *defstruct-share-accessor-functions* t)
-
-(defun slot-accessor-fn (slot name &aux (ref (ssd-reftype slot))
- (offset (ssd-offset slot)))
- (cond ((eq ref $defstruct-nth)
- (if (and (%i< offset 10) *defstruct-share-accessor-functions*)
- `(fset ',name
+
+(defparameter *defstruct-share-accessor-functions* t) ;; TODO: isn't it =
time to get rid of this?
+
+(defun slot-accessor-fn (slot name env &aux (ref (ssd-reftype slot)) (offs=
et (ssd-offset slot)))
+ (cond ((eq ref $defstruct-nth)
+ (if (and (%i< offset 10) *defstruct-share-accessor-functions*)
+ `((eval-when (:compile-toplevel)
+ (record-function-info ',name ',*one-arg-defun-def-info* ,en=
v))
+ (fset ',name
,(symbol-function
(%svref '#(first second third fourth fifth
- sixth seventh eighth ninth tenth) o=
ffset)))
- `(defun ,name (x) (nth ,offset x))))
- ((eq ref $defstruct-struct)
- (if (and (%i< offset 10) *defstruct-share-accessor-functions*)
- `(fset ',name , (%svref *struct-ref-vector* offset))
- `(defun ,name (x) (struct-ref x ,offset))))
- ((or (eq ref target::subtag-simple-vector)
- (eq ref $defstruct-simple-vector))
- (if (and (%i< offset 10) *defstruct-share-accessor-functions*)
- `(fset ',name ,(%svref *svref-vector* offset))
- `(defun ,name (x) (svref x ,offset))))
- (t `(defun ,name (x) (uvref x ,offset)))))
+ sixth seventh eighth ninth tenth) offset)=
)))
+ `((defun ,name (x) (nth ,offset x)))))
+ ((eq ref $defstruct-struct)
+ (if (and (%i< offset 10) *defstruct-share-accessor-functions*)
+ `((eval-when (:compile-toplevel)
+ (record-function-info ',name ',*one-arg-defun-def-info* ,en=
v)) =
+ (fset ',name , (%svref *struct-ref-vector* offset)))
+ `((defun ,name (x) (struct-ref x ,offset)))))
+ ((or (eq ref target::subtag-simple-vector)
+ (eq ref $defstruct-simple-vector))
+ (if (and (%i< offset 10) *defstruct-share-accessor-functions*)
+ `((eval-when (:compile-toplevel)
+ (record-function-info ',name ',*one-arg-defun-def-info* ,en=
v))
+ (fset ',name ,(%svref *svref-vector* offset)))
+ `((defun ,name (x) (svref x ,offset)))))
+ (t `((defun ,name (x) (uvref x ,offset))))))
=
(defun defstruct-reftype (type)
(cond ((null type) $defstruct-struct)
@@ -210,6 +219,7 @@
(t (element-type-subtype (cadr type)))))
=
(defun defstruct-slot-defs (sd refnames env)
+ (declare (ignore env))
(let ((ref (defstruct-reftype (sd-type sd))) name defs)
(dolist (slot (sd-slots sd))
(ssd-set-reftype slot ref)
@@ -218,11 +228,7 @@
(unless (sd-refname-pos-in-included-struct sd name)
(push name defs))))
(setq defs (nreverse defs))
- (let* ((info (list (cons (dpb 1 $lfbits-numreq 0) nil))))
- `(progn
- (eval-when (:compile-toplevel)
- ,@(mapcar #'(lambda (name) `(record-function-info ',name ',info =
,env)) defs))
- (declaim (inline , at defs))))))
+ `((declaim (inline , at defs)))))
=
;;;Used by setf and whatever...
(defun defstruct-ref-transform (predicate-or-type-and-refinfo args)
Modified: trunk/source/lib/format.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/lib/format.lisp (original)
+++ trunk/source/lib/format.lisp Thu Oct 2 14:43:48 2008
@@ -390,15 +390,17 @@
=
; in l1-format
(defvar *logical-block-xp* nil)
-(defun pop-format-arg (&aux (args *format-arguments*)(xp *logical-block-xp=
*))
- (when xp
- (if (pprint-pop-check+ args xp) ; gets us level and length stuff in lo=
gical block
- (throw 'logical-block nil))) =
- (if (and (null args)(null xp)) ; what if its 3?
- (format-error "Missing argument")
- (progn
- (setq *format-arguments* (cdr args))
- (%car args))))
+
+(without-duplicate-definition-warnings
+ (defun pop-format-arg (&aux (args *format-arguments*)(xp *logical-block-x=
p*))
+ (when xp
+ (if (pprint-pop-check+ args xp) ; gets us level and length stuff i=
n logical block
+ (throw 'logical-block nil))) =
+ (if (and (null args)(null xp)) ; what if its 3?
+ (format-error "Missing argument")
+ (progn
+ (setq *format-arguments* (cdr args))
+ (%car args)))))
=
; SUB-FORMAT is now defined in L1-format.lisp
; DEFFORMAT is also defined there.
Modified: trunk/source/lib/macros.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/lib/macros.lisp (original)
+++ trunk/source/lib/macros.lisp Thu Oct 2 14:43:48 2008
@@ -624,15 +624,6 @@
(eval-when (:load-toplevel :execute)
(%define-symbol-macro ',name ',expansion))))
=
-(defun record-function-info (name info env)
- (let* ((definition-env (definition-environment env)))
- (if definition-env
- (let* ((already (assq name (defenv.defined definition-env))))
- (if already
- (if info (%rplacd already info))
- (push (cons name info) (defenv.defined definition-env)))
- info))))
-
;; ---- allow inlining setf functions
(defmacro defun (spec args &body body &environment env &aux global-name in=
line-spec)
"Define a function at top level."
@@ -661,8 +652,6 @@
(cons doc lambda-expression)
doc)))
`(progn
- (eval-when (:compile-toplevel)
- (note-function-info ',spec ',lambda-expression ,env))
(%defun (nfunction ,spec ,lambda-expression) ',info)
',spec))))
=
@@ -745,16 +734,6 @@
(let* ((temp (gensym)))
`(let* ((,temp (function-to-function-vector ,f)))
(%svref ,temp (the fixnum (1- (the fixnum (uvsize ,temp))))))))
-
-; %Pascal-Functions% Entry
-; Used by "l1;ppc-callback-support" & "lib;dumplisp"
-(def-accessor-macros %svref
- pfe.routine-descriptor
- pfe.proc-info
- pfe.lisp-function
- pfe.sym
- pfe.without-interrupts
- pfe.trace-p)
=
(defmacro cond (&rest args &aux clause)
(when args
@@ -950,6 +929,9 @@
(warn "Invalid lambda expression: ~s" lambda-expression))
`(function (lambda ,paramlist , at body)))
=
+; This isn't
+(defmacro nlambda (name (&rest arglist) &body body)
+ `(nfunction ,name (lambda ,arglist , at body)))
=
(defmacro when (test &body body)
"If the first argument is true, the rest of the forms are
@@ -1457,8 +1439,10 @@
WITH-COMPILATION-UNIT form grabs the undefined warnings. Specifying
OVERRIDE true causes that form to grab any enclosed warnings, even=
if
it is enclosed by another WITH-COMPILATION-UNIT."
- `(let* ((*outstanding-deferred-warnings* (%defer-warnings ,override)))
- (multiple-value-prog1 (progn , at body) (report-deferred-warnings))))
+ `(flet ((with-compilation-unit-body ()
+ , at body))
+ (declare (dynamic-extent #'with-compilation-unit-body))
+ (call-with-compilation-unit #'with-compilation-unit-body :override ,o=
verride)))
=
; Yow! Another Done Fun.
(defmacro with-standard-io-syntax (&body body &environment env)
@@ -1736,14 +1720,11 @@
`(progn
(eval-when (:compile-toplevel)
(record-function-info ',(maybe-setf-function-name name)
- ',(list (list (encode-gf-lambda-list
- lambda-list)))
- ,env))
- (compiler-let ((*nx-method-warning-name* =
- (list ',name
- ,@(mapcar #'(lambda (x) `',x) qualifiers)
- ',specializers)))
- (ensure-method ',name ,specializers-form
+ ',(%cons-def-info 'defmethod (encode-gf-lam=
bda-list lambda-list) nil nil
+ specializers qualifiers)
+ ,env))
+ (compiler-let ((*nx-method-warning-name* '(,name , at qualifiers ,spec=
ializers)))
+ (ensure-method ',name ,specializers-form
:function ,function-form
:qualifiers ',qualifiers
:lambda-list ',lambda-list
@@ -1911,8 +1892,8 @@
(documentation-p nil)
(readers nil)
(writers nil)
- (reader-info (list (cons (dpb 1 $lfbits-numreq 0) ni=
l)))
- (writer-info (list (cons (dpb 2 $lfbits-numreq 0) ni=
l))))
+ (reader-info (%cons-def-info 'defmethod (dpb 1 $lfbi=
ts-numreq 0) nil nil (list class-name)))
+ (writer-info (%cons-def-info 'defmethod (dpb 2 $lfbi=
ts-numreq 0) nil nil (list t class-name))))
(when (memq slot-name slot-names)
(SIGNAL-PROGRAM-error "Multiple slots named ~S in DEFCL=
ASS ~S" slot-name class-name))
(push slot-name slot-names)
@@ -2020,7 +2001,7 @@
`(progn
(eval-when (:compile-toplevel)
(record-function-info ',(maybe-setf-function-name function-name)
- ',(list (list (encode-gf-lambda-list lamb=
da-list)))
+ ',(%cons-def-info 'defgeneric (encode-gf-=
lambda-list lambda-list))
,env))
(let ((,gf (%defgeneric
',function-name ',lambda-list ',method-combination ',g=
eneric-function-class =
@@ -2846,6 +2827,11 @@
(declare (dynamic-extent ,thunk))
(funcall-with-error-reentry-detection ,thunk))))
=
+(defmacro without-duplicate-definition-warnings (&body body)
+ `(compiler-let ((*compiler-warn-on-duplicate-definitions* nil))
+ , at body))
+
+
#+ppc-target
(defmacro scan-for-instr (mask opcode fn pc-index &optional (tries *trap-l=
ookup-tries*))
`(%scan-for-instr ,mask ,opcode ,fn ,pc-index ,tries))
Modified: trunk/source/lib/method-combination.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/lib/method-combination.lisp (original)
+++ trunk/source/lib/method-combination.lisp Thu Oct 2 14:43:48 2008
@@ -91,11 +91,12 @@
`(gethash ,method-combination-type *method-combination-info*))
=
; Need to special case (find-method-combination #'find-method-combination =
...)
-(defmethod find-method-combination ((generic-function standard-generic-fun=
ction)
- method-combination-type
- method-combination-options)
- (%find-method-combination
- generic-function method-combination-type method-combination-options))
+(without-duplicate-definition-warnings ;; override version in l1-clos-boot=
.lisp
+ (defmethod find-method-combination ((generic-function standard-generic-fu=
nction)
+ method-combination-type
+ method-combination-options)
+ (%find-method-combination
+ generic-function method-combination-type method-combination-options)))
=
(defun %find-method-combination (gf type options)
(declare (ignore gf))
Modified: trunk/source/lib/misc.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/lib/misc.lisp (original)
+++ trunk/source/lib/misc.lisp Thu Oct 2 14:43:48 2008
@@ -157,9 +157,6 @@
(defmethod documentation (thing doc-id)
(%get-documentation thing doc-id))
=
-(defun set-documentation (thing doc-id new)
- (setf (documentation thing doc-id) new))
-
(defmethod (setf documentation) (new thing doc-id)
(%put-documentation thing doc-id new))
=
Modified: trunk/source/lib/nfcomp.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/lib/nfcomp.lisp (original)
+++ trunk/source/lib/nfcomp.lisp Thu Oct 2 14:43:48 2008
@@ -145,6 +145,8 @@
(skip-compile-file ()
:report (lambda (stream) (format stream "Skip compiling ~s" src))
(return))))))
+
+(defvar *fasl-compile-time-env* nil)
=
(defun %compile-file (src output-file verbose print load features
save-local-symbols save-doc-strings save-definit=
ions
@@ -199,15 +201,17 @@
(*target-ftd* (backend-target-foreign-type-data target-backend))
(defenv (new-definition-environment))
(lexenv (new-lexical-environment defenv))
+ (*fasl-compile-time-env* (new-lexical-environment (new-defini=
tion-environment)))
(*fcomp-external-format* external-format))
(let ((forms nil))
(let* ((*outstanding-deferred-warnings* (%defer-warnings nil)))
(rplacd (defenv.type defenv) *outstanding-deferred-warnings*)
+ (setf (defenv.defined defenv) (deferred-warnings.defs *outstan=
ding-deferred-warnings*))
+
(setq forms (fcomp-file src orig-src lexenv))
+
(setf (deferred-warnings.warnings *outstanding-deferred-warnin=
gs*) =
- (append *fasl-deferred-warnings* (deferred-warnings.warn=
ings *outstanding-deferred-warnings*))
- (deferred-warnings.defs *outstanding-deferred-warnings*)
- (append (defenv.defined defenv) (deferred-warnings.defs =
*outstanding-deferred-warnings*)))
+ (append *fasl-deferred-warnings* (deferred-warnings.warn=
ings *outstanding-deferred-warnings*)))
(when *compile-verbose* (fresh-line))
(multiple-value-bind (any harsh) (report-deferred-warnings)
(setq *fasl-warnings-signalled-p* (or *fasl-warnings-signall=
ed-p* any)
@@ -256,6 +260,7 @@
(new-compiler-policy :force-boundp-checks t))
=
(defun %compile-time-eval (form env)
+ (declare (ignore env))
(let* ((*target-backend* *host-backend*))
;; The HANDLER-BIND here is supposed to note WARNINGs that're
;; signaled during (eval-when (:compile-toplevel) processing; this
@@ -271,7 +276,8 @@
(signal c))))
(funcall (compile-named-function
`(lambda () ,form)
- :env env :policy *compile-time-evaluation-policy*)))))
+ :env *fasl-compile-time-env*
+ :policy *compile-time-evaluation-policy*)))))
=
=
;;; No methods by default, not even for structures. This really sux.
@@ -427,7 +433,8 @@
(fcomp-output-form $fasl-src env *loading-file-source-file*)
(let* ((*fcomp-previous-position* nil))
(loop
- (let* ((*fcomp-stream-position* (file-position stream)))
+ (let* ((*fcomp-stream-position* (file-position stream))
+ (*nx-warnings* nil))
(unless (eq read-package *package*)
(fcomp-compile-toplevel-forms env)
(setq read-package *package*))
@@ -442,6 +449,7 @@
(setq form (read stream nil eofval)))))
(when (eq eofval form) (return))
(fcomp-form form env processing-mode)
+ (fcomp-signal-or-defer-warnings *nx-warnings* env)
(setq *fcomp-previous-position* *fcomp-stream-position*))))
(while (setq form *fasl-eof-forms*)
(setq *fasl-eof-forms* nil)
@@ -624,14 +632,19 @@
=
(defun define-compile-time-constant (symbol initform env)
(note-variable-info symbol t env)
- (let ((definition-env (definition-environment env)))
- (when definition-env
+ (let ((compile-time-defenv (definition-environment *fasl-compile-time-en=
v*))
+ (definition-env (definition-environment env)))
+ (when (or compile-time-defenv definition-env)
(multiple-value-bind (value error) =
(ignore-errors (values (%compile-time-eval init=
form env) nil))
(when error
(warn "Compile-time evaluation of DEFCONSTANT initial value form=
for ~S while ~
compiling ~S signalled the error: ~&~A" symbol *fasl-sour=
ce-file* error))
- (push (cons symbol (if error (%unbound-marker-8) value)) (defenv.c=
onstants definition-env))))
+ (let ((cell (cons symbol (if error (%unbound-marker-8) value))))
+ (when definition-env
+ (push cell (defenv.constants definition-env)))
+ (when compile-time-defenv
+ (push cell (defenv.constants compile-time-defenv))))))
symbol))
=
(defun fcomp-load-%defconstant (form env)
@@ -677,19 +690,28 @@
=
=
(defun define-compile-time-macro (name lambda-expression env)
- (let ((definition-env (definition-environment env)))
- (when definition-env
- (push (list* name =
- 'macro =
- (compile-named-function lambda-expression :name name :e=
nv env))
- (defenv.functions definition-env))
- (record-function-info name (list (cons nil 'macro)) env))
+ (let ((compile-time-defenv (definition-environment *fasl-compile-time-en=
v*))
+ (definition-env (definition-environment env)))
+ (when (or definition-env compile-time-defenv)
+ (let ((cell (list* name =
+ 'macro =
+ (compile-named-function lambda-expression :name n=
ame :env env))))
+ (when compile-time-defenv
+ (push cell (defenv.functions compile-time-defenv)))
+ (when definition-env
+ (push cell (defenv.functions definition-env))))
+ (record-function-info name (%cons-def-info 'defmacro) env))
name))
=
(defun define-compile-time-symbol-macro (name expansion env)
- (let* ((definition-env (definition-environment env)))
- (if definition-env
- (push (cons name expansion) (defenv.symbol-macros definition-env)))
+ (let ((compile-time-defenv (definition-environment *fasl-compile-time-en=
v*))
+ (definition-env (definition-environment env)))
+ (when (or definition-env compile-time-defenv)
+ (let ((cell (cons name expansion)))
+ (when compile-time-defenv
+ (push cell (defenv.functions compile-time-defenv)))
+ (when definition-env
+ (push cell (defenv.functions definition-env)))))
name))
=
=
@@ -757,6 +779,8 @@
(if (and (eq (car doc) 'quote) (consp (cadr doc)))
(setf (car (cadr doc)) nil))
(setq doc nil)))
+ (when (and (consp fn) (eq (%car fn) 'nfunction))
+ (note-function-info (cadr fn) (caddr fn) env))
(if (and (constantp doc)
(setq fn (fcomp-function-arg fn env)))
(progn
Modified: trunk/source/lib/pprint.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/lib/pprint.lisp (original)
+++ trunk/source/lib/pprint.lisp Thu Oct 2 14:43:48 2008
@@ -1259,13 +1259,14 @@
(return nil)))))))
=
=0C
-(defun pprint (object &optional (stream *standard-output*))
- "Prettily output OBJECT preceded by a newline."
- (setq stream (decode-stream-arg stream))
- (terpri stream)
- (let ((*print-escape* T) (*print-pretty* T))
- (write-1 object stream))
- (values))
+(without-duplicate-definition-warnings ;; override l1-io version.
+ (defun pprint (object &optional (stream *standard-output*))
+ "Prettily output OBJECT preceded by a newline."
+ (setq stream (decode-stream-arg stream))
+ (terpri stream)
+ (let ((*print-escape* T) (*print-pretty* T))
+ (write-1 object stream))
+ (values)))
=
=0C
;Any format string that is converted to a function is always printed
Modified: trunk/source/lib/sequences.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/lib/sequences.lisp (original)
+++ trunk/source/lib/sequences.lisp Thu Oct 2 14:43:48 2008
@@ -994,40 +994,6 @@
(nreverse temp)
temp))
=
-;;; Modified to clear the elements between the old and new fill pointers
-;;; so they won't hold on to garbage.
-(defun vector-delete (item vector test test-not key start end inc count
- &aux (length (length vector)) pos fill val)
- (setq key (adjust-key key))
- (multiple-value-setq (test test-not) (adjust-test-args item test test-no=
t))
- (setq end (check-sequence-bounds vector start end))
- (if (%i< inc 0) (psetq start (%i- end 1) end (%i- start 1)))
- (setq fill (setq pos start))
- (loop
- (if (or (eq count 0) (eq pos end)) (return))
- (if (matchp2 item (setq val (aref vector pos)) test test-not key)
- (setq count (%i- count 1))
- (progn
- (if (neq fill pos) (setf (aref vector fill) val))
- (setq fill (%i+ fill inc))))
- (setq pos (%i+ pos inc)))
- (if (%i> fill pos) (psetq fill (%i+ pos 1) pos (%i+ fill 1)))
- (loop
- (if (eq pos length) (return))
- (setf (aref vector fill) (aref vector pos))
- (setq fill (%i+ fill 1) pos (%i+ pos 1)))
- (when (gvectorp (array-data-and-offset vector))
- (let ((old-fill (fill-pointer vector))
- (i fill))
- (declare (fixnum i old-fill))
- (loop
- (when (>=3D i old-fill) (return))
- (setf (aref vector i) nil)
- (incf i))))
- (setf (fill-pointer vector) fill)
- vector)
-
-
; The vector will be freshly consed & nothing is displaced to it,
; so it's legit to destructively truncate it.
; Likewise, it's ok to access its components with UVREF.
Modified: trunk/source/library/lispequ.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/library/lispequ.lisp (original)
+++ trunk/source/library/lispequ.lisp Thu Oct 2 14:43:48 2008
@@ -271,9 +271,9 @@
=
(def-accessors (logical-pathname) %svref
() ; 'logical-pathname
- %pathname-directory
- %pathname-name
- %pathname-type =
+ nil ; %pathname-directory
+ nil ; %pathname-name
+ nil ; %pathname-type =
%logical-pathname-host
%logical-pathname-version)
=
@@ -1403,6 +1403,23 @@
entry-full-spec ;list of priority and type specifier
)
=
+;;; MacOS toolbox routines were once written mostly in Pascal, so some
+;;; code still refers to callbacks from foreign code as "pascal-callable
+;;; functions".
+
+; %Pascal-Functions% Entry
+(def-accessor-macros %svref
+ pfe.routine-descriptor
+ pfe.proc-info
+ pfe.lisp-function
+ pfe.sym
+ pfe.without-interrupts
+ pfe.trace-p)
+
+(defmacro %cons-pfe (routine-descriptor proc-info lisp-function sym withou=
t-interrupts)
+ `(vector ,routine-descriptor ,proc-info ,lisp-function ,sym ,without-int=
errupts nil))
+
+
(def-accessors %svref
() ; 'xp-structure
xp-base-stream ;;The stream io eventually goes to.
More information about the Openmcl-cvs-notifications
mailing list