[Openmcl-cvs-notifications] r13031 - in /release/1.4/source: cocoa-ide/ cocoa-ide/ide-contents/Resources/English.lproj/project.nib/ compiler/ compiler/X86/ doc/ doc/src/ level-0/X86/ level-0/X86/X8632/ level-1/ lib/ library/ lisp-kernel/ objc-bridge/ scripts/ tools/
rme at clozure.com
rme at clozure.com
Thu Oct 15 14:48:26 EDT 2009
Author: rme
Date: Thu Oct 15 14:48:26 2009
New Revision: 13031
Log:
Trunk changes r12910 through r13030 (need to update interfaces separately).
Added:
release/1.4/source/cocoa-ide/ide-contents/Resources/English.lproj/proje=
ct.nib/
- copied from r13030, trunk/source/cocoa-ide/ide-contents/Resources/E=
nglish.lproj/project.nib/
release/1.4/source/cocoa-ide/project.lisp
- copied unchanged from r13030, trunk/source/cocoa-ide/project.lisp
release/1.4/source/lib/x86-watch.lisp
- copied unchanged from r13030, trunk/source/lib/x86-watch.lisp
Modified:
release/1.4/source/cocoa-ide/cocoa-editor.lisp
release/1.4/source/cocoa-ide/defsystem.lisp
release/1.4/source/compiler/X86/x86-disassemble.lisp
release/1.4/source/compiler/nx-basic.lisp
release/1.4/source/compiler/nx.lisp
release/1.4/source/compiler/nx0.lisp
release/1.4/source/doc/ccl-documentation.html
release/1.4/source/doc/src/ffi.xml
release/1.4/source/doc/src/gc.xml
release/1.4/source/doc/src/platform-notes.xml
release/1.4/source/level-0/X86/X8632/x8632-utils.lisp
release/1.4/source/level-0/X86/x86-utils.lisp
release/1.4/source/level-1/l1-aprims.lisp
release/1.4/source/level-1/l1-clos-boot.lisp
release/1.4/source/level-1/l1-error-system.lisp
release/1.4/source/level-1/l1-reader.lisp
release/1.4/source/level-1/l1-readloop.lisp
release/1.4/source/level-1/linux-files.lisp
release/1.4/source/level-1/sysutils.lisp
release/1.4/source/level-1/x86-trap-support.lisp
release/1.4/source/lib/ccl-export-syms.lisp
release/1.4/source/lib/compile-ccl.lisp
release/1.4/source/lib/ffi-win64.lisp (props changed)
release/1.4/source/lib/level-2.lisp
release/1.4/source/lib/macros.lisp
release/1.4/source/lib/misc.lisp
release/1.4/source/lib/nfcomp.lisp
release/1.4/source/lib/systems.lisp
release/1.4/source/library/leaks.lisp
release/1.4/source/library/x86-win64-syscalls.lisp (props changed)
release/1.4/source/lisp-kernel/windows-calls.c
release/1.4/source/lisp-kernel/x86-exceptions.c
release/1.4/source/lisp-kernel/x86-gc.c
release/1.4/source/lisp-kernel/x86_print.c
release/1.4/source/objc-bridge/objc-runtime.lisp
release/1.4/source/objc-bridge/objc-support.lisp
release/1.4/source/scripts/makedmg
release/1.4/source/tools/asdf.lisp
Modified: release/1.4/source/cocoa-ide/cocoa-editor.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
--- release/1.4/source/cocoa-ide/cocoa-editor.lisp (original)
+++ release/1.4/source/cocoa-ide/cocoa-editor.lisp Thu Oct 15 14:48:26 2009
@@ -2568,11 +2568,7 @@
(make-hemlock-buffer
(lisp-string-from-nsstring
(#/displayName doc))
- :modes '("Lisp" "Editor"))))
- ;; Cocotron's NSUndoManager implementation causes CPU usage to peg a=
t 90+%
- ;; Remove this when Cocotron issue #273 is fixed
- ;; (http://code.google.com/p/cocotron/issues/detail?id=3D273)
- #+cocotron (#/setHasUndoManager: doc nil))
+ :modes '("Lisp" "Editor")))))
(with-slots (encoding) doc
(setq encoding (or (get-default-encoding) #$NSISOLatin1StringEncodin=
g)))
(setq *last-document-created* doc)
Modified: release/1.4/source/cocoa-ide/defsystem.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
--- release/1.4/source/cocoa-ide/defsystem.lisp (original)
+++ release/1.4/source/cocoa-ide/defsystem.lisp Thu Oct 15 14:48:26 2009
@@ -76,6 +76,7 @@
"cocoa-grep"
"cocoa-backtrace"
"inspector"
+ "project"
"preferences"
"processes-window"
"apropos-window"
Modified: release/1.4/source/compiler/X86/x86-disassemble.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
--- release/1.4/source/compiler/X86/x86-disassemble.lisp (original)
+++ release/1.4/source/compiler/X86/x86-disassemble.lisp Thu Oct 15 14:48:2=
6 2009
@@ -35,7 +35,23 @@
=
(defmethod print-object ((xdi x86-disassembled-instruction) stream)
(print-unreadable-object (xdi stream :type t :identity t)
- (format stream "~a" (x86-di-mnemonic xdi))))
+ (dolist (p (x86-di-prefixes xdi))
+ (format stream "(~a) " p))
+ (format stream "(~a" (x86-di-mnemonic xdi))
+ (let* ((op0 (x86-di-op0 xdi))
+ (op1 (x86-di-op1 xdi))
+ (op2 (x86-di-op2 xdi))
+ (ds (make-x86-disassembly-state :mode-64 #+x8664-target t
+ #+x8632-target nil
+ :code-vector nil
+ :code-pointer 0)))
+ (when op0
+ (write-x86-lap-operand stream op0 ds)
+ (when op1
+ (write-x86-lap-operand stream op1 ds)
+ (when op2
+ (write-x86-lap-operand stream op2 ds)))))
+ (format stream ")")))
=
(defstruct (x86-disassembly-state (:conc-name x86-ds-))
(mode-64 t)
@@ -2780,14 +2796,14 @@
(format t "~& (~a)~%" p))
(format t " (~a" (x86-di-mnemonic instruction))
(let* ((op0 (x86-di-op0 instruction))
- (op1 (x86-di-op1 instruction))
- (op2 (x86-di-op2 instruction)))
+ (op1 (x86-di-op1 instruction))
+ (op2 (x86-di-op2 instruction)))
(when op0
- (write-x86-lap-operand t op0 ds)
- (when op1
- (write-x86-lap-operand t op1 ds)
- (when op2
- (write-x86-lap-operand t op2 ds)))))
+ (write-x86-lap-operand t op0 ds)
+ (when op1
+ (write-x86-lap-operand t op1 ds)
+ (when op2
+ (write-x86-lap-operand t op2 ds)))))
(format t ")")
(format t "~%")
(1+ seq)))
Modified: release/1.4/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
--- release/1.4/source/compiler/nx-basic.lisp (original)
+++ release/1.4/source/compiler/nx-basic.lisp Thu Oct 15 14:48:26 2009
@@ -582,14 +582,14 @@
(return-from nx-declared-inline-p (eq (cddr decl) 'inline))))
(setq env (lexenv.parent-env env))))
=
-(defun report-compile-time-argument-mismatch (condition stream)
+(defun report-compile-time-argument-mismatch (condition stream &aux (type =
(compiler-warning-warning-type condition)))
(destructuring-bind (callee reason args spread-p)
(compiler-warning-args condition)
(format stream "In the ~a ~s with arguments ~:s,~% "
(if spread-p "application of" "call to")
callee
args)
- (case (car reason)
+ (ecase (car reason)
(:toomany
(destructuring-bind (provided max)
(cdr reason)
@@ -604,22 +604,30 @@
(:unknown-keyword
(destructuring-bind (badguy goodguys)
(cdr reason)
- (format stream "the keyword argument~:[ ~s is~;s~{ ~s~^~#[~; and~=
:;,~]~} are~] not one of ~s, which are recognized~& by "
- (consp badguy) badguy goodguys))))
+ (format stream "the keyword argument~:[ ~s is~;s~{ ~s~^~#[~; and~=
:;,~]~} are~] not one of ~:s, which are recognized by "
+ (consp badguy) badguy goodguys)))
+ (:unknown-gf-keywords
+ (let ((badguys (cadr reason)))
+ (when (and (consp badguys) (null (%cdr badguys))) (setq badguys=
(car badguys)))
+ (format stream "the keyword argument~:[ ~s is~;s~{ ~s~^~#[~; an=
d~:;,~]~} are~] not recognized by "
+
+ (consp badguys) badguys))))
(format stream
- (ecase (compiler-warning-warning-type condition) =
+ (ecase type
(:ftype-mismatch "the FTYPE declaration of ~s")
(:global-mismatch "the current global definition of ~s")
(:environment-mismatch "the definition of ~s visible in the =
current compilation unit.")
- (:lexical-mismatch "the lexically visible definition of ~s"))
+ (:lexical-mismatch "the lexically visible definition of ~s")
+ ;; This can happen when compiling without compilation unit:
+ (:deferred-mismatch "~s"))
callee)))
=
(defparameter *compiler-warning-formats*
'((:special . "Undeclared free variable ~S")
(:unused . "Unused lexical variable ~S")
(:ignore . "Variable ~S not ignored.")
- (:undefined-function . "Undefined function ~S") ;; (not reported if de=
fined later)
- (:undefined-type . "Undefined type ~S") ;; (not reported if de=
fined later)
+ (:undefined-function . "Undefined function ~S") ;; (deferred)
+ (:undefined-type . "Undefined type ~S") ;; (deferred)
(:unknown-type-in-declaration . "Unknown or invalid type ~S, declarati=
on ignored")
(:bad-declaration . "Unknown or invalid declaration ~S")
(:invalid-type . report-invalid-type-compiler-warning)
@@ -631,10 +639,14 @@
(:environment-mismatch . report-compile-time-argument-mismatch)
(:lexical-mismatch . report-compile-time-argument-mismatch) =
(:ftype-mismatch . report-compile-time-argument-mismatch)
+ (:deferred-mismatch . report-compile-time-argument-mismatch)
(:type . "Type declarations violated in ~S")
(:type-conflict . "Conflicting type declarations for ~S")
(:special-fbinding . "Attempt to bind compiler special name: ~s. Resul=
t undefined.")
(:lambda . "Suspicious lambda-list: ~s")
+ (:incongruent-gf-lambda-list . "Lambda list of generic function ~s is =
incongruent with previously defined methods")
+ (:incongruent-method-lambda-list . "Lambda list of ~s is incongruent w=
ith previous definition of ~s")
+ (:gf-keys-not-accepted . "~s does not accept keywords ~s required by t=
he generic functions")
(:result-ignored . "Function result ignored in call to ~s")
(:duplicate-definition . report-compile-time-duplicate-definition)
(:format-error . "~:{~@?~%~}")
Modified: release/1.4/source/compiler/nx.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
--- release/1.4/source/compiler/nx.lisp (original)
+++ release/1.4/source/compiler/nx.lisp Thu Oct 15 14:48:26 2009
@@ -198,6 +198,7 @@
(defparameter *compiler-whining-conditions*
'((:undefined-function . undefined-function-reference)
(:undefined-type . undefined-type-reference)
+ (:deferred-mismatch . undefined-keyword-reference)
(:invalid-type . invalid-type-warning)
(:global-mismatch . invalid-arguments-global)
(:lexical-mismatch . invalid-arguments)
Modified: release/1.4/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
--- release/1.4/source/compiler/nx0.lisp (original)
+++ release/1.4/source/compiler/nx0.lisp Thu Oct 15 14:48:26 2009
@@ -2096,11 +2096,11 @@
=
=
(defun innermost-lfun-bits-keyvect (def)
- (declare (notinline innermost-lfun-bits-keyvect))
(let* ((inner-def (closure-function (find-unencapsulated-definition def)=
))
(bits (lfun-bits inner-def))
(keys (lfun-keyvect inner-def)))
(declare (fixnum bits))
+ #+no
(when (and (eq (ash 1 $lfbits-gfn-bit)
(logand bits (logior (ash 1 $lfbits-gfn-bit)
(ash 1 $lfbits-method-bit))))
@@ -2109,73 +2109,108 @@
keys nil))
(values bits keys)))
=
+(defun def-info-bits-keyvect (info)
+ (let ((bits (def-info.lfbits info)))
+ (when (and (eq (def-info.function-type info) 'defgeneric)
+ (logbitp $lfbits-keys-bit bits)
+ (not (logbitp $lfbits-aok-bit bits))
+ #-BOOTSTRAPPED (fboundp 'def-info-method.keyvect)
+ (loop for m in (def-info.methods info)
+ thereis (null (def-info-method.keyvect m))))
+ ;; Some method has &aok, don't bother checking keywords.
+ (setq bits (logior bits (ash 1 $lfbits-aok-bit))))
+ (values bits (def-info.keyvect info))))
+
=
(defun nx1-check-call-args (def arglist spread-p)
- (let* ((deftype (if (functionp def) =
- :global-mismatch
- (if (istruct-typep def 'afunc)
- :lexical-mismatch
- :environment-mismatch)))
- (reason nil))
- (multiple-value-bind (bits keyvect)
- (case deftype
- (:global-mismatch (innermost-lfun-bits-keyvect =
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)))=
)))
- (setq reason (nx1-check-call-bits bits keyvect arglist spread-p))
- (when reason
- (values deftype reason)))))
-
-(defun nx1-check-call-bits (bits keyvect arglist spread-p)
- (when bits
- (unless (typep bits 'fixnum) (error "Bug: Bad bits ~s!" bits))
- (let* ((env *nx-lexical-environment*)
- (nargs (length arglist))
- (minargs (if spread-p (1- nargs) nargs))
- (required (ldb $lfbits-numreq bits))
- (max (if (logtest (logior (ash 1 $lfbits-rest-bit) (ash 1 $lfbits-rest=
v-bit) (ash 1 $lfbits-keys-bit)) bits)
- nil
- (+ required (ldb $lfbits-numopt bits)))))
- ;; If the (apparent) number of args in the call doesn't
- ;; match the definition, complain. If "spread-p" is true,
- ;; we can only be sure of the case when more than the
- ;; required number of args have been supplied.
- (or (and (not spread-p)
- (< minargs required)
- `(:toofew ,minargs ,required))
- (and max
- (> minargs max)
- (list :toomany nargs max))
- (nx1-find-bogus-keywords arglist spread-p bits keyvect env)))))
-
-(defun nx1-find-bogus-keywords (args spread-p bits keyvect env)
- (declare (fixnum bits))
- (when (logbitp $lfbits-aok-bit bits)
- (setq keyvect nil)) ; only check for even length tail
- (when (and (logbitp $lfbits-keys-bit bits) =
- (not spread-p)) ; Can't be sure, last argform may contain=
:allow-other-keys
- (do* ((bad-keys nil)
- (key-values (nthcdr (+ (ldb $lfbits-numreq bits) (ldb $lfbits-numopt b=
its)) args))
- (key-args key-values (cddr key-args)))
- ((null key-args)
- (when (and keyvect bad-keys)
- (list :unknown-keyword
- (if (cdr bad-keys) (nreverse bad-keys) (%car bad-keys))
- (coerce keyvect 'list))))
- (unless (cdr key-args)
- (return (list :odd-keywords key-values)))
- (when keyvect
- (let* ((keyword (%car key-args)))
- (unless (nx-form-constant-p keyword env)
- (return nil))
- (setq keyword (nx-form-constant-value keyword env))
- (if (eq keyword :allow-other-keys)
- (setq keyvect nil)
- (unless (position keyword keyvect)
- (push keyword bad-keys))))))))
+ (multiple-value-bind (bits keyvect)
+ (etypecase def
+ (function (innermost-lfun-bits-keyvect def))
+ (afunc (let ((lambda-form (afunc-lambdaform def)))
+ (and (lambda-expression-p lambda-form)
+ (encode-lambda-list (cadr lambda-form) t))))
+ (cons (def-info-bits-keyvect (cdr def))))
+ (when bits
+ (multiple-value-bind (reason defer-p)
+ (or (nx1-check-call-bits bits arglist spread-p) ;; never deferred
+ (nx1-check-call-keywords def bits keyvect arglist spread-p))
+ (when reason
+ #-BOOTSTRAPPED (unless (find-class 'undefined-keyword-reference =
nil)
+ (return-from nx1-check-call-args nil))
+ (values (if defer-p
+ :deferred-mismatch
+ (typecase def
+ (function :global-mismatch)
+ (afunc :lexical-mismatch)
+ (t :environment-mismatch)))
+ reason))))))
+
+(defun nx1-check-call-bits (bits arglist spread-p)
+ (let* ((nargs (length arglist))
+ (minargs (if spread-p (1- nargs) nargs))
+ (required (ldb $lfbits-numreq bits))
+ (max (if (logtest (logior (ash 1 $lfbits-rest-bit) (ash 1 $lfbits=
-restv-bit) (ash 1 $lfbits-keys-bit)) bits)
+ nil
+ (+ required (ldb $lfbits-numopt bits)))))
+ ;; If the (apparent) number of args in the call doesn't
+ ;; match the definition, complain. If "spread-p" is true,
+ ;; we can only be sure of the case when more than the
+ ;; required number of args have been supplied.
+ (or (and (not spread-p)
+ (< minargs required)
+ `(:toofew ,minargs ,required))
+ (and max
+ (> minargs max)
+ `(:toomany ,nargs ,max)))))
+
+(defun nx1-check-call-keywords (def bits keyvect args spread-p &aux (env *=
nx-lexical-environment*))
+ ;; Ok, if generic function, bits and keyvect are for the generic functio=
n itself.
+ ;; Still, since all congruent, can check whether have variable numargs
+ (unless (and (logbitp $lfbits-keys-bit bits)
+ (not spread-p)) ; last argform may contain :allow-other-keys
+ (return-from nx1-check-call-keywords nil))
+ (let* ((bad-keys nil)
+ (key-args (nthcdr (+ (ldb $lfbits-numreq bits) (ldb $lfbits-numop=
t bits)) args))
+ (generic-p (or (generic-function-p def)
+ (and (consp def)
+ (eq (def-info.function-type (cdr def)) 'defge=
neric)))))
+ (when (oddp (length key-args))
+ (return-from nx1-check-call-keywords (list :odd-keywords key-args)))
+ (when (logbitp $lfbits-aok-bit bits)
+ (return-from nx1-check-call-keywords nil))
+ (loop for key-form in key-args by #'cddr
+ do (unless (nx-form-constant-p key-form env) ;; could be :aok
+ (return-from nx1-check-call-keywords nil))
+ do (let ((key (nx-form-constant-value key-form env)))
+ (when (eq key :allow-other-keys)
+ (return-from nx1-check-call-keywords nil))
+ (unless (or (find key keyvect)
+ (and generic-p (nx1-valid-gf-keyword-p def key)))
+ (push key bad-keys))))
+ (when bad-keys
+ (if generic-p
+ (values (list :unknown-gf-keywords bad-keys) t)
+ (list :unknown-keyword (if (cdr bad-keys) (nreverse bad-keys) (%ca=
r bad-keys)) keyvect)))))
+
+(defun nx1-valid-gf-keyword-p (def key)
+ ;; Can assume has $lfbits-keys-bit and not $lfbits-aok-bit
+ (if (consp def)
+ (let ((definfo (cdr def)))
+ (assert (eq (def-info.function-type definfo) 'defgeneric))
+ (loop for m in (def-info.methods definfo)
+ as keyvect =3D (def-info-method.keyvect m)
+ thereis (or (null keyvect) (find key keyvect))))
+ (let ((gf (find-unencapsulated-definition def)))
+ (or (find key (%defgeneric-keys gf))
+ (loop for m in (%gf-methods gf)
+ thereis (let* ((func (%inner-method-function m))
+ (mbits (lfun-bits func)))
+ (or (and (logbitp $lfbits-aok-bit mbits)
+ ;; If no &rest, then either don't use t=
he keyword in which case
+ ;; it's good to warn; or it's used via =
next-method, we'll approve
+ ;; it when we get to that method.
+ (logbitp $lfbits-rest-bit mbits))
+ (find key (lfun-keyvect func)))))))))
=
;;; we can save some space by going through subprims to call "builtin"
;;; functions for us.
Modified: release/1.4/source/doc/ccl-documentation.html
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- release/1.4/source/doc/ccl-documentation.html (original)
+++ release/1.4/source/doc/ccl-documentation.html Thu Oct 15 14:48:26 2009
@@ -12624,7 +12624,7 @@
<span class=3D"term">Description</span>
</dt>
<dd>
- <p>Equivalent to (%ptr-to-int 0).</p>
+ <p>Equivalent to (%int-to-ptr 0).</p>
</dd>
</dl>
</div>
@@ -16933,9 +16933,10 @@
</div>
</div>
</div>
- <p xmlns=3D"http://www.w3.org/1999/xhtml">Fixnums on 32-bit sy=
stems use 30 bits and are in the
- range XXX through YYY. Fixnums on 64-bit systems use 61-bits
- and are in the range XXX through YYY. (see <a href=3D"#Tagging-scheme=
" title=3D"16.2.4.=C3=82=C2=A0Tagging scheme">Section=C3=82=C2=A016.2.4, =
=C3=A2=C2=80=C2=9CTagging scheme=C3=A2=C2=80=C2=9D</a>)</p>
+ <p xmlns=3D"http://www.w3.org/1999/xhtml">Fixnums on 32-bit sy=
stems are 30 bits long, and are in the
+ range -536870912 through 536870911. Fixnums on 64-bit
+ systems are 61 bits long, and are in the range
+ -1152921504606846976 through 1152921504606846975. (see <a href=3D"#Tagg=
ing-scheme" title=3D"16.2.4.=C3=82=C2=A0Tagging scheme">Section=C3=82=C2=A0=
16.2.4, =C3=A2=C2=80=C2=9CTagging scheme=C3=A2=C2=80=C2=9D</a>)</p>
<p xmlns=3D"http://www.w3.org/1999/xhtml">Since we have much l=
arger fixnums on 64-bit systems,
<em class=3D"varname">INTERNAL-TIME-UNITS-PER-SECOND</em> is 1000000
on 64-bit systems but remains 1000 on 32-bit systems. This
@@ -17398,7 +17399,7 @@
<p>
<div>
<div class=3D"refsect1" lang=3D"en" xml:lang=3D"en">
- <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id397124">=
</a>
+ <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id397123">=
</a>
<div class=3D"header">Arguments and Values:</div>
<p><i><span xmlns=3D"http://www.w3.org/1999/xhtml" class=
=3D"term">name</span></i>---a string which is the name of an existing
environment variable;
@@ -17408,7 +17409,7 @@
is not, NIL</p>
</div>
<div class=3D"refsect1" lang=3D"en" xml:lang=3D"en">
- <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id397169">=
</a>
+ <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id397168">=
</a>
<div class=3D"header">Description:</div>
<p xmlns=3D"http://www.w3.org/1999/xhtml">
Looks up the value of the environment variable named by
@@ -17429,7 +17430,7 @@
<p>
<div>
<div class=3D"refsect1" lang=3D"en" xml:lang=3D"en">
- <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id397230">=
</a>
+ <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id397229">=
</a>
<div class=3D"header">Arguments and Values:</div>
<p><i><span xmlns=3D"http://www.w3.org/1999/xhtml" class=
=3D"term">name</span></i>---a string which is the name of a new or existing
environment variable;
@@ -17442,7 +17443,7 @@
the problem</p>
</div>
<div class=3D"refsect1" lang=3D"en" xml:lang=3D"en">
- <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id397290">=
</a>
+ <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id397289">=
</a>
<div class=3D"header">Description:</div>
<p xmlns=3D"http://www.w3.org/1999/xhtml">
Sets the value of the environment variable named by
@@ -17466,13 +17467,13 @@
<p>
<div>
<div class=3D"refsect1" lang=3D"en" xml:lang=3D"en">
- <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id396617">=
</a>
+ <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id396616">=
</a>
<div class=3D"header">Values:</div>
<p><i><span xmlns=3D"http://www.w3.org/1999/xhtml" class=
=3D"term">path</span></i>---a string, an absolute pathname in Posix format =
- with
directory components separated by slashes</p>
</div>
<div class=3D"refsect1" lang=3D"en" xml:lang=3D"en">
- <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id396644">=
</a>
+ <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id396643">=
</a>
<div class=3D"header">Description:</div>
<p xmlns=3D"http://www.w3.org/1999/xhtml">
Looks up the current working directory of the Clozure CL process;
@@ -17494,13 +17495,13 @@
<p>
<div>
<div class=3D"refsect1" lang=3D"en" xml:lang=3D"en">
- <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id396703">=
</a>
+ <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id396702">=
</a>
<div class=3D"header">Values:</div>
<p><i><span xmlns=3D"http://www.w3.org/1999/xhtml" class=
=3D"term">uid</span></i>---a non-negative integer, identifying a specific u=
ser
account as defined in the OS user database</p>
</div>
<div class=3D"refsect1" lang=3D"en" xml:lang=3D"en">
- <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id396730">=
</a>
+ <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id396729">=
</a>
<div class=3D"header">Description:</div>
<p xmlns=3D"http://www.w3.org/1999/xhtml">
Returns the ("real") user ID of the current user.
@@ -17520,7 +17521,7 @@
<p>
<div>
<div class=3D"refsect1" lang=3D"en" xml:lang=3D"en">
- <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id396787">=
</a>
+ <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id396786">=
</a>
<div class=3D"header">Arguments and Values:</div>
<p><i><span xmlns=3D"http://www.w3.org/1999/xhtml" class=
=3D"term">uid</span></i>---a non-negative integer, identifying a specific u=
ser
account as defined in the OS user database</p>
@@ -17529,7 +17530,7 @@
the problem</p>
</div>
<div class=3D"refsect1" lang=3D"en" xml:lang=3D"en">
- <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id396830">=
</a>
+ <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id396829">=
</a>
<div class=3D"header">Description:</div>
<p xmlns=3D"http://www.w3.org/1999/xhtml">
Attempts to change the current user ID (both "real" and
@@ -17552,7 +17553,7 @@
<p>
<div>
<div class=3D"refsect1" lang=3D"en" xml:lang=3D"en">
- <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id410161">=
</a>
+ <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id410160">=
</a>
<div class=3D"header">Arguments and Values:</div>
<p><i><span xmlns=3D"http://www.w3.org/1999/xhtml" class=
=3D"term">gid</span></i>---a non-negative integer, identifying a specific
group as defined in the OS user database</p>
@@ -17561,7 +17562,7 @@
the problem</p>
</div>
<div class=3D"refsect1" lang=3D"en" xml:lang=3D"en">
- <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id410204">=
</a>
+ <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id410202">=
</a>
<div class=3D"header">Description:</div>
<p xmlns=3D"http://www.w3.org/1999/xhtml">
Attempts to change the current group ID (both "real" and
@@ -17584,12 +17585,12 @@
<p>
<div>
<div class=3D"refsect1" lang=3D"en" xml:lang=3D"en">
- <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id410263">=
</a>
+ <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id410262">=
</a>
<div class=3D"header">Values:</div>
<p><i><span xmlns=3D"http://www.w3.org/1999/xhtml" class=
=3D"term">pid</span></i>---a non-negative integer, identifying an OS proces=
s</p>
</div>
<div class=3D"refsect1" lang=3D"en" xml:lang=3D"en">
- <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id410289">=
</a>
+ <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id410288">=
</a>
<div class=3D"header">Description:</div>
<p xmlns=3D"http://www.w3.org/1999/xhtml">
Returns the ID of the Clozure CL OS process.
@@ -17610,7 +17611,7 @@
<p>
<div>
<div class=3D"refsect1" lang=3D"en" xml:lang=3D"en">
- <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id410346">=
</a>
+ <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id410345">=
</a>
<div class=3D"header">Values:</div>
<p><i><span xmlns=3D"http://www.w3.org/1999/xhtml" class=
=3D"term">uid</span></i>---a non-negative integer, identifying a specific u=
ser
account as defined in the OS user database</p>
@@ -17618,7 +17619,7 @@
directory components separated by slashes; or NIL</p>
</div>
<div class=3D"refsect1" lang=3D"en" xml:lang=3D"en">
- <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id408852">=
</a>
+ <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id408851">=
</a>
<div class=3D"header">Description:</div>
<p xmlns=3D"http://www.w3.org/1999/xhtml">
Looks up and returns the defined home directory of the user
@@ -17643,7 +17644,7 @@
<p>
<div>
<div class=3D"refsect1" lang=3D"en" xml:lang=3D"en">
- <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id408921">=
</a>
+ <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id408920">=
</a>
<div class=3D"header">Values:</div>
<p><i><span xmlns=3D"http://www.w3.org/1999/xhtml" class=
=3D"term">command-line</span></i>---a string, obeying all the whitespace and
escaping
@@ -17652,7 +17653,7 @@
code of a subprocess; zero indicates success</p>
</div>
<div class=3D"refsect1" lang=3D"en" xml:lang=3D"en">
- <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id408963">=
</a>
+ <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id408962">=
</a>
<div class=3D"header">Description:</div>
<p xmlns=3D"http://www.w3.org/1999/xhtml">
Invokes the Posix function <span><strong class=3D"function">system(=
)</strong></span>, which
@@ -17668,7 +17669,7 @@
</p>
</div>
<div class=3D"refsect1" lang=3D"en" xml:lang=3D"en">
- <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id408997">=
</a>
+ <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id408996">=
</a>
<div class=3D"header">Notes:</div>
<p xmlns=3D"http://www.w3.org/1999/xhtml">
By convention, an exit code of 0 indicates success. There are
@@ -17693,14 +17694,14 @@
<p>
<div>
<div class=3D"refsect1" lang=3D"en" xml:lang=3D"en">
- <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id409057">=
</a>
+ <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id409056">=
</a>
<div class=3D"header">Arguments and Values:</div>
<p><i><span xmlns=3D"http://www.w3.org/1999/xhtml" class=
=3D"term">class-name</span></i>---a string which denotes an existing class =
name, or a
symbol which can be mapped to such a string via the standard
name-mapping conventions for class names</p>
</div>
<div class=3D"refsect1" lang=3D"en" xml:lang=3D"en">
- <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id409085">=
</a>
+ <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id409084">=
</a>
<div class=3D"header">Description:</div>
<p xmlns=3D"http://www.w3.org/1999/xhtml">Used to refer to=
a known ObjC class by name. (Via the use
LOAD-TIME-VALUE, the results of a class-name -> class lookup
@@ -17725,13 +17726,13 @@
<p>
<div>
<div class=3D"refsect1" lang=3D"en" xml:lang=3D"en">
- <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id397372">=
</a>
+ <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id397371">=
</a>
<div class=3D"header">Arguments and Values:</div>
<p><i><span xmlns=3D"http://www.w3.org/1999/xhtml" class=
=3D"term">string</span></i>---a string constant, used to canonically refer =
to an
ObjC method selector</p>
</div>
<div class=3D"refsect1" lang=3D"en" xml:lang=3D"en">
- <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id397398">=
</a>
+ <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id397396">=
</a>
<div class=3D"header">Description:</div>
<p xmlns=3D"http://www.w3.org/1999/xhtml">Used to refer to=
an ObjC method selector (method name). Uses
LOAD-TIME-VALUE to cache the result of a string -> selector
@@ -17753,7 +17754,7 @@
<p>
<div>
<div class=3D"refsect1" lang=3D"en" xml:lang=3D"en">
- <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id397464">=
</a>
+ <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id397462">=
</a>
<div class=3D"header">Arguments and Values:</div>
<p><i><span xmlns=3D"http://www.w3.org/1999/xhtml" class=
=3D"term">name-and-result-type</span></i>---either an Objective-C message n=
ame, for methods
that return a value of type <code xmlns=3D"http://www.w3.o=
rg/1999/xhtml" class=3D"literal">:ID</code>, or
@@ -17775,7 +17776,7 @@
is a foreign type specifier.</p>
</div>
<div class=3D"refsect1" lang=3D"en" xml:lang=3D"en">
- <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id397545">=
</a>
+ <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id397543">=
</a>
<div class=3D"header">Description:</div>
<p xmlns=3D"http://www.w3.org/1999/xhtml">Defines an Objec=
tive-C-callable method which implements
the specified message selector for instances of the existing
@@ -17800,7 +17801,7 @@
<p>
<div>
<div class=3D"refsect1" lang=3D"en" xml:lang=3D"en">
- <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id397628">=
</a>
+ <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id397626">=
</a>
<div class=3D"header">Arguments and Values:</div>
<p><i><span xmlns=3D"http://www.w3.org/1999/xhtml" class=
=3D"term">selector</span></i>---either a string which represents the name o=
f the
selector or a list which describes the method's return
@@ -17836,12 +17837,12 @@
<p>
<div>
<div class=3D"refsect1" lang=3D"en" xml:lang=3D"en">
- <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id411348">=
</a>
+ <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id411346">=
</a>
<div class=3D"header">Arguments and Values:</div>
<p xmlns=3D"http://www.w3.org/1999/xhtml">As per DEFINE-OB=
JC-METHOD</p>
</div>
<div class=3D"refsect1" lang=3D"en" xml:lang=3D"en">
- <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id411359">=
</a>
+ <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id411358">=
</a>
<div class=3D"header">Description:</div>
<p xmlns=3D"http://www.w3.org/1999/xhtml">Like DEFINE-OBJC=
-METHOD, only used to define methods on the
<span class=3D"emphasis"><em>class</em></span> named by class-nam=
e and on its
@@ -17883,7 +17884,7 @@
<p>
<div>
<div class=3D"refsect1" lang=3D"en" xml:lang=3D"en">
- <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id411435">=
</a>
+ <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id411434">=
</a>
<div class=3D"header">Description:</div>
<p xmlns=3D"http://www.w3.org/1999/xhtml">This variable is=
currently only used by the standard reader macro
function for #\; (single-line comments); that function reads succ=
essive
@@ -17918,7 +17919,7 @@
<p>
<div>
<div class=3D"refsect1" lang=3D"en" xml:lang=3D"en">
- <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id411493">=
</a>
+ <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id411492">=
</a>
<div class=3D"header">Description:</div>
<p xmlns=3D"http://www.w3.org/1999/xhtml">Per ANSI CL, Clo=
zure CL supports the :EXTERNAL-FORMAT keyword
argument to the functions OPEN, LOAD, and COMPILE-FILE. This argu=
ment is
@@ -17962,7 +17963,7 @@
<p>
<div>
<div class=3D"refsect1" lang=3D"en" xml:lang=3D"en">
- <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id411573">=
</a>
+ <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id411572">=
</a>
<div class=3D"header">Description:</div>
<p xmlns=3D"http://www.w3.org/1999/xhtml">The value of thi=
s variable is used when :EXTERNAL-FORMAT is
unspecified or specified as :DEFAULT. It can meaningfully be give=
n any
@@ -17986,12 +17987,12 @@
<p>
<div>
<div class=3D"refsect1" lang=3D"en" xml:lang=3D"en">
- <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id411623">=
</a>
+ <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id411622">=
</a>
<div class=3D"header">Superclasses:</div>
<p xmlns=3D"http://www.w3.org/1999/xhtml">NS:NS-STRING</p>
</div>
<div class=3D"refsect1" lang=3D"en" xml:lang=3D"en">
- <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id411634">=
</a>
+ <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id411633">=
</a>
<div class=3D"header">Initargs:</div>
<p><i><span xmlns=3D"http://www.w3.org/1999/xhtml" class=
=3D"term">:string</span></i>---
a Lisp string which is to be the content of
@@ -17999,7 +18000,7 @@
</p>
</div>
<div class=3D"refsect1" lang=3D"en" xml:lang=3D"en">
- <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id411661">=
</a>
+ <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id411660">=
</a>
<div class=3D"header">Description:</div>
<p xmlns=3D"http://www.w3.org/1999/xhtml">
This class
@@ -18017,7 +18018,7 @@
</p>
</div>
<div class=3D"refsect1" lang=3D"en" xml:lang=3D"en">
- <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id411681">=
</a>
+ <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id411680">=
</a>
<div class=3D"header">Examples:</div>
<p xmlns=3D"http://www.w3.org/1999/xhtml">
You can create an ns-lisp-string with
@@ -18048,7 +18049,7 @@
</pre>
</div>
<div class=3D"refsect1" lang=3D"en" xml:lang=3D"en">
- <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id394242">=
</a>
+ <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id394241">=
</a>
<div class=3D"header">Notes:</div>
<p xmlns=3D"http://www.w3.org/1999/xhtml">
Currently, ns-lisp-string is defined in
@@ -18388,7 +18389,7 @@
<p>
<div>
<div class=3D"refsect1" lang=3D"en" xml:lang=3D"en">
- <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id411950">=
</a>
+ <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id411949">=
</a>
<div class=3D"header">Arguments and Values:</div>
<p><i><span xmlns=3D"http://www.w3.org/1999/xhtml" class=
=3D"term">type</span></i>---The type of population, one of <code xmlns=3D"h=
ttp://www.w3.org/1999/xhtml" class=3D"literal">:LIST</code> (the default) o=
r <code xmlns=3D"http://www.w3.org/1999/xhtml" class=3D"literal">:ALIST</co=
de></p>
<p><i><span xmlns=3D"http://www.w3.org/1999/xhtml" class=
=3D"term">initial-contents</span></i>--- A sequence of elements (or conses,=
for <code xmlns=3D"http://www.w3.org/1999/xhtml" class=3D"literal">:alist<=
/code>) to be used to initialize the
@@ -18396,7 +18397,7 @@
alist) is not stored in the population, a new list or alist =
is created to hold the elements.</p>
</div>
<div class=3D"refsect1" lang=3D"en" xml:lang=3D"en">
- <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id412009">=
</a>
+ <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id412008">=
</a>
<div class=3D"header">Description:</div>
<p xmlns=3D"http://www.w3.org/1999/xhtml">Creates a new po=
pulation of the specified type.</p>
</div>
@@ -18414,7 +18415,7 @@
<p>
<div>
<div class=3D"refsect1" lang=3D"en" xml:lang=3D"en">
- <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id412066">=
</a>
+ <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id412065">=
</a>
<div class=3D"header">Description:</div>
<p xmlns=3D"http://www.w3.org/1999/xhtml">returns the type=
of <code class=3D"literal">population</code>, one of <code class=3D"litera=
l">:LIST</code> or <code class=3D"literal">:ALIST</code></p>
</div>
@@ -18432,7 +18433,7 @@
<p>
<div>
<div class=3D"refsect1" lang=3D"en" xml:lang=3D"en">
- <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id393854">=
</a>
+ <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id393852">=
</a>
<div class=3D"header">Description:</div>
<p xmlns=3D"http://www.w3.org/1999/xhtml">returns the list=
encapsulated in <code class=3D"literal">population</code>.
Note that as long as there is a direct (non-weak) reference to this
@@ -18455,7 +18456,7 @@
<p>
<div>
<div class=3D"refsect1" lang=3D"en" xml:lang=3D"en">
- <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id412232">=
</a>
+ <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id412231">=
</a>
<div class=3D"header">Description:</div>
<p xmlns=3D"http://www.w3.org/1999/xhtml">Sets the list en=
capsulated in <code class=3D"literal">population</code> to
<code class=3D"literal">contents</code>. <code class=3D"literal">=
Contents</code> is not copied,
@@ -18509,12 +18510,12 @@
<p>
<div>
<div class=3D"refsect1" lang=3D"en" xml:lang=3D"en">
- <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id394272">=
</a>
+ <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id394270">=
</a>
<div class=3D"header">Arguments and Values:</div>
<p><i><span xmlns=3D"http://www.w3.org/1999/xhtml" class=
=3D"term">new-threshold</span></i>---The requested new lisp-heap-gc-thresho=
ld.</p>
</div>
<div class=3D"refsect1" lang=3D"en" xml:lang=3D"en">
- <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id394298">=
</a>
+ <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id394296">=
</a>
<div class=3D"header">Description:</div>
<p xmlns=3D"http://www.w3.org/1999/xhtml">Sets the value o=
f the kernel variable that specifies the
amount of free space to leave in the heap after full GC to
@@ -18538,7 +18539,7 @@
<p>
<div>
<div class=3D"refsect1" lang=3D"en" xml:lang=3D"en">
- <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id394360">=
</a>
+ <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id394358">=
</a>
<div class=3D"header">Description:</div>
<p xmlns=3D"http://www.w3.org/1999/xhtml">Tries to grow or=
shrink lisp's heap space, so that the
free space is (approximately) equal to the current heap threshold.
@@ -18558,12 +18559,12 @@
<p>
<div>
<div class=3D"refsect1" lang=3D"en" xml:lang=3D"en">
- <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id394418">=
</a>
+ <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id394416">=
</a>
<div class=3D"header">Arguments and Values:</div>
<p><i><span xmlns=3D"http://www.w3.org/1999/xhtml" class=
=3D"term">arg</span></i>---a generalized boolean</p>
</div>
<div class=3D"refsect1" lang=3D"en" xml:lang=3D"en">
- <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id394444">=
</a>
+ <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id394442">=
</a>
<div class=3D"header">Description:</div>
<p xmlns=3D"http://www.w3.org/1999/xhtml">Enables the EGC =
if arg is non-nil, disables the EGC
otherwise. Returns the previous enabled status. Although this
@@ -18589,7 +18590,7 @@
<p>
<div>
<div class=3D"refsect1" lang=3D"en" xml:lang=3D"en">
- <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id394503">=
</a>
+ <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id394501">=
</a>
<div class=3D"header">Description:</div>
<p xmlns=3D"http://www.w3.org/1999/xhtml">Returns T if the=
EGC was enabled at the time of the call,
NIL otherwise.</p>
@@ -18612,7 +18613,7 @@
<p>
<div>
<div class=3D"refsect1" lang=3D"en" xml:lang=3D"en">
- <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id394558">=
</a>
+ <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id394557">=
</a>
<div class=3D"header">Description:</div>
<p xmlns=3D"http://www.w3.org/1999/xhtml">Returns T if the=
EGC was active at the time of the call, NIL
otherwise. Since this is generally a volatile piece of
@@ -18637,7 +18638,7 @@
<p>
<div>
<div class=3D"refsect1" lang=3D"en" xml:lang=3D"en">
- <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id394616">=
</a>
+ <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id394615">=
</a>
<div class=3D"header">Description:</div>
<p xmlns=3D"http://www.w3.org/1999/xhtml">Returns, as mult=
iple values, the sizes in kilobytes of the
thresholds associated with the youngest ephemeral generation, the
@@ -18659,7 +18660,7 @@
<p>
<div>
<div class=3D"refsect1" lang=3D"en" xml:lang=3D"en">
- <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id394675">=
</a>
+ <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id394674">=
</a>
<div class=3D"header">Arguments and Values:</div>
<p><i><span xmlns=3D"http://www.w3.org/1999/xhtml" class=
=3D"term">generation-0-size</span></i>---the requested threshold size of th=
e youngest
generation, in kilobytes</p>
@@ -18669,10 +18670,12 @@
in kilobytes</p>
</div>
<div class=3D"refsect1" lang=3D"en" xml:lang=3D"en">
- <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id394730">=
</a>
+ <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id394729">=
</a>
<div class=3D"header">Description:</div>
- <p xmlns=3D"http://www.w3.org/1999/xhtml">If the EGC is cu=
rrently disabled, puts the indicated
- threshold sizes in effect and returns T, otherwise, returns NIL.
+ <p xmlns=3D"http://www.w3.org/1999/xhtml">Puts the indicat=
ed threshold sizes in effect.
+ Each threshold indicates the total size that may be allocated
+ in that and all younger generations before a GC is triggered.
+ Disables EGC while setting the values.
(The provided threshold sizes are rounded up to a multiple of
64Kbytes in <code class=3D"literal">CCL</code> 0.14 and to a multiple o=
f 32KBytes in earlier
versions.)</p>
@@ -18876,7 +18879,7 @@
</dt>
<dt>
<span class=3D"sect2">
- <a href=3D"#id404491">16.7.2. Recommended Reading</a>
+ <a href=3D"#id404502">16.7.2. Recommended Reading</a>
</span>
</dt>
</dl>
@@ -20152,7 +20155,7 @@
<ol type=3D"1">
<li>
<p>To support a feature called <span class=3D"emphasis">=
<em>GCTWA
- <sup>[<a id=3D"id403223" href=3D"#ftn.id403223">1</a>]</su=
p>
+ <sup>[<a id=3D"id403234" href=3D"#ftn.id403234">1</a>]</su=
p>
, </em></span>the vector that contains the internal
symbols of the current package is marked on entry to the
mark phase, but the symbols themselves are not marked at
@@ -20285,7 +20288,7 @@
<br />
<hr width=3D"100" align=3D"left" />
<div xmlns=3D"http://www.w3.org/1999/xhtml" class=3D"footnote">
- <p><sup>[<a id=3D"ftn.id403223" href=3D"#id403223">1</a>] </=
sup>I believe that the acronym comes from MACLISP,
+ <p><sup>[<a id=3D"ftn.id403234" href=3D"#id403234">1</a>] </=
sup>I believe that the acronym comes from MACLISP,
where it stood for "Garbage Collection of Truly
Worthless Atoms".</p>
</div>
@@ -20345,7 +20348,7 @@
generations. To avoid the need to scan those (often large) other
generations looking for such intergenerational references, the
runtime system must note all such intergenerational references
- at the point where they're created (via Setf).<sup>[<a id=3D"id404=
278" href=3D"#ftn.id404278">2</a>]</sup> The
+ at the point where they're created (via Setf).<sup>[<a id=3D"id404=
289" href=3D"#ftn.id404289">2</a>]</sup> The
set of pointers that may contain intergenerational references is
sometimes called <span class=3D"emphasis"><em>the remembered set</=
em></span>.</p>
<p xmlns=3D"http://www.w3.org/1999/xhtml">In Clozure CL's EGC, t=
he heap is organized exactly the same
@@ -20392,7 +20395,7 @@
to and exit from the binding of a special variable), all setfs
that might introduce an intergenerational reference must be
memoized.
- <sup>[<a id=3D"id404347" href=3D"#ftn.id404347">3</a>]</sup> It's =
always safe to
+ <sup>[<a id=3D"id404359" href=3D"#ftn.id404359">3</a>]</sup> It's =
always safe to
push any cons cell or gvector locative onto the memo stack;
it's never safe to push anything else.
</p>
@@ -20413,13 +20416,13 @@
<br />
<hr width=3D"100" align=3D"left" />
<div xmlns=3D"http://www.w3.org/1999/xhtml" class=3D"footnote">
- <p><sup>[<a id=3D"ftn.id404278" href=3D"#id404278">2</a>] </=
sup>This is
+ <p><sup>[<a id=3D"ftn.id404289" href=3D"#id404289">2</a>] </=
sup>This is
sometimes called "The Write Barrier": all assignments which
might result in intergenerational references must be noted, as
if the other generations were write-protected.</p>
</div>
<div xmlns=3D"http://www.w3.org/1999/xhtml" class=3D"footnote">
- <p><sup>[<a id=3D"ftn.id404347" href=3D"#id404347">3</a>] </=
sup>Note that the implicit setfs that occur when
+ <p><sup>[<a id=3D"ftn.id404359" href=3D"#id404359">3</a>] </=
sup>Note that the implicit setfs that occur when
initializing an object - as in the case of a call to cons or
vector - can't introduce intergenerational references, since
the newly created object is always younger than the objects
@@ -20535,7 +20538,7 @@
<div xmlns=3D"http://www.w3.org/1999/xhtml" class=3D"titlepage=
">
<div>
<div>
- <h3 class=3D"title"><a id=3D"id404491"></a>16.7.2.=C3=82=
=C2=A0Recommended Reading</h3>
+ <h3 class=3D"title"><a id=3D"id404502"></a>16.7.2.=C3=82=
=C2=A0Recommended Reading</h3>
</div>
</div>
</div>
@@ -20948,7 +20951,7 @@
<p>
<div>
<div class=3D"refsect1" lang=3D"en" xml:lang=3D"en">
- <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id362876">=
</a>
+ <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id285538">=
</a>
<div class=3D"header">Description:</div>
<p xmlns=3D"http://www.w3.org/1999/xhtml">When true, attem=
pts to redefine (via DEFUN or DEFMETHOD)
functions and methods that are marked as being
@@ -20973,7 +20976,7 @@
<p>
<div>
<div class=3D"refsect1" lang=3D"en" xml:lang=3D"en">
- <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id396482">=
</a>
+ <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id393300">=
</a>
<div class=3D"header">Description:</div>
<p xmlns=3D"http://www.w3.org/1999/xhtml">Arranges that th=
e outermost special bindings of *PACKAGE*
and *WARN-IF-REDEFINE-KERNEL* restore values of the "CCL"
@@ -20997,7 +21000,7 @@
<p>
<div>
<div class=3D"refsect1" lang=3D"en" xml:lang=3D"en">
- <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id410712">=
</a>
+ <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id395749">=
</a>
<div class=3D"header">Description:</div>
<p xmlns=3D"http://www.w3.org/1999/xhtml">Arranges that th=
e outermost special bindings of *PACKAGE*
and *WARN-IF-REDEFINE-KERNEL* restore values of the
@@ -21020,7 +21023,7 @@
<p>
<div>
<div class=3D"refsect1" lang=3D"en" xml:lang=3D"en">
- <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id342136">=
</a>
+ <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id342109">=
</a>
<div class=3D"header">Description:</div>
<p xmlns=3D"http://www.w3.org/1999/xhtml">This variable is=
initialized each time an Clozure CL session
starts based on information provided by the lisp kernel. Its value
@@ -21045,7 +21048,7 @@
<p>
<div>
<div class=3D"refsect1" lang=3D"en" xml:lang=3D"en">
- <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id339429">=
</a>
+ <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id397671">=
</a>
<div class=3D"header">Description:</div>
<p xmlns=3D"http://www.w3.org/1999/xhtml">Returns non-NIL =
if AltiVec is available.</p>
</div>
@@ -21063,7 +21066,7 @@
<p>
<div>
<div class=3D"refsect1" lang=3D"en" xml:lang=3D"en">
- <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id379784">=
</a>
+ <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id397714">=
</a>
<div class=3D"header">Description:</div>
<p xmlns=3D"http://www.w3.org/1999/xhtml">Intended to cont=
rol the expansion of certain lap macros.
Initialized to NIL on LinuxPPC; initialized to T on platforms
@@ -21085,13 +21088,13 @@
<p>
<div>
<div class=3D"refsect1" lang=3D"en" xml:lang=3D"en">
- <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id403499">=
</a>
+ <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id335473">=
</a>
<div class=3D"header">Arguments and Values:</div>
<p><i><span xmlns=3D"http://www.w3.org/1999/xhtml" class=
=3D"term">reglist</span></i>---A list of vector register names (vr0 .. vr31=
).</p>
<p><i><span xmlns=3D"http://www.w3.org/1999/xhtml" class=
=3D"term">body</span></i>---A sequence of PPC LAP instructions.</p>
</div>
<div class=3D"refsect1" lang=3D"en" xml:lang=3D"en">
- <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id403540">=
</a>
+ <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id395300">=
</a>
<div class=3D"header">Description:</div>
<p xmlns=3D"http://www.w3.org/1999/xhtml">Specifies the se=
t of AltiVec registers used in body. If
*altivec-lapmacros-maintain-vrsave-p* is true when the macro is
@@ -21117,7 +21120,7 @@
<p>
<div>
<div class=3D"refsect1" lang=3D"en" xml:lang=3D"en">
- <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id395242">=
</a>
+ <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id379776">=
</a>
<div class=3D"header">Arguments and Values:</div>
<p><i><span xmlns=3D"http://www.w3.org/1999/xhtml" class=
=3D"term">base</span></i>---Any available general-purpose register.</p>
<p><i><span xmlns=3D"http://www.w3.org/1999/xhtml" class=
=3D"term">n</span></i>---An integer between 1 and 254, inclusive. (Should
@@ -21126,7 +21129,7 @@
<p><i><span xmlns=3D"http://www.w3.org/1999/xhtml" class=
=3D"term">body</span></i>---A sequence of PPC LAP instructions.</p>
</div>
<div class=3D"refsect1" lang=3D"en" xml:lang=3D"en">
- <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id335443">=
</a>
+ <a xmlns=3D"http://www.w3.org/1999/xhtml" id=3D"id379834">=
</a>
<div class=3D"header">Description:</div>
<p xmlns=3D"http://www.w3.org/1999/xhtml">Generates code w=
hich allocates a 16-byte aligned buffer
large enough to contain N vector registers; the GPR base points to
@@ -21775,6 +21778,6 @@
<div xmlns=3D"http://www.w3.org/TR/xhtml1/transitional" align=3D"cente=
r">
<a href=3D"#Symbol-Index">Symbol Index</a>
</div>
- <p xmlns=3D"http://www.w3.org/TR/xhtml1/transitional" xmlns:date=3D"ht=
tp://exslt.org/dates-and-times" class=3D"footer">This document was last mod=
ified at 20:0 on September 1, 2009, in UTC.<br></br>It uses version 1.72.0 =
of the Norman Walsh Docbook stylesheets.<br></br>Built from subversion rev =
12729<br></br>Using libxml 20629, libxslt 10121 and libexslt 813.</p>
+ <p xmlns=3D"http://www.w3.org/TR/xhtml1/transitional" xmlns:date=3D"ht=
tp://exslt.org/dates-and-times" class=3D"footer">This document was last mod=
ified at 5:0 on October 9, 2009, in UTC.<br></br>It uses version 1.72.0 of =
the Norman Walsh Docbook stylesheets.<br></br>Built from subversion rev 129=
33<br></br>Using libxml 20629, libxslt 10121 and libexslt 813.</p>
</body>
</html>
Modified: release/1.4/source/doc/src/ffi.xml
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- release/1.4/source/doc/src/ffi.xml (original)
+++ release/1.4/source/doc/src/ffi.xml Thu Oct 15 14:48:26 2009
@@ -941,7 +941,7 @@
<term>Description</term>
=
<listitem>
- <para>Equivalent to (%ptr-to-int 0).</para>
+ <para>Equivalent to (%int-to-ptr 0).</para>
</listitem>
</varlistentry>
</variablelist>
Modified: release/1.4/source/doc/src/gc.xml
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- release/1.4/source/doc/src/gc.xml (original)
+++ release/1.4/source/doc/src/gc.xml Thu Oct 15 14:48:26 2009
@@ -637,8 +637,10 @@
<refsect1>
<title>Description</title>
=
- <para>If the EGC is currently disabled, puts the indicated
- threshold sizes in effect and returns T, otherwise, returns NIL.
+ <para>Puts the indicated threshold sizes in effect.
+ Each threshold indicates the total size that may be allocated
+ in that and all younger generations before a GC is triggered.
+ Disables EGC while setting the values.
(The provided threshold sizes are rounded up to a multiple of
64Kbytes in &CCL; 0.14 and to a multiple of 32KBytes in earlier
versions.)</para>
Modified: release/1.4/source/doc/src/platform-notes.xml
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- release/1.4/source/doc/src/platform-notes.xml (original)
+++ release/1.4/source/doc/src/platform-notes.xml Thu Oct 15 14:48:26 2009
@@ -24,10 +24,11 @@
<sect2 id=3D"differences-between-32-bit-and-64-bit-implementations">
<title>Differences Between 32-bit and 64-bit implementations</title>
=
- <para>Fixnums on 32-bit systems use 30 bits and are in the
- range XXX through YYY. Fixnums on 64-bit systems use 61-bits
- and are in the range XXX through YYY. (see <xref
- linkend=3D"Tagging-sche=
me"/>)</para>
+ <para>Fixnums on 32-bit systems are 30 bits long, and are in the
+ range -536870912 through 536870911. Fixnums on 64-bit
+ systems are 61 bits long, and are in the range
+ -1152921504606846976 through 1152921504606846975. (see <xref
+ linkend=3D"Tagging-scheme"/>)</para>
=
<para>Since we have much larger fixnums on 64-bit systems,
<varname>INTERNAL-TIME-UNITS-PER-SECOND</varname> is 1000000
Modified: release/1.4/source/level-0/X86/X8632/x8632-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
--- release/1.4/source/level-0/X86/X8632/x8632-utils.lisp (original)
+++ release/1.4/source/level-0/X86/X8632/x8632-utils.lisp Thu Oct 15 14:48:=
26 2009
@@ -393,12 +393,8 @@
=
(defx8632lapfunction %watch ((uvector arg_z))
(check-nargs 1)
- ;; May want to tighten this up to disallow watching functions,
- ;; symbols, etc.
- (trap-unless-lisptag=3D uvector x8632::tag-misc imm0)
(movl ($ arch::watch-trap-function-watch) (%l imm0))
(uuo-watch-trap)
- (movl ($ nil) (%l arg_z))
(single-value-return))
=
(defx8632lapfunction %unwatch ((watched arg_y) (new arg_z))
Modified: release/1.4/source/level-0/X86/x86-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
--- release/1.4/source/level-0/X86/x86-utils.lisp (original)
+++ release/1.4/source/level-0/X86/x86-utils.lisp Thu Oct 15 14:48:26 2009
@@ -448,7 +448,6 @@
(check-nargs 1)
(movl ($ arch::watch-trap-function-watch) (%l imm0))
(uuo-watch-trap)
- (movl ($ nil) (%l arg_z))
(single-value-return))
=
(defx86lapfunction %unwatch ((watched arg_y) (new arg_z))
Modified: release/1.4/source/level-1/l1-aprims.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
--- release/1.4/source/level-1/l1-aprims.lisp (original)
+++ release/1.4/source/level-1/l1-aprims.lisp Thu Oct 15 14:48:26 2009
@@ -1138,13 +1138,19 @@
effect and returns T, otherwise, returns NIL. (The provided threshold sizes
are rounded up to a multiple of 64Kbytes in OpenMCL 0.14 and to a multiple
of 32KBytes in earlier versions.)"
- (let* ((was-enabled (egc-active-p)))
+ (let* ((was-enabled (egc-active-p))
+ (e2size (require-type e2size '(unsigned-byte 18)))
+ (e1size (require-type e1size '(unsigned-byte 18)))
+ (e0size (require-type e0size '(integer 1 #.(ash 1 18)))))
+ (unless (<=3D e0size e1size e2size)
+ (error "Generation ~s threshold cannot be smaller than generation ~s=
threshold"
+ (if (> e0size e1size) 1 2) (if (> e0size e1size) 0 1)))
(unwind-protect
(progn
(egc nil)
- (setq e2size (logand (lognot #xffff) (+ #xffff (ash (require-ty=
pe e2size '(unsigned-byte 18)) 10)))
- e1size (logand (lognot #xffff) (+ #xffff (ash (require-ty=
pe e1size '(unsigned-byte 18)) 10)))
- e0size (logand (lognot #xffff) (+ #xffff (ash (require-ty=
pe e0size '(integer 1 #.(ash 1 18))) 10))))
+ (setq e2size (logand (lognot #xffff) (+ #xffff (ash e2size 10)))
+ e1size (logand (lognot #xffff) (+ #xffff (ash e1size 10)))
+ e0size (logand (lognot #xffff) (+ #xffff (ash e0size 10))=
))
(%configure-egc e0size e1size e2size))
(egc was-enabled))))
=
Modified: release/1.4/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
--- release/1.4/source/level-1/l1-clos-boot.lisp (original)
+++ release/1.4/source/level-1/l1-clos-boot.lisp Thu Oct 15 14:48:26 2009
@@ -356,7 +356,7 @@
(when keyp (setq bits (%ilogior (%ilsl $lfbits-keys-bit 1) bits)))
(when aokp (setq bits (%ilogior (%ilsl $lfbits-aok-bit 1) bits)))
(if return-keys?
- (values bits (apply #'vector (nreverse key-list)))
+ (values bits (and keyp (apply #'vector (nreverse key-list))))
bits)))))
=
(defun pair-arg-p (thing &optional lambda-list-ok supplied-p-ok keyword-ne=
sting-ok)
Modified: release/1.4/source/level-1/l1-error-system.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
--- release/1.4/source/level-1/l1-error-system.lisp (original)
+++ release/1.4/source/level-1/l1-error-system.lisp Thu Oct 15 14:48:26 2009
@@ -83,6 +83,7 @@
(define-condition invalid-type-warning (style-warning) ())
(define-condition invalid-arguments (style-warning) ())
(define-condition invalid-arguments-global (style-warning) ())
+(define-condition undefined-keyword-reference (undefined-reference invalid=
-arguments) ())
=
(define-condition simple-error (simple-condition error) ())
=
@@ -103,24 +104,43 @@
(format s "Invalid memory operation."))))
=
(define-condition write-to-watched-object (storage-condition)
- ((address :initarg :address)
- (object :initform nil :initarg :object))
- (:report (lambda (c s)
- (with-slots (object address) c
- (if (uvectorp object)
- ;; This is safe only because watched objects are in a
- ;; static GC area and won't be moved around.
- (let* ((size (uvsize object))
- (nbytes (if (ivectorp object)
- (subtag-bytes (typecode object) size)
- (* size target::node-size)))
- (bytes-per-element (/ nbytes size))
- (noderef (logandc2 (%address-of object)
- target::fulltagmask))
- (offset (- address (+ noderef target::node-size)))
- (index (/ offset bytes-per-element)))
- (format s "Write to watched object ~s at address #x~x (uvector index =
~d)." object address index))
- (format s "Write to watched object ~s at address #x~x" object address))=
))))
+ ((object :initform nil :initarg :object
+ :reader write-to-watched-object-object)
+ (offset :initarg :offset
+ :reader write-to-watched-object-offset)
+ (instruction :initarg :instruction
+ :reader write-to-watched-object-instruction))
+ (:report report-write-to-watched-object))
+
+(defun report-write-to-watched-object (c s)
+ (with-slots (object offset instruction) c
+ (cond
+ ((uvectorp object)
+ (let* ((count (uvsize object))
+ (nbytes (if (ivectorp object)
+ (subtag-bytes (typecode object) count)
+ (* count target::node-size)))
+ (bytes-per-element (/ nbytes count))
+ (offset (- offset target::misc-data-offset))
+ (index (/ offset bytes-per-element)))
+ (format s "Write to watched uvector ~s at " object)
+ (if (fixnump index)
+ (format s "index ~s" index)
+ (format s "an apparently unaligned byte offset ~s" offset))))
+ ((consp object)
+ (format s "Write to ~a watched cons cell ~s"
+ (cond
+ ((=3D offset target::cons.cdr) "the CDR of")
+ ((=3D offset target::cons.car) "the CAR of")
+ (t
+ (format nil "an apparently unaligned byte offset (~s) into"
+ offset)))
+ object))
+ (t
+ (format s "Write to a strange object ~s at byte offset ~s"
+ object offset)))
+ (when instruction
+ (format s "~&Faulting instruction: ~s" instruction))))
=
(define-condition type-error (error)
((datum :initarg :datum)
Modified: release/1.4/source/level-1/l1-reader.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
--- release/1.4/source/level-1/l1-reader.lisp (original)
+++ release/1.4/source/level-1/l1-reader.lisp Thu Oct 15 14:48:26 2009
@@ -2150,64 +2150,6 @@
(push (cons sub-ch fn) (cdr def))))
t))
=
-(defun %make-readtable-iterator (readtable macs? dmacs?)
- (setq readtable (readtable-arg (or readtable %initial-readtable%)))
- (let ((char-macro-alist (rdtab.alist readtable)))
- (labels ((generate ()
- (if char-macro-alist
- (destructuring-bind (char . defn) (pop char-macro-alist)
- (if (consp defn)
- (if dmacs?
- (values t char (car defn) t (cdr defn))
- (generate))
- (if macs?
- (values t char defn nil nil)
- (generate))))
- (values nil nil nil nil nil))))
- #'generate)))
-
-(defmacro with-readtable-iterator ((name readtable &rest macro-char-types)=
&body body)
- "While executing BODY, bind NAME to a macro that iterates over
- READTABLE's macros. Each invocation of NAME yields five values:
-
- VALUE? CHAR FUNCTION DISPATCH? DISPATCH-ALIST
-
- VALUE? is true until the iterator runs out of items. CHAR is the
- macro character. FUNCTION is the primary value of
- `get-macro-character' for CHAR. DISPATCH? is true if and only if
- CHAR is a dispatching macro character. DISPATCH-ALIST is an alist
- mapping sub-characters to their respective values of
- `get-dispatch-macro-character', and is NIL unless DISPATCH?.
-
- MACRO-CHAR-TYPES, which defaults
- to (:macro-char :dispatch-macro-char) thereby yielding all items,
- selects subsets of the iterated items. When `:macro-char' is
- present, yield those values where DISPATCH? is false; when
- `:dispatch-macro-char' is present, yield those values where
- DISPATCH? is true.
-
- The consequences of modifying READTABLE after entering BODY and
- before the final invocation of NAME or final use of a
- DISPATCH-ALIST are undefined."
- (unless (symbolp name)
- (signal-program-error
- "~S is not a variable name" name))
- (let ((it (gensym)) macs? dmacs?)
- (if macro-char-types
- (dolist (mct macro-char-types)
- (case mct
- ((:macro-char) (setq macs? t))
- ((:dispatch-macro-char) (setq dmacs? t))
- (otherwise
- (signal-program-error ;can't be type-error
- "~S is not one of ~S or ~S"
- mct :macro-char :dispatch-macro-char))))
- (setq macs? t dmacs? t))
- `(let ((,it (%make-readtable-iterator ,readtable ,macs? ,dmacs?)))
- (macrolet ((,name () `(funcall ,',it)))
- , at body))))
-
-
=
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Reader ;;
Modified: release/1.4/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
--- release/1.4/source/level-1/l1-readloop.lisp (original)
+++ release/1.4/source/level-1/l1-readloop.lisp Thu Oct 15 14:48:26 2009
@@ -420,14 +420,17 @@
lambda-expression))
=
=
-(defun %cons-def-info (type &optional lfbits keyvect lambda specializers q=
ualifiers)
+(defun %cons-def-info (type &optional lfbits keyvect data specializers qua=
lifiers)
(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))=
))
- (deftype (setq lambda '(type) lfbits (cons nil *loading-file-source-fi=
le*))))
- (vector lfbits keyvect *loading-file-source-file* lambda))
+ (defmacro (setq data '(macro) lfbits nil)) ;; some code assumes lfbits=
=3Dnil
+ (defgeneric (setq data (list :methods) lfbits (logior (ash 1 $lfbits-g=
fn-bit) lfbits)))
+ (defmethod (setq data (list :methods
+ (%cons-def-info-method lfbits keyvect qual=
ifiers specializers))
+ lfbits (logandc2 lfbits (ash 1 $lfbits-aok-bit))
+ keyvect nil))
+ (deftype (setq data '(type) lfbits (cons nil *loading-file-source-file=
*))))
+ (vector lfbits keyvect *loading-file-source-file* data))
=
(defun def-info.lfbits (def-info)
(and def-info
@@ -450,10 +453,31 @@
(let ((data (svref def-info 3)))
(and (eq (car data) :methods) (%cdr data)))))
=
-(defun def-info-with-new-methods (def-info new-methods)
- (if (eq new-methods (def-info.methods def-info))
+(defun %cons-def-info-method (lfbits keyvect qualifiers specializers)
+ (cons (cons (and keyvect
+ (if (logbitp $lfbits-aok-bit lfbits)
+ (and (not (logbitp $lfbits-rest-bit lfbits))
+ (list keyvect))
+ keyvect))
+ *loading-file-source-file*)
+ (cons qualifiers specializers)))
+
+(defun def-info-method.keyvect (def-info-method)
+ (let ((kv (caar def-info-method)))
+ (if (listp kv)
+ (values (car kv) t)
+ (values kv nil))))
+
+(defun def-info-method.file (def-info-method)
+ (cdar def-info-method))
+
+(defun def-info-with-new-methods (def-info new-bits new-methods)
+ (if (and (eq new-methods (def-info.methods def-info))
+ (eql new-bits (def-info.lfbits def-info)))
def-info
- (let ((new (copy-seq def-info)))
+ (let ((new (copy-seq def-info))
+ (old-bits (svref def-info 0)))
+ (setf (svref new 0) (if (consp old-bits) (cons new-bits (cdr old-bit=
s)) old-bits))
(setf (svref new 3) (cons :methods new-methods))
new)))
=
@@ -519,25 +543,66 @@
:deftype (def-info.deftype def-info)
:deftype-type (def-info.deftype-type def-info)))
=
+(defun combine-gf-def-infos (name old-info new-info)
+ (let* ((old-bits (def-info.lfbits old-info))
+ (new-bits (def-info.lfbits new-info))
+ (old-methods (def-info.methods old-info))
+ (new-methods (def-info.methods new-info)))
+ (when (and (logbitp $lfbits-gfn-bit old-bits) (logbitp $lfbits-gfn-bit=
new-bits))
+ (when *compiler-warn-on-duplicate-definitions*
+ (nx1-whine :duplicate-definition
+ name
+ (def-info.file old-info)
+ (def-info.file new-info)))
+ (return-from combine-gf-def-infos new-info))
+ (unless (congruent-lfbits-p old-bits new-bits)
+ (if (logbitp $lfbits-gfn-bit new-bits)
+ ;; A defgeneric, incongruent with previously defined methods
+ (nx1-whine :incongruent-gf-lambda-list name)
+ ;; A defmethod incongruent with previously defined explicit or imp=
licit generic
+ (nx1-whine :incongruent-method-lambda-list
+ (if new-methods `(:method ,@(cadar new-methods) ,name ,=
(cddar new-methods)) name)
+ name))
+ ;; Perhaps once this happens, should just mark it somehow to not com=
plain again
+ (return-from combine-gf-def-infos =
+ (if (logbitp $lfbits-gfn-bit old-bits) old-info new-info)))
+ (loop for new-method in new-methods
+ as old =3D (member (cdr new-method) old-methods :test #'equal :k=
ey #'cdr)
+ do (when old
+ (when *compiler-warn-on-duplicate-definitions*
+ (nx1-whine :duplicate-definition
+ `(:method ,@(cadr new-method) ,name ,(cddr new=
-method))
+ (def-info-method.file (car old))
+ (def-info-method.file new-method)))
+ (setq old-methods (remove (car old) old-methods :test #'eq)=
))
+ do (push new-method old-methods))
+ (cond ((logbitp $lfbits-gfn-bit new-bits)
+ ;; If adding a defgeneric, use its info.
+ (setq old-info new-info old-bits new-bits))
+ ((not (logbitp $lfbits-gfn-bit old-bits))
+ ;; If no defgeneric (yet?) just remember whether any method has=
&key
+ (setq old-bits (logior old-bits (logand new-bits (ash 1 $lfbits=
-keys-bit))))))
+ ;; Check that all methods implement defgeneric keys
+ (let ((gfkeys (and (logbitp $lfbits-gfn-bit old-bits) (def-info.keyvec=
t old-info))))
+ (when (> (length gfkeys) 0)
+ (loop for minfo in old-methods
+ do (multiple-value-bind (mkeys aok) (def-info-method.keyvect=
minfo)
+ (when (and mkeys
+ (not aok)
+ (setq mkeys (loop for gk across gfkeys
+ unless (find gk mkeys) col=
lect gk)))
+ (nx1-whine :gf-keys-not-accepted
+ `(:method ,@(cadr minfo) ,name ,(cddr minf=
o))
+ mkeys))))))
+ (def-info-with-new-methods old-info old-bits old-methods)))
+
(defun combine-definition-infos (name old-info new-info)
- (let ((old-type (def-info.function-type old-info)) ;; defmacro
- (old-deftype (def-info.deftype old-info)) ;; nil
- (new-type (def-info.function-type new-info)) ;; nil
- (new-deftype (def-info.deftype new-info))) ;; (nil . file)
+ (let ((old-type (def-info.function-type old-info))
+ (old-deftype (def-info.deftype old-info))
+ (new-type (def-info.function-type new-info))
+ (new-deftype (def-info.deftype 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)))
- (setq new-info (def-info-with-new-methods old-info old-method=
s))))
+ (setq new-info (combine-gf-def-infos name old-info new-info)))
((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*)
Modified: release/1.4/source/level-1/linux-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
--- release/1.4/source/level-1/linux-files.lisp (original)
+++ release/1.4/source/level-1/linux-files.lisp Thu Oct 15 14:48:26 2009
@@ -713,7 +713,7 @@
(logior #$FILE_SHARE_READ #$FILE_SHARE_WRITE)
(%null-ptr)
#$OPEN_EXISTING
- #$FILE_ATTRIBUTE_NORMAL
+ #$FILE_FLAG_BACKUP_SEMANTICS
(%null-ptr))))
(if (eql handle *windows-invalid-handle*)
(%windows-error-disp (#_GetLastError))
Modified: release/1.4/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
--- release/1.4/source/level-1/sysutils.lisp (original)
+++ release/1.4/source/level-1/sysutils.lisp Thu Oct 15 14:48:26 2009
@@ -560,6 +560,7 @@
(etypecase w
(undefined-type-reference (verify-deferred-type-warning w))
(undefined-function-reference (verify-deferred-function-warning w))
+ (undefined-keyword-reference (verify-deferred-keyword-warning w))
(compiler-warning nil)))
=
(defun verify-deferred-type-warning (w)
@@ -592,31 +593,38 @@
nil)))
=
=
+(defun deferred-function-def (name)
+ (let* ((defs (deferred-warnings.defs *outstanding-deferred-warnings*))
+ (def (or (let ((cell (gethash name defs)))
+ (and cell (def-info.function-p (cdr cell)) cell))
+ (let* ((global (fboundp name)))
+ (and (typep global 'function) global)))))
+ def))
+
+(defun check-deferred-call-args (w def wargs)
+ (destructuring-bind (arglist spread-p) wargs
+ (multiple-value-bind (deftype reason) (nx1-check-call-args def arglist=
spread-p)
+ (when deftype
+ (when (eq deftype :deferred-mismatch)
+ (setq deftype (if (consp def) :environment-mismatch :global-mism=
atch)))
+ (make-condition
+ 'invalid-arguments
+ :function-name (compiler-warning-function-name w)
+ :source-note (compiler-warning-source-note w)
+ :warning-type deftype
+ :args (list (car (compiler-warning-args w)) reason arglist spread=
-p))))))
+
(defun verify-deferred-function-warning (w)
(let* ((args (compiler-warning-args w))
(wfname (car args))
- (defs (deferred-warnings.defs *outstanding-deferred-warnings*))
- (def (or (let ((cell (gethash wfname defs)))
- (and cell (def-info.function-p (cdr cell)) cell))
- (let* ((global (fboundp wfname)))
- (and (typep global 'function) global)))))
+ (def (deferred-function-def wfname)))
(cond ((null def) w)
((or (typep def 'function)
(and (consp def)
(def-info.lfbits (cdr def))))
;; Check args in call to forward-referenced function.
(when (cdr args)
- (destructuring-bind (arglist spread-p) (cdr args)
- (multiple-value-bind (deftype reason)
- (nx1-check-call-args def arglist spread-p)
- (when deftype
- (let* ((w2 (make-condition
- 'invalid-arguments
- :function-name (compiler-warning-function-name w)
- :source-note (compiler-warning-source-note w)
- :warning-type deftype
- :args (list (car args) reason arglist spread-p))))
- w2))))))
+ (check-deferred-call-args w def (cdr args))))
((def-info.macro-p (cdr def))
(let* ((w2 (make-condition
'macro-used-before-definition
@@ -625,6 +633,13 @@
:warning-type :macro-used-before-definition
:args (list (car args)))))
w2)))))
+
+(defun verify-deferred-keyword-warning (w)
+ (let* ((args (compiler-warning-args w))
+ (wfname (car args))
+ (def (deferred-function-def wfname)))
+ (when def
+ (check-deferred-call-args w def (cddr args)))))
=
=
(defun report-deferred-warnings (&optional (file nil))
Modified: release/1.4/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
--- release/1.4/source/level-1/x86-trap-support.lisp (original)
+++ release/1.4/source/level-1/x86-trap-support.lisp Thu Oct 15 14:48:26 20=
09
@@ -386,7 +386,8 @@
;;; If the signal number is 0, other arguments (besides the exception cont=
ext XP)
;;; may not be meaningful.
(defcallback xcmain (:address xp :address xcf :int signal :long code :long=
addr :long other :int)
- (let* ((frame-ptr (macptr->fixnum xcf)))
+ (let* ((frame-ptr (macptr->fixnum xcf))
+ (skip 0))
(cond ((zerop signal) ;thread interrupt
(cmain))
((< signal 0)
@@ -430,19 +431,54 @@
:void))))
((=3D code 2)
;; Write to a watched object.
- (flet ((%int-to-object (i)
- (rlet ((a :address))
- (setf (%get-ptr a) (%int-to-ptr i))
- (%get-object a 0))))
- (let ((object (%int-to-object other)))
+ (let* ((offset other)
+ ;; The kernel exception handler leaves the
+ ;; watched object on the lisp stack under the
+ ;; xcf.
+ (object (%get-object xcf target::xcf.size)))
+ (multiple-value-bind (insn insn-length)
+ (ignore-errors (x86-faulting-instruction xp))
(restart-case (%error (make-condition
'write-to-watched-object
- :address addr
- :object object)
+ :offset offset
+ :object object
+ :instruction insn)
nil frame-ptr)
+ #-windows-target
+ (emulate ()
+ :test (lambda (c)
+ (declare (ignore c))
+ (x86-can-emulate-instruction insn))
+ :report
+ "Emulate this instruction, leaving the object watched."
+ (flet ((watchedp (object)
+ (%map-areas #'(lambda (x)
+ (when (eq object x)
+ (return-from watchedp t)))
+ area-watched area-watched)))
+ (let ((result nil))
+ (with-other-threads-suspended
+ (when (watchedp object)
+ ;; We now trust that the object is in a
+ ;; static gc area.
+ (let* ((a (+ (%address-of object) offset))
+ (ptr (%int-to-ptr
+ (logandc2 a (1- *host-page-size*)))))
+ (#_mprotect ptr *host-page-size* #$PROT_WRITE)
+ (setq result (x86-emulate-instruction xp insn))
+ (#_mprotect ptr *host-page-size*
+ (logior #$PROT_READ #$PROT_EXEC)))))
+ (if result
+ (setq skip insn-length)
+ (error "could not emulate the instrution")))))
+ (skip ()
+ :test (lambda (c)
+ (declare (ignore c))
+ insn)
+ :report "Skip over this write instruction."
+ (setq skip insn-length))
(unwatch ()
- :report (lambda (s)
- (format s "Unwatch ~s and perform the write." object))
+ :report "Unwatch the object and retry the write."
(unwatch object))))))))
((=3D signal #+win32-target 10 #-win32-target #$SIGBUS)
(if (=3D code -1)
@@ -453,5 +489,19 @@
:address addr
:write-p (not (zerop code)))
()
- frame-ptr)))))
- 0)
+ frame-ptr))))
+ skip))
+
+(defun x86-faulting-instruction (xp)
+ (let* ((code-bytes (make-array 15 :element-type '(unsigned-byte 8)))
+ (pc (indexed-gpr-macptr xp #+x8632-target eip-register-offset
+ #+x8664-target rip-register-offset)))
+ (dotimes (i (length code-bytes))
+ (setf (aref code-bytes i) (%get-unsigned-byte pc i)))
+ (let* ((ds (make-x86-disassembly-state
+ :mode-64 #+x8664-target t #+x8632-target nil
+ :code-vector code-bytes
+ :code-pointer 0))
+ (insn (x86-disassemble-instruction ds nil))
+ (len (- (x86-ds-code-pointer ds) (x86-ds-insn-start ds))))
+ (values insn len))))
Modified: release/1.4/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
--- release/1.4/source/lib/ccl-export-syms.lisp (original)
+++ release/1.4/source/lib/ccl-export-syms.lisp Thu Oct 15 14:48:26 2009
@@ -705,7 +705,6 @@
unmap-octet-vector
;; Miscellany
heap-utilization
- with-readtable-iterator
=
external-process-creation-failure
=
Modified: release/1.4/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
--- release/1.4/source/lib/compile-ccl.lisp (original)
+++ release/1.4/source/lib/compile-ccl.lisp Thu Oct 15 14:48:26 2009
@@ -174,7 +174,7 @@
(append *other-lib-modules*
(case target
((:ppc32 :ppc64) '(ppc-backtrace ppc-disassemble))
- ((:x8632 :x8664) '(x86-backtrace x86-disassemble)))))
+ ((:x8632 :x8664) '(x86-backtrace x86-disassemble x86-watch)))))
=
=
(defun target-lib-modules (&optional (backend-name
Propchange: release/1.4/source/lib/ffi-win64.lisp
---------------------------------------------------------------------------=
---
--- svn:executable (original)
+++ svn:executable (removed)
@@ -1,1 +1,0 @@
-*
Modified: release/1.4/source/lib/level-2.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
--- release/1.4/source/lib/level-2.lisp (original)
+++ release/1.4/source/lib/level-2.lisp Thu Oct 15 14:48:26 2009
@@ -48,7 +48,6 @@
; This is so we can be pedantic about binding &WHOLE/&ENVIRONMENT args
; that have been scarfed out of a macro-like lambda list.
; The returned value is supposed to be suitable for splicing ...
-#+not-used
(defun hoist-special-decls (sym decls)
(when sym
(dolist (decl decls)
Modified: release/1.4/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
--- release/1.4/source/lib/macros.lisp (original)
+++ release/1.4/source/lib/macros.lisp Thu Oct 15 14:48:26 2009
@@ -177,69 +177,29 @@
(defmacro %vstack-block (spec &body forms)
`(%stack-block (,spec) , at forms))
=
-
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
-(defun extract-type-decl-for-dolist-var (var decls env)
- (if (null decls)
- (values nil nil nil)
- (let* ((declared-type-p nil))
- (collect ((new-decls)
- (declared-types))
- (dolist (declform decls)
- ;; (assert (eq (car declform) 'declare))
- (dolist (decl (cdr declform))
- (if (atom decl)
- (new-decls decl)
- (let* ((spec (car decl)))
- (if (specifier-type-if-known spec env)
- (setq spec 'type
- decl `(type , at decl)))
- (if (eq spec 'type)
- (destructuring-bind (typespec &rest vars) (cdr decl)
- (cond ((member var vars :test #'eq)
- (setq declared-type-p t)
- (declared-types typespec)
- (new-decls `(type ,typespec ,@(remove var vars)=
)))
- (t (new-decls decl))))
- (new-decls decl))))))
- (if (not declared-type-p)
- (values nil nil (new-decls))
- (values t
- (let* ((declared-type (declared-types)))
- (if (cdr declared-type)
- `(and , at declared-type)
- (car declared-type)))
- (new-decls)))))))
-)
-
-
(defmacro dolist ((varsym list &optional ret) &body body &environment env)
(if (not (symbolp varsym)) (signal-program-error $XNotSym varsym))
(let* ((toplab (gensym))
(tstlab (gensym))
(lstsym (gensym)))
(multiple-value-bind (forms decls) (parse-body body env nil)
- (multiple-value-bind (var-type-p vartype other-decls)
- (extract-type-decl-for-dolist-var varsym decls env)
- (if var-type-p
- (setq forms `((locally (declare (type ,vartype ,varsym)) (tagbod=
y , at forms)))))
- (if other-decls
- (setq other-decls `((declare , at other-decls))))
- `(block nil
- (let* ((,lstsym ,list) ,varsym)
- ,@(if var-type-p `((declare (type (or null ,vartype) ,varsym))=
))
- , at other-decls
- (tagbody
- (go ,tstlab)
- ,toplab
- (setq ,lstsym (cdr (the list ,lstsym)))
- , at forms
- ,tstlab
- (setq ,varsym (car ,lstsym))
- (if ,lstsym (go ,toplab)))
- ,@(if ret `((progn ,ret)))))))))
-
+ `(block nil
+ (let* ((,lstsym ,list))
+ (tagbody
+ (go ,tstlab)
+ ,toplab
+ (let ((,varsym (car ,lstsym)))
+ , at decls
+ (tagbody
+ , at forms)
+ (setq ,lstsym (cdr (the list ,lstsym))))
+ ,tstlab
+ (if ,lstsym (go ,toplab))))
+ ,@(if ret `((let ((,varsym nil))
+ (declare (ignore-if-unused ,varsym)
+ ,@(loop for decl in decls
+ append (remove 'special (cdr decl)=
:test #'neq :key #'car)))
+ ,ret)))))))
=
(defmacro dovector ((varsym vector &optional ret) &body body &environment =
env)
(if (not (symbolp varsym))(signal-program-error $XNotSym varsym))
@@ -1810,21 +1770,14 @@
ll)
(append ll '(&allow-other-keys)))))
=
-(defun encode-gf-lambda-list (lambda-list)
- (let* ((bits (encode-lambda-list lambda-list)))
- (declare (fixnum bits))
- (if (logbitp $lfbits-keys-bit bits)
- (logior bits (ash 1 $lfbits-aok-bit))
- bits)))
-
(defmacro defmethod (name &rest args &environment env)
(multiple-value-bind (function-form specializers-form qualifiers lambda-=
list documentation specializers)
(parse-defmethod name args env)
`(progn
(eval-when (:compile-toplevel)
(record-function-info ',(maybe-setf-function-name name)
- ',(%cons-def-info 'defmethod (encode-gf-lam=
bda-list lambda-list) nil nil
- specializers qualifiers)
+ ',(multiple-value-bind (bits keyvect) (enco=
de-lambda-list lambda-list t)
+ (%cons-def-info 'defmethod bits keyvect=
nil specializers qualifiers))
,env))
(compiler-let ((*nx-method-warning-name* '(,name , at qualifiers ,spec=
ializers)))
(ensure-method ',name ,specializers-form
@@ -2125,7 +2078,8 @@
`(progn
(eval-when (:compile-toplevel)
(record-function-info ',(maybe-setf-function-name function-name)
- ',(%cons-def-info 'defgeneric (encode-gf-=
lambda-list lambda-list))
+ ',(multiple-value-bind (bits keyvect) (en=
code-lambda-list lambda-list t)
+ (%cons-def-info 'defgeneric bits keyv=
ect))
,env))
(let ((,gf (%defgeneric
',function-name ',lambda-list ',method-combination ',=
generic-function-class =
Modified: release/1.4/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
--- release/1.4/source/lib/misc.lisp (original)
+++ release/1.4/source/lib/misc.lisp Thu Oct 15 14:48:26 2009
@@ -963,19 +963,27 @@
(defun report-heap-utilization (out nconses nvectors vector-sizes vector-p=
hysical-sizes)
(let* ((total-cons-size (* nconses target::cons.size))
(total-vector-size 0)
- (total-physical-vector-size 0))
- (format out "~&Object type~40tCount~48tTotal Size in Bytes~70tTotal Si=
ze")
- (format out "~&CONS~34t~12d~46t~16d~16d" nconses total-cons-size total=
-cons-size)
+ (total-physical-vector-size 0)
+ (total-size 0))
+ (format out "~&Object type~42tCount~50tTotal Size in Bytes~72tTotal Si=
ze~82t % of Heap")
+ (dotimes( i (length nvectors))
+ (incf total-vector-size (aref vector-sizes i))
+ (incf total-physical-vector-size (aref vector-physical-sizes i)))
+ (setq total-size (+ total-cons-size total-physical-vector-size))
+ (unless (zerop nconses)
+ (format out "~&CONS~36t~12d~48t~16d~16d~8,2f%" nconses total-cons-si=
ze total-cons-size
+ (* 100 (/ total-cons-size total-size))))
(dotimes (i (length nvectors))
- (let* ((count (aref nvectors i))
- (sizes (aref vector-sizes i))
- (psizes (aref vector-physical-sizes i)))
+ (let ((count (aref nvectors i))
+ (sizes (aref vector-sizes i))
+ (psizes (aref vector-physical-sizes i)))
(unless (zerop count)
- (incf total-vector-size sizes)
- (incf total-physical-vector-size psizes)
- (format out "~&~a~34t~12d~46t~16d~16d" (aref *heap-utilization-v=
ector-type-names* i) count sizes psizes))))
- (format out "~& Total sizes: ~47t~16d~16d" (+ total-cons-size total-=
vector-size) (+ total-cons-size total-physical-vector-size))))
- =
+ (format out "~&~a~36t~12d~48t~16d~16d~8,2f%"
+ (aref *heap-utilization-vector-type-names* i)
+ count sizes psizes
+ (* 100.0 (/ psizes total-size))))))
+ (format out "~& Total sizes: ~49t~16d~16d" (+ total-cons-size total-=
vector-size) (+ total-cons-size total-physical-vector-size))))
+
;; The number of words to allocate for static conses when the user requests
;; one and we don't have any left over
(defparameter *static-cons-chunk* 1048576)
@@ -1043,25 +1051,35 @@
(lock-name lock)
(%ptr-to-int (%svref lock target::lock._value-cell)))))
=
+(defun all-watched-objects ()
+ (let (result)
+ (with-other-threads-suspended
+ (%map-areas #'(lambda (x) (push x result)) area-watched area-watched=
))
+ result))
+
+(defun primitive-watch (thing)
+ (require-type thing '(or cons (satisfies uvectorp)))
+ (%watch thing))
+
(defun watch (&optional thing)
- (if thing
- (progn
- (require-type thing '(or cons (satisfies uvectorp)))
- (%watch thing))
- (let (result)
- (%map-areas #'(lambda (x) (push x result)) area-watched area-watched)
- result)))
+ (cond ((null thing)
+ (all-watched-objects))
+ ((arrayp thing)
+ (primitive-watch (array-data-and-offset thing)))
+ ((hash-table-p thing)
+ (primitive-watch (nhash.vector thing)))
+ ((standard-instance-p thing)
+ (primitive-watch (instance-slots thing)))
+ (t
+ (primitive-watch thing))))
=
(defun unwatch (thing)
- (%map-areas #'(lambda (x)
- (when (eq x thing)
- ;; This is a rather questionable thing to do,
- ;; since we'll be unlinking an area from the area
- ;; list while %map-areas iterates over it, but I
- ;; think we'll get away with it.
- (let ((new (if (uvectorp thing)
- (%alloc-misc (uvsize thing) (typecode thing))
- (cons nil nil))))
- (return-from unwatch (%unwatch thing new)))))
- area-watched area-watched))
- =
+ (with-other-threads-suspended
+ (%map-areas #'(lambda (x)
+ (when (eq x thing)
+ (let ((new (if (uvectorp thing)
+ (%alloc-misc (uvsize thing)
+ (typecode thing))
+ (cons nil nil))))
+ (return-from unwatch (%unwatch thing new)))))
+ area-watched area-watched)))
Modified: release/1.4/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
--- release/1.4/source/lib/nfcomp.lisp (original)
+++ release/1.4/source/lib/nfcomp.lisp Thu Oct 15 14:48:26 2009
@@ -1230,7 +1230,18 @@
(ash 1 x8664::fulltag-immheader-1)
(ash 1 x8664::fulltag-immheader-2))))
(case type-code
- ((#.target::subtag-macptr #.target::subtag-dead-macptr) (unle=
ss (%null-ptr-p exp) (fasl-unknown exp)))
+ (#.target::subtag-dead-macptr (fasl-unknown exp))
+ (#.target::subtag-macptr
+ ;; Treat untyped pointers to the high/low 64K of the address
+ ;; space as constants. Refuse to dump other pointers.
+ (unless (and (zerop (%macptr-type exp))
+ (<=3D (%macptr-domain exp) 1))
+ (error "Can't dump typed pointer ~s" exp))
+ (let* ((addr (%ptr-to-int exp)))
+ (unless (or (< addr #x10000)
+ (>=3D addr (- (ash 1 target::nbits-in-word)
+ #x10000)))
+ (error "Can't dump pointer ~s : address is not in the lo=
w or high 64K of the address space." exp))))
(t (fasl-scan-ref exp)))
(case type-code
((#.target::subtag-pool #.target::subtag-weak #.target::subta=
g-lock) (fasl-unknown exp))
Modified: release/1.4/source/lib/systems.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
--- release/1.4/source/lib/systems.lisp (original)
+++ release/1.4/source/lib/systems.lisp Thu Oct 15 14:48:26 2009
@@ -160,6 +160,7 @@
(backtrace "ccl:bin;backtrace" ("ccl:lib;backtrace.lisp"=
))
(ppc-backtrace "ccl:bin;ppc-backtrace" ("ccl:lib;ppc-backtrace.l=
isp"))
(x86-backtrace "ccl:bin;x86-backtrace" ("ccl:lib;x86-backtrace.l=
isp"))
+ (x86-watch "ccl:bin;x86-watch" ("ccl:lib;x86-watch.lisp"=
))
(backtrace-lds "ccl:bin;backtrace-lds" ("ccl:lib;backtrace-lds.l=
isp"))
(apropos "ccl:bin;apropos" ("ccl:lib;apropos.lisp"))
(numbers "ccl:bin;numbers" ("ccl:lib;numbers.lisp"))
Modified: release/1.4/source/library/leaks.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
--- release/1.4/source/library/leaks.lisp (original)
+++ release/1.4/source/library/leaks.lisp Thu Oct 15 14:48:26 2009
@@ -234,6 +234,7 @@
(defun parse-mtrace-log (log-file)
(with-open-file (s log-file)
(let ((hash (make-hash-table :test 'equal))
+ (free-list '())
(eof (list :eof)))
(loop for line =3D (read-line s nil eof)
until (eq line eof)
@@ -241,8 +242,8 @@
(equal "@ " (subseq line 0 2)))
do
(setf line (subseq line 2))
- (let ((plus-pos (search " + " line))
- (minus-pos (search " - " line)))
+ (let ((plus-pos (or (search " + " line) (search " > " line)))
+ (minus-pos (or (search " - " line) (search " < " line))))
(cond (plus-pos
(let* ((where (subseq line 0 plus-pos))
(addr-and-size (subseq line (+ plus-pos 3)))
@@ -251,13 +252,29 @@
(size (subseq addr-and-size (1+ space-pos))))
(setf (gethash addr hash) (list where size))))
(minus-pos
- (let ((addr (subseq line (+ minus-pos 3))))
- (remhash addr hash))))))
+ (let* ((where (subseq line 0 minus-pos))
+ (addr (subseq line (+ minus-pos 3)))
+ (found (nth-value 1 (gethash addr hash))))
+ (if found
+ (remhash addr hash)
+ (push (list where addr) free-list)))))))
(let ((res nil))
(maphash (lambda (key value)
(push (append value (list key)) res))
hash)
- res))))
+ (values res free-list)))))
+
+(defun pretty-print-mtrace-summary (file)
+ (let* ((malloc-sum 0))
+ (multiple-value-bind (mallocs frees) (parse-mtrace-log file)
+ (dolist (i mallocs)
+ (incf malloc-sum (parse-integer (second i) :radix 16 :start 2))
+ (format t "~&~A" i))
+ (format t "~&Freed but not malloced:~%~{~A~%~}" frees)
+ (format t "~&total-malloc-not-freed: ~~A ~A free not malloc: ~A"
+ (/ malloc-sum 1024.0)
+ (length mallocs)
+ (length frees)))))
=
;; Return the total number of bytes allocated by malloc()
(defun mallinfo ()
@@ -265,4 +282,47 @@
(#_mallinfo mallinfo)
(ccl::rref mallinfo :mallinfo.uordblks)))
=
+#||
+http://www.gnu.org/s/libc/manual/html_node/Statistics-of-Malloc.html
+
+int arena
+ This is the total size of memory allocated with sbrk by malloc, in byt=
es.
+int ordblks
+ This is the number of chunks not in use. (The memory allocator interna=
lly gets chunks of memory from the operating system, and then carves them u=
p to satisfy individual malloc requests; see Efficiency and Malloc.)
+int smblks
+ This field is unused.
+int hblks
+ This is the total number of chunks allocated with mmap.
+int hblkhd
+ This is the total size of memory allocated with mmap, in bytes.
+int usmblks
+ This field is unused.
+int fsmblks
+ This field is unused.
+int uordblks
+ This is the total size of memory occupied by chunks handed out by mall=
oc.
+int fordblks
+ This is the total size of memory occupied by free (not in use) chunks.
+int keepcost
+ This is the size of the top-most releasable chunk that normally border=
s the end of the heap (i.e., the high end of the virtual address space's da=
ta segment).
+||# =
+
+(defun show-malloc-info ()
+ (rlet ((info :mallinfo))
+ (#_mallinfo info) ;struct return invisible arg.
+ (let* ((arena (pref info :mallinfo.arena))
+ (ordblks (pref info :mallinfo.ordblks))
+ (hblks (pref info :mallinfo.hblks))
+ (hblkhd (pref info :mallinfo.hblkhd))
+ (uordblks (pref info :mallinfo.uordblks))
+ (fordblks (pref info :mallinfo.fordblks))
+ (keepcost (pref info :mallinfo.keepcost)))
+ (format t "~& arena size: ~d/#x~x" arena arena)
+ (format t "~& number of unused chunks =3D ~d" ordblks)
+ (format t "~& number of mmap'ed chunks =3D ~d" hblks)
+ (format t "~& total size of mmap'ed chunks =3D ~d/#x~x" hblkhd hblkh=
d)
+ (format t "~& total size of malloc'ed chunks =3D ~d/#x~x" uordblks u=
ordblks)
+ (format t "~& total size of free chunks =3D ~d/#x~x" fordblks fordbl=
ks)
+ (format t "~& size of releaseable chunk =3D ~d/#x~x" keepcost keepco=
st))))
+
) ;; end of linux-only code
Propchange: release/1.4/source/library/x86-win64-syscalls.lisp
---------------------------------------------------------------------------=
---
--- svn:executable (original)
+++ svn:executable (removed)
@@ -1,1 +1,0 @@
-*
Modified: release/1.4/source/lisp-kernel/windows-calls.c
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- release/1.4/source/lisp-kernel/windows-calls.c (original)
+++ release/1.4/source/lisp-kernel/windows-calls.c Thu Oct 15 14:48:26 2009
@@ -194,14 +194,11 @@
dwShareMode =3D FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE;
=
if ((flag & _O_WRONLY) =3D=3D _O_WRONLY) {
- dwDesiredAccess |=3D GENERIC_WRITE | FILE_WRITE_DATA |
- FILE_READ_ATTRIBUTES | FILE_WRITE_ATTRIBUTES;
+ dwDesiredAccess |=3D GENERIC_WRITE;
} else if ((flag & _O_RDWR) =3D=3D _O_RDWR) {
- dwDesiredAccess |=3D GENERIC_WRITE|GENERIC_READ | FILE_READ_DATA |
- FILE_WRITE_DATA | FILE_READ_ATTRIBUTES | FILE_WRITE_ATTRIBUTES;
+ dwDesiredAccess |=3D GENERIC_WRITE|GENERIC_READ;
} else {
- dwDesiredAccess |=3D GENERIC_READ | FILE_READ_DATA | FILE_READ_ATTRIBU=
TES |
- FILE_WRITE_ATTRIBUTES;
+ dwDesiredAccess |=3D GENERIC_READ;
}
=
=
Modified: release/1.4/source/lisp-kernel/x86-exceptions.c
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- release/1.4/source/lisp-kernel/x86-exceptions.c (original)
+++ release/1.4/source/lisp-kernel/x86-exceptions.c Thu Oct 15 14:48:26 2009
@@ -841,11 +841,16 @@
(header_subtag(header_of(cmain)) =3D=3D subtag_macptr)) {
LispObj save_vsp =3D xpGPR(xp, Isp);
LispObj save_fp =3D xpGPR(xp, Ifp);
- LispObj xcf =3D create_exception_callback_frame(xp, tcr);
+ LispObj xcf;
+ natural offset =3D (LispObj)addr - obj;
int skip;
=
+ push_on_lisp_stack(xp, obj);
+ xcf =3D create_exception_callback_frame(xp, tcr);
+
/* The magic 2 means this was a write to a watchd object */
- skip =3D callback_to_lisp(tcr, cmain, xp, xcf, SIGSEGV, 2, (natural) ad=
dr, obj);
+ skip =3D callback_to_lisp(tcr, cmain, xp, xcf, SIGSEGV, 2,
+ (natural)addr, offset);
xpPC(xp) +=3D skip;
xpGPR(xp, Ifp) =3D save_fp;
xpGPR(xp, Isp) =3D save_vsp;
@@ -3729,7 +3734,7 @@
else
size =3D uvector_total_size_in_bytes(noderef);
=
- if (object_area && object_area->code !=3D AREA_WATCHED) {
+ if (object_area && object_area->code =3D=3D AREA_DYNAMIC) {
area *a =3D new_watched_area(size);
LispObj old =3D object;
LispObj new =3D (LispObj)((natural)a->low + tag);
@@ -3742,6 +3747,7 @@
memset(noderef, 0, size);
wp_update_references(tcr, old, new);
check_all_areas(tcr);
+ return 1;
}
return 0;
}
@@ -3785,10 +3791,13 @@
{
LispObj selector =3D xpGPR(xp,Iimm0);
LispObj object =3D xpGPR(xp, Iarg_z);
+ signed_natural result;
=
switch (selector) {
case WATCH_TRAP_FUNCTION_WATCH:
- gc_like_from_xp(xp, watch_object, object);
+ result =3D gc_like_from_xp(xp, watch_object, object);
+ if (result =3D=3D 0)
+ xpGPR(xp,Iarg_z) =3D lisp_nil;
break;
case WATCH_TRAP_FUNCTION_UNWATCH:
gc_like_from_xp(xp, unwatch_object, 0);
Modified: release/1.4/source/lisp-kernel/x86-gc.c
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- release/1.4/source/lisp-kernel/x86-gc.c (original)
+++ release/1.4/source/lisp-kernel/x86-gc.c Thu Oct 15 14:48:26 2009
@@ -2811,12 +2811,14 @@
* be nice to generalize it somehow.
*/
=
-static inline void
+static inline int
wp_maybe_update(LispObj *p, LispObj old, LispObj new)
{
if (*p =3D=3D old) {
*p =3D new;
- }
+ return true;
+ }
+ return false;
}
=
static void
@@ -2846,7 +2848,6 @@
p =3D (LispObj *)skip_over_ivector(ptr_to_lispobj(p), node);
} else if (nodeheader_tag_p(tag_n)) {
nwords =3D header_element_count(node);
- =
nwords +=3D 1 - (nwords & 1);
=
if ((header_subtag(node) =3D=3D subtag_hash_vector) &&
@@ -2857,7 +2858,7 @@
p++;
nwords -=3D skip;
while(skip--) {
- if (*p =3D=3D old) *p =3D new;
+ wp_maybe_update(p, old, new);
p++;
}
/* "nwords" is odd at this point: there are (floor nwords 2)
@@ -2866,13 +2867,12 @@
past the alignment word. */
nwords >>=3D 1;
while(nwords--) {
- if (*p =3D=3D old && hashp) {
- *p =3D new;
+ if (wp_maybe_update(p, old, new) && hashp) {
hashp->flags |=3D nhash_key_moved_mask;
hashp =3D NULL;
}
p++;
- if (*p =3D=3D old) *p =3D new;
+ wp_maybe_update(p, old, new);
p++;
}
*p++ =3D 0;
@@ -3055,5 +3055,7 @@
wp_update_tcr_tlb(other_tcr, old, new);
other_tcr =3D other_tcr->next;
} while (other_tcr !=3D tcr);
+ unprotect_watched_areas();
wp_update_all_areas(old, new);
-}
+ protect_watched_areas();
+}
Modified: release/1.4/source/lisp-kernel/x86_print.c
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- release/1.4/source/lisp-kernel/x86_print.c (original)
+++ release/1.4/source/lisp-kernel/x86_print.c Thu Oct 15 14:48:26 2009
@@ -237,7 +237,7 @@
{
add_c_string("#<");
sprint_unsigned_decimal(elements);
- add_c_string("-element vector subtag =3D ");
+ add_c_string("-element vector subtag =3D #x");
add_char(digits[subtag>>4]);
add_char(digits[subtag&15]);
add_c_string(" @");
Modified: release/1.4/source/objc-bridge/objc-runtime.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
--- release/1.4/source/objc-bridge/objc-runtime.lisp (original)
+++ release/1.4/source/objc-bridge/objc-runtime.lisp Thu Oct 15 14:48:26 20=
09
@@ -2548,6 +2548,34 @@
(setq info name-info))))
(apply (objc-message-info-lisp-name info) instance args)))
=
+(defun objc-set->setf (method)
+ (let* ((info (get-objc-message-info method))
+ (name (objc-message-info-lisp-name info))
+ (str (symbol-name name))
+ (value-placeholder-index (position #\: str)))
+ (when (and (> (length str) 4) value-placeholder-index)
+ (let* ((truncated-name (nstring-downcase (subseq (remove #\: str
+ :test #'cha=
r=3D :count 1)
+ 3)
+ :end 1))
+ (reader-name (if (> (length truncated-name)
+ (decf value-placeholder-index 3))
+ (nstring-upcase truncated-name
+ :start value-placeholder-index
+ :end (1+ value-placeholder-inde=
x))
+ truncated-name))
+ (reader (intern reader-name :nextstep-functions)))
+ (eval `(defun (setf ,reader) (value object &rest args)
+ (apply #',name object value args)
+ value))))))
+
+(defun register-objc-set-messages ()
+ (do-interface-dirs (d)
+ (dolist (init (cdb-enumerate-keys (db-objc-methods d)
+ #'(lambda (string)
+ (string=3D string "set"
+ :end1 (min (length stri=
ng) 3)))))
+ (objc-set->setf init))))
=
=
=
@@ -2746,6 +2774,8 @@
:typestring typestring
:imp imp
:class-p class-p)))
+ (if (string=3D selname "set" :end1 (min (length selname) 3))
+ (objc-set->setf selname))
impname)
=
=
Modified: release/1.4/source/objc-bridge/objc-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
--- release/1.4/source/objc-bridge/objc-support.lisp (original)
+++ release/1.4/source/objc-bridge/objc-support.lisp Thu Oct 15 14:48:26 20=
09
@@ -106,6 +106,7 @@
(register-objc-class-decls)
(maybe-map-objc-classes t)
(register-objc-init-messages)
+(register-objc-set-messages)
=
#+gnu-objc
(defun iterate-over-class-methods (class method-function)
@@ -551,7 +552,8 @@
:test #'equalp)
(map-objc-classes)
;; Update info about init messages.
- (register-objc-init-messages))
+ (register-objc-init-messages)
+ (register-objc-set-messages))
(return winning)))))))))))
=
(defun objc:load-framework (framework-name interfaces-name)
Modified: release/1.4/source/scripts/makedmg
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- release/1.4/source/scripts/makedmg (original)
+++ release/1.4/source/scripts/makedmg Thu Oct 15 14:48:26 2009
@@ -1,4 +1,3 @@
-
#!/bin/sh
#
# Creates a compresses disk image from the current directory
Modified: release/1.4/source/tools/asdf.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
--- release/1.4/source/tools/asdf.lisp (original)
+++ release/1.4/source/tools/asdf.lisp Thu Oct 15 14:48:26 2009
@@ -1,19 +1,29 @@
-;;; This is asdf: Another System Definition Facility. $Revision$
+;;; This is asdf: Another System Definition Facility. =
+;;; hash - $Format:%H$
+;;;
+;;; Local Variables:
+;;; mode: lisp
+;;; End:
;;;
;;; Feedback, bug reports, and patches are all welcome: please mail to
-;;; <cclan-list at lists.sf.net>. But note first that the canonical
-;;; source for asdf is presently the cCLan CVS repository at
-;;; <URL:http://cvs.sourceforge.net/cgi-bin/viewcvs.cgi/cclan/asdf/>
+;;; <asdf-devel at common-lisp.net>. But note first that the canonical
+;;; source for asdf is presently on common-lisp.net at
+;;; <URL:http://common-lisp.net/project/asdf/>
;;;
;;; If you obtained this copy from anywhere else, and you experience
;;; trouble using it, or find bugs, you may want to check at the
;;; location above for a more recent version (and for documentation
;;; and test files, if your copy came without them) before reporting
-;;; bugs. There are usually two "supported" revisions - the CVS HEAD
+;;; bugs. There are usually two "supported" revisions - the git HEAD
;;; is the latest development version, whereas the revision tagged
;;; RELEASE may be slightly older but is considered `stable'
=
-;;; Copyright (c) 2001-2008 Daniel Barlow and contributors
+;;; -- LICENSE START
+;;; (This is the MIT / X Consortium license as taken from =
+;;; http://www.opensource.org/licenses/mit-license.html on or about
+;;; Monday; July 13, 2009)
+;;;
+;;; Copyright (c) 2001-2009 Daniel Barlow and contributors
;;;
;;; Permission is hereby granted, free of charge, to any person obtaining
;;; a copy of this software and associated documentation files (the
@@ -33,15 +43,20 @@
;;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
;;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
;;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+;;;
+;;; -- LICENSE END
=
;;; the problem with writing a defsystem replacement is bootstrapping:
;;; we can't use defsystem to compile it. Hence, all in one file
=
+#+xcvb (module ())
+
(defpackage #:asdf
+ (:documentation "Another System Definition Facility")
(:export #:defsystem #:oos #:operate #:find-system #:run-shell-command
#:system-definition-pathname #:find-component ; miscellaneous
-
- #:compile-op #:load-op #:load-source-op =
+ #:compile-system #:load-system #:test-system
+ #:compile-op #:load-op #:load-source-op
#:test-op
#:operation ; operations
#:feature ; sort-of operation
@@ -80,6 +95,7 @@
#:system-licence
#:system-source-file
#:system-relative-pathname
+ #:map-systems
=
#:operation-on-warnings
#:operation-on-failure
@@ -90,6 +106,7 @@
#:*compile-file-warnings-behaviour*
#:*compile-file-failure-behaviour*
#:*asdf-revision*
+ #:*resolve-symlinks*
=
#:operation-error #:compile-failed #:compile-warned #:compile-e=
rror
#:error-component #:error-operation
@@ -104,10 +121,20 @@
#:try-recompiling
#:retry
#:accept ; restarts
+ #:coerce-entry-to-directory
+ #:remove-entry-from-registry
=
#:standard-asdf-method-combination
#:around ; protocol assistants
- )
+ =
+ #:*source-to-target-mappings*
+ #:*default-toplevel-directory*
+ #:*centralize-lisp-binaries*
+ #:*include-per-user-information*
+ #:*map-all-source-files*
+ #:output-files-for-system-and-operation
+ #:*enable-asdf-binary-locations*
+ #:implementation-specific-directory-name)
(:use :cl))
=
=
@@ -118,14 +145,15 @@
=
(in-package #:asdf)
=
-(defvar *asdf-revision* (let* ((v "$Revision$")
- (colon (or (position #\: v) -1))
- (dot (position #\. v)))
- (and v colon dot
- (list (parse-integer v :start (1+ colon)
- :junk-allowed t)
- (parse-integer v :start (1+ dot)
- :junk-allowed t)))))
+(defvar *asdf-revision* =
+ ;; the 1+ hair is to ensure that we don't do an inadvertant find and rep=
lace
+ (subseq "REVISION:1.366" (1+ (length "REVISION"))))
+ =
+
+(defvar *resolve-symlinks* t
+ "Determine whether or not ASDF resolves symlinks when defining systems.
+
+Defaults to `t`.")
=
(defvar *compile-file-warnings-behaviour* :warn)
=
@@ -135,382 +163,6 @@
=
(defparameter +asdf-methods+
'(perform explain output-files operation-done-p))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; utility stuff
-
-(defmacro aif (test then &optional else)
- `(let ((it ,test)) (if it ,then ,else)))
-
-(defun pathname-sans-name+type (pathname)
- "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME,
-and NIL NAME and TYPE components"
- (make-pathname :name nil :type nil :defaults pathname))
-
-(define-modify-macro appendf (&rest args)
- append "Append onto list")
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; classes, condiitons
-
-(define-condition system-definition-error (error) ()
- ;; [this use of :report should be redundant, but unfortunately it's not.
- ;; cmucl's lisp::output-instance prefers the kernel:slot-class-print-fun=
ction
- ;; over print-object; this is always conditions::%print-condition for
- ;; condition objects, which in turn does inheritance of :report options =
at
- ;; run-time. fortunately, inheritance means we only need this kludge he=
re in
- ;; order to fix all conditions that build on it. -- rgr, 28-Jul-02.]
- #+cmu (:report print-object))
-
-(define-condition formatted-system-definition-error (system-definition-err=
or)
- ((format-control :initarg :format-control :reader format-control)
- (format-arguments :initarg :format-arguments :reader format-arguments))
- (:report (lambda (c s)
- (apply #'format s (format-control c) (format-arguments c)))))
-
-(define-condition circular-dependency (system-definition-error)
- ((components :initarg :components :reader circular-dependency-components=
)))
-
-(define-condition duplicate-names (system-definition-error)
- ((name :initarg :name :reader duplicate-names-name)))
-
-(define-condition missing-component (system-definition-error)
- ((requires :initform "(unnamed)" :reader missing-requires :initarg :requ=
ires)
- (parent :initform nil :reader missing-parent :initarg :parent)))
-
-(define-condition missing-component-of-version (missing-component)
- ((version :initform nil :reader missing-version :initarg :version)))
-
-(define-condition missing-dependency (missing-component)
- ((required-by :initarg :required-by :reader missing-required-by)))
-
-(define-condition missing-dependency-of-version (missing-dependency
- missing-component-of-version)
- ())
-
-(define-condition operation-error (error)
- ((component :reader error-component :initarg :component)
- (operation :reader error-operation :initarg :operation))
- (:report (lambda (c s)
- (format s "~@<erred while invoking ~A on ~A~@:>"
- (error-operation c) (error-component c)))))
-(define-condition compile-error (operation-error) ())
-(define-condition compile-failed (compile-error) ())
-(define-condition compile-warned (compile-error) ())
-
-(defclass component ()
- ((name :accessor component-name :initarg :name :documentation
- "Component name: designator for a string composed of portable pat=
hname characters")
- (version :accessor component-version :initarg :version)
- (in-order-to :initform nil :initarg :in-order-to)
- ;; XXX crap name
- (do-first :initform nil :initarg :do-first)
- ;; methods defined using the "inline" style inside a defsystem form:
- ;; need to store them somewhere so we can delete them when the system
- ;; is re-evaluated
- (inline-methods :accessor component-inline-methods :initform nil)
- (parent :initarg :parent :initform nil :reader component-parent)
- ;; no direct accessor for pathname, we do this as a method to allow
- ;; it to default in funky ways if not supplied
- (relative-pathname :initarg :pathname)
- (operation-times :initform (make-hash-table )
- :accessor component-operation-times)
- ;; XXX we should provide some atomic interface for updating the
- ;; component properties
- (properties :accessor component-properties :initarg :properties
- :initform nil)))
-
-;;;; methods: conditions
-
-(defmethod print-object ((c missing-dependency) s)
- (format s "~@<~A, required by ~A~@:>"
- (call-next-method c nil) (missing-required-by c)))
-
-(defun sysdef-error (format &rest arguments)
- (error 'formatted-system-definition-error :format-control format :format=
-arguments arguments))
-
-;;;; methods: components
-
-(defmethod print-object ((c missing-component) s)
- (format s "~@<component ~S not found~
- ~@[ in ~A~]~@:>"
- (missing-requires c)
- (when (missing-parent c)
- (component-name (missing-parent c)))))
-
-(defmethod print-object ((c missing-component-of-version) s)
- (format s "~@<component ~S does not match version ~A~
- ~@[ in ~A~]~@:>"
- (missing-requires c)
- (missing-version c)
- (when (missing-parent c)
- (component-name (missing-parent c)))))
-
-(defgeneric component-system (component)
- (:documentation "Find the top-level system containing COMPONENT"))
-
-(defmethod component-system ((component component))
- (aif (component-parent component)
- (component-system it)
- component))
-
-(defmethod print-object ((c component) stream)
- (print-unreadable-object (c stream :type t :identity t)
- (ignore-errors
- (prin1 (component-name c) stream))))
-
-(defclass module (component)
- ((components :initform nil :accessor module-components :initarg :compone=
nts)
- ;; what to do if we can't satisfy a dependency of one of this module's
- ;; components. This allows a limited form of conditional processing
- (if-component-dep-fails :initform :fail
- :accessor module-if-component-dep-fails
- :initarg :if-component-dep-fails)
- (default-component-class :accessor module-default-component-class
- :initform 'cl-source-file :initarg :default-component-class)))
-
-(defgeneric component-pathname (component)
- (:documentation "Extracts the pathname applicable for a particular compo=
nent."))
-
-(defun component-parent-pathname (component)
- (aif (component-parent component)
- (component-pathname it)
- *default-pathname-defaults*))
-
-(defgeneric component-relative-pathname (component)
- (:documentation "Extracts the relative pathname applicable for a particu=
lar component."))
-
-(defmethod component-relative-pathname ((component module))
- (or (slot-value component 'relative-pathname)
- (make-pathname
- :directory `(:relative ,(component-name component))
- :host (pathname-host (component-parent-pathname component)))))
-
-(defmethod component-pathname ((component component))
- (let ((*default-pathname-defaults* (component-parent-pathname component)=
))
- (merge-pathnames (component-relative-pathname component))))
-
-(defgeneric component-property (component property))
-
-(defmethod component-property ((c component) property)
- (cdr (assoc property (slot-value c 'properties) :test #'equal)))
-
-(defgeneric (setf component-property) (new-value component property))
-
-(defmethod (setf component-property) (new-value (c component) property)
- (let ((a (assoc property (slot-value c 'properties) :test #'equal)))
- (if a
- (setf (cdr a) new-value)
- (setf (slot-value c 'properties)
- (acons property new-value (slot-value c 'properties))))))
-
-(defclass system (module)
- ((description :accessor system-description :initarg :description)
- (long-description
- :accessor system-long-description :initarg :long-description)
- (author :accessor system-author :initarg :author)
- (maintainer :accessor system-maintainer :initarg :maintainer)
- (licence :accessor system-licence :initarg :licence
- :accessor system-license :initarg :license)))
-
-;;; version-satisfies
-
-;;; with apologies to christophe rhodes ...
-(defun split (string &optional max (ws '(#\Space #\Tab)))
- (flet ((is-ws (char) (find char ws)))
- (nreverse
- (let ((list nil) (start 0) (words 0) end)
- (loop
- (when (and max (>=3D words (1- max)))
- (return (cons (subseq string start) list)))
- (setf end (position-if #'is-ws string :start start))
- (push (subseq string start end) list)
- (incf words)
- (unless end (return list))
- (setf start (1+ end)))))))
-
-(defgeneric version-satisfies (component version))
-
-(defmethod version-satisfies ((c component) version)
- (unless (and version (slot-boundp c 'version))
- (return-from version-satisfies t))
- (let ((x (mapcar #'parse-integer
- (split (component-version c) nil '(#\.))))
- (y (mapcar #'parse-integer
- (split version nil '(#\.)))))
- (labels ((bigger (x y)
- (cond ((not y) t)
- ((not x) nil)
- ((> (car x) (car y)) t)
- ((=3D (car x) (car y))
- (bigger (cdr x) (cdr y))))))
- (and (=3D (car x) (car y))
- (or (not (cdr y)) (bigger (cdr x) (cdr y)))))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; finding systems
-
-(defvar *defined-systems* (make-hash-table :test 'equal))
-(defun coerce-name (name)
- (typecase name
- (component (component-name name))
- (symbol (string-downcase (symbol-name name)))
- (string name)
- (t (sysdef-error "~@<invalid component designator ~A~@:>" name))))
-
-;;; for the sake of keeping things reasonably neat, we adopt a
-;;; convention that functions in this list are prefixed SYSDEF-
-
-(defvar *system-definition-search-functions*
- '(sysdef-central-registry-search))
-
-(defun system-definition-pathname (system)
- (let ((system-name (coerce-name system)))
- (or
- (some (lambda (x) (funcall x system-name))
- *system-definition-search-functions*)
- (let ((system-pair (system-registered-p system-name)))
- (and system-pair
- (system-source-file (cdr system-pair)))))))
-
-(defvar *central-registry*
- '(*default-pathname-defaults*
- #+nil "/home/dan/src/sourceforge/cclan/asdf/systems/"
- #+nil "telent:asdf;systems;"))
-
-(defun sysdef-central-registry-search (system)
- (let ((name (coerce-name system)))
- (block nil
- (dolist (dir *central-registry*)
- (let* ((defaults (eval dir))
- (file (and defaults
- (make-pathname
- :defaults defaults :version :newest
- :name name :type "asd" :case :local))))
- (if (and file (probe-file file))
- (return file)))))))
-
-(defun make-temporary-package ()
- (flet ((try (counter)
- (ignore-errors
- (make-package (format nil "ASDF~D" counter)
- :use '(:cl :asdf)))))
- (do* ((counter 0 (+ counter 1))
- (package (try counter) (try counter)))
- (package package))))
-
-(defun find-system (name &optional (error-p t))
- (let* ((name (coerce-name name))
- (in-memory (system-registered-p name))
- (on-disk (system-definition-pathname name)))
- (when (and on-disk
- (or (not in-memory)
- (< (car in-memory) (file-write-date on-disk))))
- (let ((package (make-temporary-package)))
- (unwind-protect
- (let ((*package* package))
- (format
- *verbose-out*
- "~&~@<; ~@;loading system definition from ~A into ~A~@:>~%"
- ;; FIXME: This wants to be (ENOUGH-NAMESTRING
- ;; ON-DISK), but CMUCL barfs on that.
- on-disk
- *package*)
- (load on-disk))
- (delete-package package))))
- (let ((in-memory (system-registered-p name)))
- (if in-memory
- (progn (if on-disk (setf (car in-memory) (file-write-date on-dis=
k)))
- (cdr in-memory))
- (if error-p (error 'missing-component :requires name))))))
-
-(defun register-system (name system)
- (format *verbose-out* "~&~@<; ~@;registering ~A as ~A~@:>~%" system name)
- (setf (gethash (coerce-name name) *defined-systems*)
- (cons (get-universal-time) system)))
-
-(defun system-registered-p (name)
- (gethash (coerce-name name) *defined-systems*))
-
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; finding components
-
-(defgeneric find-component (module name &optional version)
- (:documentation "Finds the component with name NAME present in the
-MODULE module; if MODULE is nil, then the component is assumed to be a
-system."))
-
-(defmethod find-component ((module module) name &optional version)
- (if (slot-boundp module 'components)
- (let ((m (find name (module-components module)
- :test #'equal :key #'component-name)))
- (if (and m (version-satisfies m version)) m))))
-
-
-;;; a component with no parent is a system
-(defmethod find-component ((module (eql nil)) name &optional version)
- (let ((m (find-system name nil)))
- (if (and m (version-satisfies m version)) m)))
-
-;;; component subclasses
-
-(defclass source-file (component) ())
-
-(defclass cl-source-file (source-file) ())
-(defclass c-source-file (source-file) ())
-(defclass java-source-file (source-file) ())
-(defclass static-file (source-file) ())
-(defclass doc-file (static-file) ())
-(defclass html-file (doc-file) ())
-
-(defgeneric source-file-type (component system))
-(defmethod source-file-type ((c cl-source-file) (s module)) "lisp")
-(defmethod source-file-type ((c c-source-file) (s module)) "c")
-(defmethod source-file-type ((c java-source-file) (s module)) "java")
-(defmethod source-file-type ((c html-file) (s module)) "html")
-(defmethod source-file-type ((c static-file) (s module)) nil)
-
-(defmethod component-relative-pathname ((component source-file))
- (let ((relative-pathname (slot-value component 'relative-pathname)))
- (if relative-pathname
- (merge-pathnames
- relative-pathname
- (make-pathname
- :type (source-file-type component (component-system component))))
- (let* ((*default-pathname-defaults*
- (component-parent-pathname component))
- (name-type
- (make-pathname
- :name (component-name component)
- :type (source-file-type component
- (component-system component)))))
- name-type))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; operations
-
-;;; one of these is instantiated whenever (operate ) is called
-
-(defclass operation ()
- ((forced :initform nil :initarg :force :accessor operation-forced)
- (original-initargs :initform nil :initarg :original-initargs
- :accessor operation-original-initargs)
- (visited-nodes :initform nil :accessor operation-visited-nodes)
- (visiting-nodes :initform nil :accessor operation-visiting-nodes)
- (parent :initform nil :initarg :parent :accessor operation-parent)))
-
-(defmethod print-object ((o operation) stream)
- (print-unreadable-object (o stream :type t :identity t)
- (ignore-errors
- (prin1 (operation-original-initargs o) stream))))
-
-(defmethod shared-initialize :after ((operation operation) slot-names
- &key force
- &allow-other-keys)
- (declare (ignore slot-names force))
- ;; empty method to disable initarg validity checking
- )
=
(define-method-combination standard-asdf-method-combination ()
((around-asdf (around))
@@ -539,6 +191,14 @@
(,@(rest around-asdf) (make-method ,standard-form)=
))
standard-form))))
=
+(setf (documentation 'standard-asdf-method-combination =
+ 'method-combination)
+ "This method combination is based on the standard method combination,
+but defines a new method-qualifier, `asdf:around`. `asdf:around`
+methods will be run *around* any `:around` methods, so that the core
+protocol may employ around methods and those around methods will not
+be overridden by around methods added by a system developer.")
+
(defgeneric perform (operation component)
(:method-combination standard-asdf-method-combination))
(defgeneric operation-done-p (operation component)
@@ -550,13 +210,578 @@
(defgeneric input-files (operation component)
(:method-combination standard-asdf-method-combination))
=
-(defun node-for (o c)
- (cons (class-name (class-of o)) c))
+(defgeneric system-source-file (system)
+ (:documentation "Return the source file in which system is defined."))
+
+(defgeneric component-system (component)
+ (:documentation "Find the top-level system containing COMPONENT"))
+
+(defgeneric component-pathname (component)
+ (:documentation "Extracts the pathname applicable for a particular compo=
nent."))
+
+(defgeneric component-relative-pathname (component)
+ (:documentation "Extracts the relative pathname applicable for a particu=
lar component."))
+
+(defgeneric component-property (component property))
+
+(defgeneric (setf component-property) (new-value component property))
+
+(defgeneric version-satisfies (component version))
+
+(defgeneric find-component (module name &optional version)
+ (:documentation "Finds the component with name NAME present in the
+MODULE module; if MODULE is nil, then the component is assumed to be a
+system."))
+
+(defgeneric source-file-type (component system))
=
(defgeneric operation-ancestor (operation)
(:documentation
"Recursively chase the operation's parent pointer until we get to
the head of the tree"))
+
+(defgeneric component-visited-p (operation component))
+
+(defgeneric visit-component (operation component data))
+
+(defgeneric (setf visiting-component) (new-value operation component))
+
+(defgeneric component-visiting-p (operation component))
+
+(defgeneric component-depends-on (operation component)
+ (:documentation
+ "Returns a list of dependencies needed by the component to perform
+ the operation. A dependency has one of the following forms:
+
+ (<operation> <component>*), where <operation> is a class
+ designator and each <component> is a component
+ designator, which means that the component depends on
+ <operation> having been performed on each <component>; or
+
+ (FEATURE <feature>), which means that the component depends
+ on <feature>'s presence in *FEATURES*.
+
+ Methods specialized on subclasses of existing component types
+ should usually append the results of CALL-NEXT-METHOD to the
+ list."))
+
+(defgeneric component-self-dependencies (operation component))
+
+(defgeneric traverse (operation component)
+ (:documentation =
+"Generate and return a plan for performing `operation` on `component`.
+
+The plan returned is a list of dotted-pairs. Each pair is the `cons`
+of ASDF operation object and a `component` object. The pairs will be =
+processed in order by `operate`."))
+
+(defgeneric output-files-using-mappings (source possible-paths path-mappin=
gs)
+ (:documentation =
+"Use the variable \\*source-to-target-mappings\\* to find
+an output path for the source. The algorithm transforms each
+entry in possible-paths as follows: If there is a mapping
+whose source starts with the path of possible-path, then
+replace possible-path with a pathname that starts with the
+target of the mapping and continues with the rest of
+possible-path. If no such mapping is found, then use the
+default mapping.
+
+If \\*centralize-lisp-binaries\\* is false, then the default
+mapping is to place the output in a subdirectory of the
+source. The subdirectory is named using the Lisp
+implementation \(see
+implementation-specific-directory-name\). If
+\\*centralize-lisp-binaries\\* is true, then the default
+mapping is to place the output in subdirectories of
+\\*default-toplevel-directory\\* where the subdirectory
+structure will mirror that of the source."))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; utility stuff
+
+(defmacro aif (test then &optional else)
+ `(let ((it ,test)) (if it ,then ,else)))
+
+(defun pathname-sans-name+type (pathname)
+ "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME,
+and NIL NAME and TYPE components"
+ (make-pathname :name nil :type nil :defaults pathname))
+
+(define-modify-macro appendf (&rest args)
+ append "Append onto list")
+
+(defun asdf-message (format-string &rest format-args)
+ (declare (dynamic-extent format-args))
+ (apply #'format *verbose-out* format-string format-args))
+
+(defun split-path-string (s &optional force-directory)
+ (check-type s string)
+ (let* ((components (split s nil "/"))
+ (last-comp (car (last components))))
+ (multiple-value-bind (relative components)
+ (if (equal (first components) "")
+ (values :absolute (cdr components))
+ (values :relative components))
+ (cond
+ ((equal last-comp "")
+ (values relative (butlast components) nil))
+ (force-directory
+ (values relative components nil))
+ (t
+ (values relative (butlast components) last-comp))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; classes, condiitons
+
+(define-condition system-definition-error (error) ()
+ ;; [this use of :report should be redundant, but unfortunately it's not.
+ ;; cmucl's lisp::output-instance prefers the kernel:slot-class-print-fun=
ction
+ ;; over print-object; this is always conditions::%print-condition for
+ ;; condition objects, which in turn does inheritance of :report options =
at
+ ;; run-time. fortunately, inheritance means we only need this kludge he=
re in
+ ;; order to fix all conditions that build on it. -- rgr, 28-Jul-02.]
+ #+cmu (:report print-object))
+
+(define-condition formatted-system-definition-error (system-definition-err=
or)
+ ((format-control :initarg :format-control :reader format-control)
+ (format-arguments :initarg :format-arguments :reader format-arguments))
+ (:report (lambda (c s)
+ (apply #'format s (format-control c) (format-arguments c)))))
+
+(define-condition circular-dependency (system-definition-error)
+ ((components :initarg :components :reader circular-dependency-components=
)))
+
+(define-condition duplicate-names (system-definition-error)
+ ((name :initarg :name :reader duplicate-names-name)))
+
+(define-condition missing-component (system-definition-error)
+ ((requires :initform "(unnamed)" :reader missing-requires :initarg :requ=
ires)
+ (parent :initform nil :reader missing-parent :initarg :parent)))
+
+(define-condition missing-component-of-version (missing-component)
+ ((version :initform nil :reader missing-version :initarg :version)))
+
+(define-condition missing-dependency (missing-component)
+ ((required-by :initarg :required-by :reader missing-required-by)))
+
+(define-condition missing-dependency-of-version (missing-dependency
+ missing-component-of-version)
+ ())
+
+(define-condition operation-error (error)
+ ((component :reader error-component :initarg :component)
+ (operation :reader error-operation :initarg :operation))
+ (:report (lambda (c s)
+ (format s "~@<erred while invoking ~A on ~A~@:>"
+ (error-operation c) (error-component c)))))
+(define-condition compile-error (operation-error) ())
+(define-condition compile-failed (compile-error) ())
+(define-condition compile-warned (compile-error) ())
+
+(defclass component ()
+ ((name :accessor component-name :initarg :name :documentation
+ "Component name: designator for a string composed of portable pat=
hname characters")
+ (version :accessor component-version :initarg :version)
+ (in-order-to :initform nil :initarg :in-order-to)
+ ;; XXX crap name
+ (do-first :initform nil :initarg :do-first)
+ ;; methods defined using the "inline" style inside a defsystem form:
+ ;; need to store them somewhere so we can delete them when the system
+ ;; is re-evaluated
+ (inline-methods :accessor component-inline-methods :initform nil)
+ (parent :initarg :parent :initform nil :reader component-parent)
+ ;; no direct accessor for pathname, we do this as a method to allow
+ ;; it to default in funky ways if not supplied
+ (relative-pathname :initarg :pathname)
+ (operation-times :initform (make-hash-table )
+ :accessor component-operation-times)
+ ;; XXX we should provide some atomic interface for updating the
+ ;; component properties
+ (properties :accessor component-properties :initarg :properties
+ :initform nil)))
+
+;;;; methods: conditions
+
+(defmethod print-object ((c missing-dependency) s)
+ (format s "~@<~A, required by ~A~@:>"
+ (call-next-method c nil) (missing-required-by c)))
+
+(defun sysdef-error (format &rest arguments)
+ (error 'formatted-system-definition-error :format-control =
+ format :format-arguments arguments))
+
+;;;; methods: components
+
+(defmethod print-object ((c missing-component) s)
+ (format s "~@<component ~S not found~
+ ~@[ in ~A~]~@:>"
+ (missing-requires c)
+ (when (missing-parent c)
+ (component-name (missing-parent c)))))
+
+(defmethod print-object ((c missing-component-of-version) s)
+ (format s "~@<component ~S does not match version ~A~
+ ~@[ in ~A~]~@:>"
+ (missing-requires c)
+ (missing-version c)
+ (when (missing-parent c)
+ (component-name (missing-parent c)))))
+
+(defmethod component-system ((component component))
+ (aif (component-parent component)
+ (component-system it)
+ component))
+
+(defmethod print-object ((c component) stream)
+ (print-unreadable-object (c stream :type t :identity t)
+ (ignore-errors
+ (prin1 (component-name c) stream))))
+
+(defclass module (component)
+ ((components :initform nil :accessor module-components :initarg :compone=
nts)
+ ;; what to do if we can't satisfy a dependency of one of this module's
+ ;; components. This allows a limited form of conditional processing
+ (if-component-dep-fails :initform :fail
+ :accessor module-if-component-dep-fails
+ :initarg :if-component-dep-fails)
+ (default-component-class :accessor module-default-component-class
+ :initform 'cl-source-file :initarg :default-component-class)))
+
+(defun component-parent-pathname (component)
+ (aif (component-parent component)
+ (component-pathname it)
+ *default-pathname-defaults*))
+
+(defmethod component-relative-pathname ((component module))
+ (or (slot-value component 'relative-pathname)
+ (multiple-value-bind (relative path)
+ (split-path-string (component-name component) t)
+ (make-pathname
+ :directory `(,relative , at path)
+ :host (pathname-host (component-parent-pathname component))))))
+
+(defmethod component-pathname ((component component))
+ (let ((*default-pathname-defaults* (component-parent-pathname component)=
))
+ (merge-pathnames (component-relative-pathname component))))
+
+(defmethod component-property ((c component) property)
+ (cdr (assoc property (slot-value c 'properties) :test #'equal)))
+
+(defmethod (setf component-property) (new-value (c component) property)
+ (let ((a (assoc property (slot-value c 'properties) :test #'equal)))
+ (if a
+ (setf (cdr a) new-value)
+ (setf (slot-value c 'properties)
+ (acons property new-value (slot-value c 'properties))))))
+
+(defclass system (module)
+ ((description :accessor system-description :initarg :description)
+ (long-description
+ :accessor system-long-description :initarg :long-description)
+ (author :accessor system-author :initarg :author)
+ (maintainer :accessor system-maintainer :initarg :maintainer)
+ (licence :accessor system-licence :initarg :licence
+ :accessor system-license :initarg :license)
+ (source-file :reader system-source-file :initarg :source-file
+ :writer %set-system-source-file)))
+
+;;; version-satisfies
+
+;;; with apologies to christophe rhodes ...
+(defun split (string &optional max (ws '(#\Space #\Tab)))
+ (flet ((is-ws (char) (find char ws)))
+ (nreverse
+ (let ((list nil) (start 0) (words 0) end)
+ (loop
+ (when (and max (>=3D words (1- max)))
+ (return (cons (subseq string start) list)))
+ (setf end (position-if #'is-ws string :start start))
+ (push (subseq string start end) list)
+ (incf words)
+ (unless end (return list))
+ (setf start (1+ end)))))))
+
+(defmethod version-satisfies ((c component) version)
+ (unless (and version (slot-boundp c 'version))
+ (return-from version-satisfies t))
+ (let ((x (mapcar #'parse-integer
+ (split (component-version c) nil '(#\.))))
+ (y (mapcar #'parse-integer
+ (split version nil '(#\.)))))
+ (labels ((bigger (x y)
+ (cond ((not y) t)
+ ((not x) nil)
+ ((> (car x) (car y)) t)
+ ((=3D (car x) (car y))
+ (bigger (cdr x) (cdr y))))))
+ (and (=3D (car x) (car y))
+ (or (not (cdr y)) (bigger (cdr x) (cdr y)))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; finding systems
+
+(defun make-defined-systems-table ()
+ (make-hash-table :test 'equal))
+
+(defvar *defined-systems* (make-defined-systems-table))
+
+(defun coerce-name (name)
+ (typecase name
+ (component (component-name name))
+ (symbol (string-downcase (symbol-name name)))
+ (string name)
+ (t (sysdef-error "~@<invalid component designator ~A~@:>" name))))
+
+(defun system-registered-p (name)
+ (gethash (coerce-name name) *defined-systems*))
+
+(defun map-systems (fn)
+ "Apply `fn` to each defined system.
+
+`fn` should be a function of one argument. It will be
+called with an object of type asdf:system."
+ (maphash (lambda (_ datum)
+ (declare (ignore _))
+ (destructuring-bind (_ . def) datum
+ (declare (ignore _))
+ (funcall fn def)))
+ *defined-systems*))
+
+;;; for the sake of keeping things reasonably neat, we adopt a
+;;; convention that functions in this list are prefixed SYSDEF-
+
+(defvar *system-definition-search-functions*
+ '(sysdef-central-registry-search))
+
+(defun system-definition-pathname (system)
+ (let ((system-name (coerce-name system)))
+ (or
+ (some (lambda (x) (funcall x system-name))
+ *system-definition-search-functions*)
+ (let ((system-pair (system-registered-p system-name)))
+ (and system-pair
+ (system-source-file (cdr system-pair)))))))
+
+(defvar *central-registry*
+ `((directory-namestring *default-pathname-defaults*))
+"A list of 'system directory designators' ASDF uses to find systems.
+
+A 'system directory designator' is a pathname or a function =
+which evaluates to a pathname. For example:
+
+ (setf asdf:*central-registry*
+ (list '*default-pathname-defaults*
+ #p\"/home/me/cl/systems/\"
+ #p\"/usr/share/common-lisp/systems/\"))
+")
+
+(defun directory-pathname-p (pathname)
+ "Does `pathname` represent a directory?
+
+A directory-pathname is a pathname _without_ a filename. The three
+ways that the filename components can be missing are for it to be `nil`, =
+`:unspecific` or the empty string.
+
+Note that this does _not_ check to see that `pathname` points to an
+actually-existing directory."
+ (flet ((check-one (x)
+ (not (null (member x '(nil :unspecific "")
+ :test 'equal)))))
+ (and (check-one (pathname-name pathname))
+ (check-one (pathname-type pathname)))))
+
+#+(or)
+;;test
+;;?? move into testsuite sometime soon
+(every (lambda (p)
+ (directory-pathname-p p))
+ (list =
+ (make-pathname :name "." :type nil :directory '(:absolute "tmp"))
+ (make-pathname :name "." :type "" :directory '(:absolute "tmp"))
+ (make-pathname :name nil :type "" :directory '(:absolute "tmp"))
+ (make-pathname :name "" :directory '(:absolute "tmp"))
+ (make-pathname :type :unspecific :directory '(:absolute "tmp"))
+ (make-pathname :name :unspecific :directory '(:absolute "tmp"))
+ (make-pathname :name :unspecific :directory '(:absolute "tmp"))
+ (make-pathname :type "" :directory '(:absolute "tmp"))
+ ))
+
+(defun ensure-directory-pathname (pathname)
+ (if (directory-pathname-p pathname)
+ pathname
+ (make-pathname :defaults pathname
+ :directory (append
+ (pathname-directory pathname)
+ (list (file-namestring pathname)))
+ :name nil :type nil :version nil)))
+
+(defun sysdef-central-registry-search (system)
+ (let ((name (coerce-name system))
+ (to-remove nil)
+ (to-replace nil))
+ (block nil
+ (unwind-protect
+ (dolist (dir *central-registry*)
+ (let ((defaults (eval dir)))
+ (when defaults
+ (cond ((directory-pathname-p defaults)
+ (let ((file (and defaults
+ (make-pathname
+ :defaults defaults :version :newest
+ :name name :type "asd" :case :local)))
+ #+(and (or win32 windows) (not :clisp))
+ (shortcut (make-pathname
+ :defaults defaults :version :new=
est
+ :name name :type "asd.lnk" :case=
:local)))
+ (if (and file (probe-file file))
+ (return file))
+ #+(and (or win32 windows) (not :clisp))
+ (when (probe-file shortcut)
+ (let ((target (parse-windows-shortcut shortcut=
)))
+ (when target
+ (return (pathname target)))))))
+ (t
+ (restart-case =
+ (let* ((*print-circle* nil)
+ (message =
+ (format nil =
+ "~@<While searching for system `~a`: `~a` evaluated ~
+to `~a` which is not a directory.~@:>" =
+ system dir defaults)))
+ (error message))
+ (remove-entry-from-registry ()
+ :report "Remove entry from *central-registry* and continue"
+ (push dir to-remove))
+ (coerce-entry-to-directory ()
+ :report (lambda (s)
+ (format s "Coerce entry to ~a, replace ~a and continue."
+ (ensure-directory-pathname defaults) dir))
+ (push (cons dir (ensure-directory-pathname defaults)) to-replace)))=
)))))
+ ;; cleanup
+ (dolist (dir to-remove)
+ (setf *central-registry* (remove dir *central-registry*)))
+ (dolist (pair to-replace)
+ (let* ((current (car pair))
+ (new (cdr pair))
+ (position (position current *central-registry*)))
+ (setf *central-registry*
+ (append (subseq *central-registry* 0 position)
+ (list new)
+ (subseq *central-registry* (1+ position))))))))))
+
+(defun make-temporary-package ()
+ (flet ((try (counter)
+ (ignore-errors
+ (make-package (format nil "~a~D" 'asdf counter)
+ :use '(:cl :asdf)))))
+ (do* ((counter 0 (+ counter 1))
+ (package (try counter) (try counter)))
+ (package package))))
+
+(defun find-system (name &optional (error-p t))
+ (let* ((name (coerce-name name))
+ (in-memory (system-registered-p name))
+ (on-disk (system-definition-pathname name)))
+ (when (and on-disk
+ (or (not in-memory)
+ (< (car in-memory) (file-write-date on-disk))))
+ (let ((package (make-temporary-package)))
+ (unwind-protect
+ (let ((*package* package))
+ (asdf-message
+ "~&~@<; ~@;loading system definition from ~A into ~A~@:>~%"
+ ;; FIXME: This wants to be (ENOUGH-NAMESTRING
+ ;; ON-DISK), but CMUCL barfs on that.
+ on-disk
+ *package*)
+ (load on-disk))
+ (delete-package package))))
+ (let ((in-memory (system-registered-p name)))
+ (if in-memory
+ (progn (if on-disk (setf (car in-memory) (file-write-date on-dis=
k)))
+ (cdr in-memory))
+ (if error-p (error 'missing-component :requires name))))))
+
+(defun register-system (name system)
+ (asdf-message "~&~@<; ~@;registering ~A as ~A~@:>~%" system name)
+ (setf (gethash (coerce-name name) *defined-systems*)
+ (cons (get-universal-time) system)))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; finding components
+
+(defmethod find-component ((module module) name &optional version)
+ (if (slot-boundp module 'components)
+ (let ((m (find name (module-components module)
+ :test #'equal :key #'component-name)))
+ (if (and m (version-satisfies m version)) m))))
+
+
+;;; a component with no parent is a system
+(defmethod find-component ((module (eql nil)) name &optional version)
+ (let ((m (find-system name nil)))
+ (if (and m (version-satisfies m version)) m)))
+
+;;; component subclasses
+
+(defclass source-file (component) ())
+
+(defclass cl-source-file (source-file) ())
+(defclass c-source-file (source-file) ())
+(defclass java-source-file (source-file) ())
+(defclass static-file (source-file) ())
+(defclass doc-file (static-file) ())
+(defclass html-file (doc-file) ())
+
+(defmethod source-file-type ((c cl-source-file) (s module)) "lisp")
+(defmethod source-file-type ((c c-source-file) (s module)) "c")
+(defmethod source-file-type ((c java-source-file) (s module)) "java")
+(defmethod source-file-type ((c html-file) (s module)) "html")
+(defmethod source-file-type ((c static-file) (s module)) nil)
+
+(defmethod component-relative-pathname ((component source-file))
+ (multiple-value-bind (relative path name)
+ (split-path-string (component-name component))
+ (let ((type (source-file-type component (component-system component)))
+ (relative-pathname (slot-value component 'relative-pathname))
+ (*default-pathname-defaults* (component-parent-pathname componen=
t)))
+ (if relative-pathname
+ (merge-pathnames
+ relative-pathname
+ (if type
+ (make-pathname :name name :type type)
+ name))
+ (make-pathname :directory `(,relative , at path) :name name :type typ=
e)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; operations
+
+;;; one of these is instantiated whenever (operate ) is called
+
+(defclass operation ()
+ ((forced :initform nil :initarg :force :accessor operation-forced)
+ (original-initargs :initform nil :initarg :original-initargs
+ :accessor operation-original-initargs)
+ (visited-nodes :initform nil :accessor operation-visited-nodes)
+ (visiting-nodes :initform nil :accessor operation-visiting-nodes)
+ (parent :initform nil :initarg :parent :accessor operation-parent)))
+
+(defmethod print-object ((o operation) stream)
+ (print-unreadable-object (o stream :type t :identity t)
+ (ignore-errors
+ (prin1 (operation-original-initargs o) stream))))
+
+(defmethod shared-initialize :after ((operation operation) slot-names
+ &key force
+ &allow-other-keys)
+ (declare (ignore slot-names force))
+ ;; empty method to disable initarg validity checking
+ )
+
+(defun node-for (o c)
+ (cons (class-name (class-of o)) c))
=
(defmethod operation-ancestor ((operation operation))
(aif (operation-parent operation)
@@ -584,10 +809,6 @@
:parent o :original-initargs args args)))))
=
=
-(defgeneric component-visited-p (operation component))
-
-(defgeneric visit-component (operation component data))
-
(defmethod visit-component ((o operation) (c component) data)
(unless (component-visited-p o c)
(push (cons (node-for o c) data)
@@ -597,8 +818,6 @@
(assoc (node-for o c)
(operation-visited-nodes (operation-ancestor o))
:test 'equal))
-
-(defgeneric (setf visiting-component) (new-value operation component))
=
(defmethod (setf visiting-component) (new-value operation component)
;; MCL complains about unused lexical variables
@@ -612,38 +831,17 @@
(setf (operation-visiting-nodes a)
(remove node (operation-visiting-nodes a) :test 'equal)))))
=
-(defgeneric component-visiting-p (operation component))
-
(defmethod component-visiting-p ((o operation) (c component))
(let ((node (node-for o c)))
(member node (operation-visiting-nodes (operation-ancestor o))
:test 'equal)))
=
-(defgeneric component-depends-on (operation component)
- (:documentation
- "Returns a list of dependencies needed by the component to perform
- the operation. A dependency has one of the following forms:
-
- (<operation> <component>*), where <operation> is a class
- designator and each <component> is a component
- designator, which means that the component depends on
- <operation> having been performed on each <component>; or
-
- (FEATURE <feature>), which means that the component depends
- on <feature>'s presence in *FEATURES*.
-
- Methods specialized on subclasses of existing component types
- should usually append the results of CALL-NEXT-METHOD to the
- list."))
-
(defmethod component-depends-on ((op-spec symbol) (c component))
(component-depends-on (make-instance op-spec) c))
=
(defmethod component-depends-on ((o operation) (c component))
(cdr (assoc (class-name (class-of o))
(slot-value c 'in-order-to))))
-
-(defgeneric component-self-dependencies (operation component))
=
(defmethod component-self-dependencies ((o operation) (c component))
(let ((all-deps (component-depends-on o c)))
@@ -705,13 +903,11 @@
;;; So you look at this code and think "why isn't it a bunch of
;;; methods". And the answer is, because standard method combination
;;; runs :before methods most->least-specific, which is back to front
-;;; for our purposes. And CLISP doesn't have non-standard method
-;;; combinations, so let's keep it simple and aspire to portability
-
-(defgeneric traverse (operation component))
+;;; for our purposes. =
+
(defmethod traverse ((operation operation) (c component))
(let ((forced nil))
- (labels ((do-one-dep (required-op required-c required-v)
+ (labels ((%do-one-dep (required-op required-c required-v)
(let* ((dep-c (or (find-component
(component-parent c)
;; XXX tacky. really we should build the
@@ -728,6 +924,26 @@
:requires required-c))))
(op (make-sub-operation c operation dep-c required-o=
p)))
(traverse op dep-c)))
+ (do-one-dep (required-op required-c required-v)
+ (loop
+ (restart-case
+ (return (%do-one-dep required-op required-c required-v))
+ (retry ()
+ :report (lambda (s)
+ (format s "~@<Retry loading component ~S.~@:>"
+ required-c))
+ :test
+ (lambda (c)
+#|
+ (print (list :c1 c (typep c 'missing-dependency)))
+ (when (typep c 'missing-dependency)
+ (print (list :c2 (missing-requires c) required-c
+ (equalp (missing-requires c)
+ required-c))))
+|#
+ (and (typep c 'missing-dependency)
+ (equalp (missing-requires c)
+ required-c)))))))
(do-dep (op dep)
(cond ((eq op 'feature)
(or (member (car dep) *features*)
@@ -737,11 +953,22 @@
(t
(dolist (d dep)
(cond ((consp d)
- (assert (string-equal
- (symbol-name (first d))
- "VERSION"))
- (appendf forced
- (do-one-dep op (second d) (third d=
))))
+ (cond ((string-equal
+ (symbol-name (first d))
+ "VERSION")
+ (appendf
+ forced
+ (do-one-dep op (second d) (third d))))
+ ((and (string-equal
+ (symbol-name (first d))
+ "FEATURE")
+ (find (second d) *features*
+ :test 'string-equal))
+ (appendf
+ forced
+ (do-one-dep op (second d) (third d))))
+ (t
+ (error "Bad dependency ~a. Dependencies must be (:version <vers=
ion>), (:feature <feature>), or a name" d))))
(t
(appendf forced (do-one-dep op d nil)))))))=
))
(aif (component-visited-p operation c)
@@ -753,9 +980,9 @@
(setf (visiting-component operation c) t)
(unwind-protect
(progn
- (loop for (required-op . deps) in =
+ (loop for (required-op . deps) in
(component-depends-on operation c)
- do (do-dep required-op deps))
+ do (do-dep required-op deps))
;; constituent bits
(let ((module-ops
(when (typep c 'module)
@@ -766,7 +993,7 @@
do (handler-case
(appendf forced (traverse operation kid ))
(missing-dependency (condition)
- (if (eq (module-if-component-dep-fails c) =
+ (if (eq (module-if-component-dep-fails c)
:fail)
(error condition))
(setf error condition))
@@ -781,7 +1008,7 @@
;; now the thing itself
(when (or forced module-ops
(not (operation-done-p operation c))
- (let ((f (operation-forced =
+ (let ((f (operation-forced
(operation-ancestor operation))))
(and f (or (not (consp f))
(member (component-name
@@ -810,7 +1037,7 @@
nil)
=
(defmethod explain ((operation operation) (component component))
- (format *verbose-out* "~&;;; ~A on ~A~%" operation component))
+ (asdf-message "~&;;; ~A on ~A~%" operation component))
=
;;; compile-op
=
@@ -889,7 +1116,7 @@
(setf state :recompiled)
(perform (make-instance 'asdf:compile-op) c))
(t
- (with-simple-restart =
+ (with-simple-restart
(try-recompiling "Recompile ~a and try loading it again"
(component-name c))
(setf state :failed-load)
@@ -909,7 +1136,7 @@
(setf state :recompiled)
(perform (make-instance 'asdf:compile-op) c))
(t
- (with-simple-restart =
+ (with-simple-restart
(try-recompiling "Try recompiling ~a"
(component-name c))
(setf state :failed-compile)
@@ -970,26 +1197,19 @@
"Testing a system is _never_ done."
nil)
=
+(defmethod component-depends-on :around ((o test-op) (c system))
+ (cons `(load-op ,(component-name c)) (call-next-method)))
+
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; invoking operations
=
-(defvar *operate-docstring*
- "Operate does three things:
-
-1. It creates an instance of `operation-class` using any keyword parameters
-as initargs.
-2. It finds the asdf-system specified by `system` (possibly loading
-it from disk).
-3. It then calls `traverse` with the operation and system as arguments
-
-The traverse operation is wrapped in `with-compilation-unit` and error
-handling code. If a `version` argument is supplied, then operate also
-ensures that the system found satisfies it using the `version-satisfies`
-method.")
-
-(defun operate (operation-class system &rest args &key (verbose t) version
+(defun operate (operation-class system &rest args &key (verbose t) version=
force
&allow-other-keys)
- (let* ((op (apply #'make-instance operation-class
+ (declare (ignore force))
+ (let* ((*package* *package*)
+ (*readtable* *readtable*)
+ (op (apply #'make-instance operation-class
:original-initargs args
args))
(*verbose-out* (if verbose *standard-output* (make-broadcast-stre=
am)))
@@ -1017,19 +1237,53 @@
(setf (gethash (type-of op)
(component-operation-times component=
))
(get-universal-time))
- (return)))))))))
-
-(setf (documentation 'operate 'function)
- *operate-docstring*)
-
-(defun oos (operation-class system &rest args &key force (verbose t) versi=
on)
+ (return)))))))
+ op))
+
+(defun oos (operation-class system &rest args &key force (verbose t) versi=
on
+ &allow-other-keys)
(declare (ignore force verbose version))
(apply #'operate operation-class system args))
=
-(setf (documentation 'oos 'function)
- (format nil
- "Short for _operate on system_ and an alias for the `operate=
` function. ~&~&~a"
- *operate-docstring*))
+(let ((operate-docstring
+ "Operate does three things:
+
+1. It creates an instance of `operation-class` using any keyword parameters
+as initargs.
+2. It finds the asdf-system specified by `system` (possibly loading
+it from disk).
+3. It then calls `traverse` with the operation and system as arguments
+
+The traverse operation is wrapped in `with-compilation-unit` and error
+handling code. If a `version` argument is supplied, then operate also
+ensures that the system found satisfies it using the `version-satisfies`
+method.
+
+Note that dependencies may cause the operation to invoke other
+operations on the system or its components: the new operations will be
+created with the same initargs as the original one.
+"))
+ (setf (documentation 'oos 'function)
+ (format nil
+ "Short for _operate on system_ and an alias for the [operate][] function=
. ~&~&~a"
+ operate-docstring))
+ (setf (documentation 'operate 'function)
+ operate-docstring))
+
+(defun load-system (system &rest args &key force (verbose t) version)
+ "Shorthand for `(operate 'asdf:load-op system)`. See [operate][] for det=
ails."
+ (declare (ignore force verbose version))
+ (apply #'operate 'load-op system args))
+
+(defun compile-system (system &rest args &key force (verbose t) version)
+ "Shorthand for `(operate 'asdf:compile-op system)`. See [operate][] for =
details."
+ (declare (ignore force verbose version))
+ (apply #'operate 'compile-op system args))
+
+(defun test-system (system &rest args &key force (verbose t) version)
+ "Shorthand for `(operate 'asdf:test-op system)`. See [operate][] for det=
ails."
+ (declare (ignore force verbose version))
+ (apply #'operate 'test-op system args))
=
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; syntax
@@ -1042,6 +1296,30 @@
(remove-keyword
key (cddr arglist))))))))
(aux key arglist)))
+
+(defun resolve-symlinks (path)
+ #-allegro (truename path)
+ #+allegro (excl:pathname-resolve-symbolic-links path)
+ )
+
+(defun determine-system-pathname (pathname pathname-supplied-p)
+ ;; called from the defsystem macro.
+ ;; the pathname of a system is either
+ ;; 1. the one supplied, =
+ ;; 2. derived from the *load-truename* (see below), or
+ ;; 3. taken from *default-pathname-defaults*
+ ;;
+ ;; if using *load-truename*, then we also deal with whether or not
+ ;; to resolve symbolic links. If not resolving symlinks, then we use
+ ;; *load-pathname* instead of *load-truename* since in some
+ ;; implementations, the latter has *already resolved it.
+ (or (and pathname-supplied-p pathname)
+ (when *load-truename*
+ (pathname-sans-name+type =
+ (if *resolve-symlinks*
+ (resolve-symlinks *load-truename*)
+ *load-pathname*)))
+ *default-pathname-defaults*))
=
(defmacro defsystem (name &body options)
(destructuring-bind (&key (pathname nil pathname-arg-p) (class 'system)
@@ -1056,26 +1334,19 @@
(cond ((and s (eq (type-of (cdr s)) ',class))
(setf (car s) (get-universal-time)))
(s
- #+clisp
- (sysdef-error "Cannot redefine the existing system ~A wi=
th a different class" s)
- #-clisp
(change-class (cdr s) ',class))
(t
(register-system (quote ,name)
- (make-instance ',class :name ',name)))))
- (parse-component-form nil (apply
- #'list
- :module (coerce-name ',name)
- :pathname
- ;; to avoid a note about unreachable c=
ode
- ,(if pathname-arg-p
- pathname
- `(or (when *load-truename*
- (pathname-sans-name+type
- (resolve-symlinks
- *load-truename*)))
- *default-pathname-defaults*))
- ',component-options))))))
+ (make-instance ',class :name ',name))))
+ (%set-system-source-file *load-truename* =
+ (cdr (system-registered-p ',name))))
+ (parse-component-form =
+ nil (apply
+ #'list
+ :module (coerce-name ',name)
+ :pathname
+ ,(determine-system-pathname pathname pathname-arg-p)
+ ',component-options))))))
=
=
(defun class-for-type (parent type)
@@ -1130,6 +1401,57 @@
=
(defvar *serial-depends-on*)
=
+(defun sysdef-error-component (msg type name value)
+ (sysdef-error (concatenate 'string msg
+ "~&The value specified for ~(~A~) ~A is ~W")
+ type name value))
+
+(defun check-component-input (type name weakly-depends-on =
+ depends-on components in-order-to)
+ "A partial test of the values of a component."
+ (unless (listp depends-on)
+ (sysdef-error-component ":depends-on must be a list."
+ type name depends-on))
+ (unless (listp weakly-depends-on)
+ (sysdef-error-component ":weakly-depends-on must be a list."
+ type name weakly-depends-on))
+ (unless (listp components)
+ (sysdef-error-component ":components must be NIL or a list of componen=
ts."
+ type name components))
+ (unless (and (listp in-order-to) (listp (car in-order-to)))
+ (sysdef-error-component ":in-order-to must be NIL or a list of compone=
nts."
+ type name in-order-to)))
+
+(defun %remove-component-inline-methods (component)
+ (loop for name in +asdf-methods+
+ do (map 'nil
+ ;; this is inefficient as most of the stored
+ ;; methods will not be for this particular gf n
+ ;; But this is hardly performance-critical
+ (lambda (m)
+ (remove-method (symbol-function name) m))
+ (component-inline-methods component)))
+ ;; clear methods, then add the new ones
+ (setf (component-inline-methods component) nil))
+
+(defun %define-component-inline-methods (ret rest)
+ (loop for name in +asdf-methods+ do
+ (let ((keyword (intern (symbol-name name) :keyword)))
+ (loop for data =3D rest then (cddr data)
+ for key =3D (first data)
+ for value =3D (second data)
+ while data
+ when (eq key keyword) do
+ (destructuring-bind (op qual (o c) &body body) value
+ (pushnew
+ (eval `(defmethod ,name ,qual ((,o ,op) (,c (eql ,ret)))
+ , at body))
+ (component-inline-methods ret)))))))
+
+(defun %refresh-component-inline-methods (component rest)
+ (%remove-component-inline-methods component)
+ (%define-component-inline-methods component rest))
+ =
(defun parse-component-form (parent options)
=
(destructuring-bind
@@ -1204,55 +1526,9 @@
(load-op (load-op , at depends-on))))
(slot-value ret 'do-first) `((compile-op (load-op , at depends-on=
))))
=
- (%remove-component-inline-methods ret rest)
+ (%refresh-component-inline-methods ret rest)
=
ret)))
-
-(defun %remove-component-inline-methods (ret rest)
- (loop for name in +asdf-methods+
- do (map 'nil
- ;; this is inefficient as most of the stored
- ;; methods will not be for this particular gf n
- ;; But this is hardly performance-critical
- (lambda (m)
- (remove-method (symbol-function name) m))
- (component-inline-methods ret)))
- ;; clear methods, then add the new ones
- (setf (component-inline-methods ret) nil)
- (loop for name in +asdf-methods+
- for v =3D (getf rest (intern (symbol-name name) :keyword))
- when v do
- (destructuring-bind (op qual (o c) &body body) v
- (pushnew
- (eval `(defmethod ,name ,qual ((,o ,op) (,c (eql ,ret)))
- , at body))
- (component-inline-methods ret)))))
-
-(defun check-component-input (type name weakly-depends-on depends-on compo=
nents in-order-to)
- "A partial test of the values of a component."
- (when weakly-depends-on (warn "We got one! XXXXX"))
- (unless (listp depends-on)
- (sysdef-error-component ":depends-on must be a list."
- type name depends-on))
- (unless (listp weakly-depends-on)
- (sysdef-error-component ":weakly-depends-on must be a list."
- type name weakly-depends-on))
- (unless (listp components)
- (sysdef-error-component ":components must be NIL or a list of componen=
ts."
- type name components))
- (unless (and (listp in-order-to) (listp (car in-order-to)))
- (sysdef-error-component ":in-order-to must be NIL or a list of compone=
nts."
- type name in-order-to)))
-
-(defun sysdef-error-component (msg type name value)
- (sysdef-error (concatenate 'string msg
- "~&The value specified for ~(~A~) ~A is ~W")
- type name value))
-
-(defun resolve-symlinks (path)
- #-allegro (truename path)
- #+allegro (excl:pathname-resolve-symbolic-links path)
- )
=
;;; optional extras
=
@@ -1261,18 +1537,18 @@
;;; is ambiguous, send a bug report
=
(defun run-shell-command (control-string &rest args)
- "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and
+ "Interpolate `args` into `control-string` as if by `format`, and
synchronously execute the result using a Bourne-compatible shell, with
-output to *VERBOSE-OUT*. Returns the shell's exit code."
+output to `*verbose-out*`. Returns the shell's exit code."
(let ((command (apply #'format nil control-string args)))
- (format *verbose-out* "; $ ~A~%" command)
+ (asdf-message "; $ ~A~%" command)
#+sbcl
(sb-ext:process-exit-code
- (sb-ext:run-program
- #+win32 "sh" #-win32 "/bin/sh"
- (list "-c" command)
- #+win32 #+win32 :search t
- :input nil :output *verbose-out*))
+ (apply #'sb-ext:run-program
+ #+win32 "sh" #-win32 "/bin/sh"
+ (list "-c" command)
+ :input nil :output *verbose-out*
+ #+win32 '(:search t) #-win32 nil))
=
#+(or cmu scl)
(ext:process-exit-code
@@ -1282,7 +1558,16 @@
:input nil :output *verbose-out*))
=
#+allegro
- (excl:run-shell-command command :input nil :output *verbose-out*)
+ ;; will this fail if command has embedded quotes - it seems to work
+ (multiple-value-bind (stdout stderr exit-code)
+ (excl.osi:command-output =
+ (format nil "~a -c \"~a\"" =
+ #+mswindows "sh" #-mswindows "/bin/sh" command)
+ :input nil :whole nil
+ #+mswindows :show-window #+mswindows :hide)
+ (format *verbose-out* "~{~&; ~a~%~}~%" stderr)
+ (format *verbose-out* "~{~&; ~a~%~}~%" stdout)
+ exit-code)
=
#+lispworks
(system:call-system-showing-output
@@ -1299,27 +1584,17 @@
(ccl:run-program "/bin/sh" (list "-c" command)
:input nil :output *verbose-out*
:wait t)))
+
#+ecl ;; courtesy of Juan Jose Garcia Ripoll
(si:system command)
+
#-(or openmcl clisp lispworks allegro scl cmu sbcl ecl)
(error "RUN-SHELL-PROGRAM not implemented for this Lisp")
))
=
-(defgeneric system-source-file (system)
- (:documentation "Return the source file in which system is defined."))
-
(defmethod system-source-file ((system-name t))
(system-source-file (find-system system-name)))
=
-(defmethod system-source-file ((system system))
- (let ((pn (and (slot-boundp system 'relative-pathname)
- (make-pathname
- :type "asd"
- :name (asdf:component-name system)
- :defaults (asdf:component-relative-pathname system)))))
- (when pn
- (probe-file pn))))
- =
(defun system-source-directory (system-name)
(make-pathname :name nil
:type nil
@@ -1335,6 +1610,322 @@
:type (or type (pathname-type pathname))
:directory directory)
(system-source-directory system))))
+
+;;; ----------------------------------------------------------------------=
-----
+;;; asdf-binary-locations
+;;;
+;;; this bit of code was stolen from Bjorn Lindberg and then it grew!
+;;; see http://www.cliki.net/asdf%20binary%20locations
+;;; and http://groups.google.com/group/comp.lang.lisp/msg/bd5ea9d2008ab9fd
+;;; ----------------------------------------------------------------------=
-----
+;;; Portions of this code were once from SWANK / SLIME
+
+(defparameter *centralize-lisp-binaries*
+ nil "
+If true, compiled lisp files without an explicit mapping (see
+\\*source-to-target-mappings\\*) will be placed in subdirectories of
+\\*default-toplevel-directory\\*. If false, then compiled lisp files
+without an explicitly mapping will be placed in subdirectories of
+their sources.")
+
+(defparameter *enable-asdf-binary-locations* nil
+ "
+If true, then compiled lisp files will be placed into a directory =
+computed from the Lisp version, Operating System and computer archetecture.
+See [implementation-specific-directory-name][] for details.")
+
+
+(defparameter *default-toplevel-directory*
+ (merge-pathnames
+ (make-pathname :directory '(:relative ".fasls"))
+ (truename (user-homedir-pathname)))
+ "If \\*centralize-lisp-binaries\\* is true, then compiled lisp files wit=
hout an explicit mapping \(see \\*source-to-target-mappings\\*\) will be pl=
aced in subdirectories of \\*default-toplevel-directory\\*.")
+
+(defparameter *include-per-user-information*
+ nil
+ "When \\*centralize-lisp-binaries\\* is true this variable controls whet=
her or not to customize the output directory based on the current user. It =
can be nil, t or a string. If it is nil \(the default\), then no additional=
information will be added to the output directory. If it is t, then the us=
er's name \(as taken from the return value of #'user-homedir-pathname\) wil=
l be included into the centralized path (just before the lisp-implementatio=
n directory). Finally, if \\*include-per-user-information\\* is a string, t=
hen this string will be included in the output-directory.")
+
+(defparameter *map-all-source-files*
+ nil
+ "If true, then all subclasses of source-file will have their output loca=
tions mapped by ASDF-Binary-Locations. If nil (the default), then only subc=
lasses of cl-source-file will be mapped.")
+
+(defvar *source-to-target-mappings* =
+ #-sbcl
+ nil
+ #+sbcl
+ (list (list (princ-to-string (sb-ext:posix-getenv "SBCL_HOME")) nil))
+ "The \\*source-to-target-mappings\\* variable specifies mappings from so=
urce to target. If the target is nil, then it means to not map the source t=
o anything. I.e., to leave it as is. This has the effect of turning off ASD=
F-Binary-Locations for the given source directory. Examples:
+
+ ;; compile everything in .../src and below into .../cmucl
+ '((\"/nfs/home/compbio/d95-bli/share/common-lisp/src/\" =
+ \"/nfs/home/compbio/d95-bli/lib/common-lisp/cmucl/\"))
+
+ ;; leave SBCL innards alone (SBCL specific)
+ (list (list (princ-to-string (sb-ext:posix-getenv \"SBCL_HOME\")) nil))
+")
+
+(defparameter *implementation-features*
+ '(:allegro :lispworks :sbcl :ccl :openmcl :cmu :clisp
+ :corman :cormanlisp :armedbear :gcl :ecl :scl))
+
+(defparameter *os-features*
+ '(:windows :mswindows :win32 :mingw32
+ :solaris :sunos
+ :macosx :darwin :apple
+ :freebsd :netbsd :openbsd :bsd
+ :linux :unix))
+
+(defparameter *architecture-features*
+ '(:amd64 (:x86-64 :x86_64 :x8664-target) :i686 :i586 :pentium3 =
+ :i486 (:i386 :pc386 :iapx386) (:x86 :x8632-target) :pentium4
+ :hppa64 :hppa :ppc64 :ppc32 :powerpc :ppc :sparc64 :sparc))
+
+;; note to gwking: this is in slime, system-check, and system-check-server=
too
+(defun lisp-version-string ()
+ #+cmu (substitute #\- #\/ =
+ (substitute #\_ #\Space =
+ (lisp-implementation-version)))
+ #+scl (lisp-implementation-version)
+ #+sbcl (lisp-implementation-version)
+ #+ecl (reduce (lambda (x str) (substitute #\_ str x))
+ '(#\Space #\: #\( #\)) =
+ :initial-value (lisp-implementation-version))
+ #+gcl (let ((s (lisp-implementation-version))) (subseq s 4))
+ #+openmcl (format nil "~d.~d~@[-~d~]"
+ ccl::*openmcl-major-version* =
+ ccl::*openmcl-minor-version*
+ #+ppc64-target 64 =
+ #-ppc64-target nil)
+ #+lispworks (format nil "~A~@[~A~]"
+ (lisp-implementation-version)
+ (when (member :lispworks-64bit *features*) "-64bit"))
+ #+allegro (format nil
+ "~A~A~A~A"
+ excl::*common-lisp-version-number*
+ ; ANSI vs MoDeRn
+ ;; thanks to Robert Goldman and Charley Cox for
+ ;; an improvement to my hack
+ (if (eq excl:*current-case-mode* =
+ :case-sensitive-lower) "M" "A")
+ ;; Note if not using International ACL
+ ;; see http://www.franz.com/support/documentation/8.1/doc/operator=
s/excl/ics-target-case.htm
+ (excl:ics-target-case
+ (:-ics "8")
+ (:+ics ""))
+ (if (member :64bit *features*) "-64bit" ""))
+ #+clisp (let ((s (lisp-implementation-version)))
+ (subseq s 0 (position #\space s)))
+ #+armedbear (lisp-implementation-version)
+ #+cormanlisp (lisp-implementation-version)
+ #+digitool (subseq (lisp-implementation-version) 8))
+
+
+(defparameter *implementation-specific-directory-name* nil)
+
+(defun implementation-specific-directory-name ()
+ "Return a name that can be used as a directory name that is
+unique to a Lisp implementation, Lisp implementation version,
+operating system, and hardware architecture."
+ (and *enable-asdf-binary-locations*
+ (list =
+ (or *implementation-specific-directory-name*
+ (setf *implementation-specific-directory-name*
+ (labels =
+ ((fp (thing)
+ (etypecase thing
+ (symbol
+ (let ((feature (find thing *features*)))
+ (when feature (return-from fp feature))))
+ ;; allows features to be lists of which the first
+ ;; member is the "main name", the rest being aliases
+ (cons
+ (dolist (subf thing)
+ (let ((feature (find subf *features*)))
+ (when feature (return-from fp (first thing))))))))
+ (first-of (features)
+ (loop for f in features
+ when (fp f) return it))
+ (maybe-warn (value fstring &rest args)
+ (cond (value)
+ (t (apply #'warn fstring args)
+ "unknown"))))
+ (let ((lisp (maybe-warn (first-of *implementation-features*)
+ "No implementation feature found in ~a." =
+ *implementation-features*))
+ (os (maybe-warn (first-of *os-features*)
+ "No os feature found in ~a." *os-features*))
+ (arch (maybe-warn (first-of *architecture-features*)
+ "No architecture feature found in ~a."
+ *architecture-features*))
+ (version (maybe-warn (lisp-version-string)
+ "Don't know how to get Lisp ~
+ implementation version.")))
+ (format nil "~(~@{~a~^-~}~)" lisp version os arch))))))))
+
+(defun pathname-prefix-p (prefix pathname)
+ (let ((prefix-ns (namestring prefix))
+ (pathname-ns (namestring pathname)))
+ (=3D (length prefix-ns)
+ (mismatch prefix-ns pathname-ns))))
+
+(defgeneric output-files-for-system-and-operation
+ (system operation component source possible-paths)
+ (:documentation "Returns the directory where the componets output files =
should be placed. This may depends on the system, the operation and the com=
ponent. The ASDF default input and outputs are provided in the source and p=
ossible-paths parameters."))
+
+(defun source-to-target-resolved-mappings ()
+ "Answer `*source-to-target-mappings*` with additional entries made
+by resolving sources that are symlinks.
+
+As ASDF sometimes resolves symlinks to compute source paths, we must
+follow that. For example, if SBCL is installed under a symlink, and
+SBCL_HOME is set through that symlink, the default rule above
+preventing SBCL contribs from being mapped elsewhere will not be
+applied by the plain `*source-to-target-mappings*`."
+ (loop for mapping in asdf:*source-to-target-mappings*
+ for (source target) =3D mapping
+ for true-source =3D (and source (resolve-symlinks source))
+ if (equal source true-source)
+ collect mapping
+ else append (list mapping (list true-source target))))
+
+(defmethod output-files-for-system-and-operation
+ ((system system) operation component source possible-paths)
+ (declare (ignore operation component))
+ (output-files-using-mappings
+ source possible-paths (source-to-target-resolved-mappings)))
+
+(defmethod output-files-using-mappings (source possible-paths path-mapping=
s)
+ (mapcar =
+ (lambda (path) =
+ (loop for (from to) in path-mappings =
+ when (pathname-prefix-p from source) =
+ do (return =
+ (if to
+ (merge-pathnames =
+ (make-pathname :type (pathname-type path)) =
+ (merge-pathnames (enough-namestring source from) =
+ to))
+ path))
+ =
+ finally
+ (return =
+ ;; Instead of just returning the path when we =
+ ;; don't find a mapping, we stick stuff into =
+ ;; the appropriate binary directory based on =
+ ;; the implementation
+ (if *centralize-lisp-binaries*
+ (merge-pathnames
+ (make-pathname
+ :type (pathname-type path)
+ :directory `(:relative
+ ,@(cond ((eq *include-per-user-information* t)
+ (cdr (pathname-directory
+ (user-homedir-pathname))))
+ ((not (null *include-per-user-information*))
+ (list *include-per-user-information*)))
+ ,@(implementation-specific-directory-name)
+ ,@(rest (pathname-directory path)))
+ :defaults path)
+ *default-toplevel-directory*)
+ (make-pathname =
+ :type (pathname-type path)
+ :directory (append
+ (pathname-directory path)
+ (implementation-specific-directory-name))
+ :defaults path))))) =
+ possible-paths))
+
+(defmethod output-files =
+ :around ((operation compile-op) (component source-file)) =
+ (if (or *map-all-source-files*
+ (typecase component =
+ (cl-source-file t)
+ (t nil)))
+ (let ((source (component-pathname component )) =
+ (paths (call-next-method))) =
+ (output-files-for-system-and-operation =
+ (component-system component) operation component source paths))
+ (call-next-method)))
+
+;;;; -----------------------------------------------------------------
+;;;; Windows shortcut support. Based on:
+;;;;
+;;;; Jesse Hager: The Windows Shortcut File Format.
+;;;; http://www.wotsit.org/list.asp?fc=3D13
+;;;; -----------------------------------------------------------------
+
+(defparameter *link-initial-dword* 76)
+(defparameter *link-guid* #(1 20 2 0 0 0 0 0 192 0 0 0 0 0 0 70))
+
+(defun read-null-terminated-string (s)
+ (with-output-to-string (out)
+ (loop
+ for code =3D (read-byte s)
+ until (zerop code)
+ do (write-char (code-char code) out))))
+
+(defun read-little-endian (s &optional (bytes 4))
+ (let ((result 0))
+ (loop
+ for i from 0 below bytes
+ do
+ (setf result (logior result (ash (read-byte s) (* 8 i)))))
+ result))
+
+(defun parse-windows-shortcut (pathname)
+ (with-open-file (s pathname :element-type '(unsigned-byte 8))
+ (handler-case
+ (when (and (=3D (read-little-endian s) *link-initial-dword*)
+ (let ((header (make-array (length *link-guid*))))
+ (read-sequence header s)
+ (equalp header *link-guid*)))
+ (let ((flags (read-little-endian s)))
+ (file-position s 76) ;skip rest of header
+ (when (logbitp 0 flags)
+ ;; skip shell item id list
+ (let ((length (read-little-endian s 2)))
+ (file-position s (+ length (file-position s)))))
+ (cond
+ ((logbitp 1 flags)
+ (parse-file-location-info s))
+ (t
+ (when (logbitp 2 flags)
+ ;; skip description string
+ (let ((length (read-little-endian s 2)))
+ (file-position s (+ length (file-position s)))))
+ (when (logbitp 3 flags)
+ ;; finally, our pathname
+ (let* ((length (read-little-endian s 2))
+ (buffer (make-array length)))
+ (read-sequence buffer s)
+ (map 'string #'code-char buffer)))))))
+ (end-of-file ()
+ nil))))
+
+(defun parse-file-location-info (s)
+ (let ((start (file-position s))
+ (total-length (read-little-endian s))
+ (end-of-header (read-little-endian s))
+ (fli-flags (read-little-endian s))
+ (local-volume-offset (read-little-endian s))
+ (local-offset (read-little-endian s))
+ (network-volume-offset (read-little-endian s))
+ (remaining-offset (read-little-endian s)))
+ (declare (ignore total-length end-of-header local-volume-offset))
+ (unless (zerop fli-flags)
+ (cond
+ ((logbitp 0 fli-flags)
+ (file-position s (+ start local-offset)))
+ ((logbitp 1 fli-flags)
+ (file-position s (+ start
+ network-volume-offset
+ #x14))))
+ (concatenate 'string
+ (read-null-terminated-string s)
+ (progn
+ (file-position s (+ start remaining-offset))
+ (read-null-terminated-string s))))))
+
=
(pushnew :asdf *features*)
=
@@ -1381,4 +1972,23 @@
(pushnew 'module-provide-asdf sb-ext:*module-provider-functions*)
(pushnew 'contrib-sysdef-search *system-definition-search-functions*))
=
+(if *asdf-revision*
+ (asdf-message ";; ASDF, revision ~a" *asdf-revision*)
+ (asdf-message ";; ASDF, revision unknown; possibly a development versi=
on"))
+
(provide 'asdf)
+
+
+#+(or)
+;;?? ignore -- so how will ABL get "installed"
+;; should be unnecessary with newer versions of ASDF
+;; load customizations
+(eval-when (:load-toplevel :execute)
+ (let* ((*package* (find-package :common-lisp)))
+ (load
+ (merge-pathnames
+ (make-pathname :name "asdf-binary-locations"
+ :type "lisp"
+ :directory '(:relative ".asdf"))
+ (truename (user-homedir-pathname)))
+ :if-does-not-exist nil)))
More information about the Openmcl-cvs-notifications
mailing list