January 2016 - cmucl-cvs - mailman3.common-lisp.net

[Git][cmucl/cmucl][master] Clean up make-double-float vop.
by Raymond Toy 25 Jan '16

25 Jan '16

Raymond Toy pushed to branch master at cmucl / cmucl Commits: b059caca by Raymond Toy at 2016-01-24T20:21:39Z Clean up make-double-float vop. Remove the :load-if stuff. Don't think it's needed. - - - - - 1 changed file: - src/compiler/x86/float-sse2.lisp Changes: ===================================== src/compiler/x86/float-sse2.lisp ===================================== --- a/src/compiler/x86/float-sse2.lisp +++ b/src/compiler/x86/float-sse2.lisp @@ -1178,10 +1178,8 @@ (inst movd res bits))))))) (define-vop (make-double-float) - (:args (hi-bits :scs (signed-reg) - :load-if (not (sc-is hi-bits signed-stack))) - (lo-bits :scs (unsigned-reg) - :load-if (not (sc-is lo-bits signed-stack)))) + (:args (hi-bits :scs (signed-reg)) + (lo-bits :scs (unsigned-reg))) (:results (res :scs (double-reg))) (:arg-types signed-num unsigned-num) (:result-types double-float) @@ -1195,7 +1193,6 @@ (inst movd res lo-bits) (inst orpd res temp))) - (define-vop (single-float-bits) (:args (float :scs (single-reg descriptor-reg) :load-if (not (sc-is float single-stack)))) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/b059caca3cd4c094432493b17…

1 0

[Git][cmucl/cmucl][master] 2 commits: Add orps and orpd SSE2 instructions.
by Raymond Toy 24 Jan '16

24 Jan '16

Raymond Toy pushed to branch master at cmucl / cmucl Commits: 23209c84 by Raymond Toy at 2016-01-23T14:28:45Z Add orps and orpd SSE2 instructions. - - - - - 187d987e by Raymond Toy at 2016-01-23T14:31:09Z Use SSE2 instructions for MAKE-DOUBLE-FLOAT Instead of storing the high and low words to memory and then loading it into the double-reg, use SSE2 instructions to directly create the double-float from the high and low words. - - - - - 2 changed files: - src/compiler/x86/float-sse2.lisp - src/compiler/x86/insts.lisp Changes: ===================================== src/compiler/x86/float-sse2.lisp ===================================== --- a/src/compiler/x86/float-sse2.lisp +++ b/src/compiler/x86/float-sse2.lisp @@ -1178,21 +1178,22 @@ (inst movd res bits))))))) (define-vop (make-double-float) - (:args (hi-bits :scs (signed-reg)) - (lo-bits :scs (unsigned-reg))) + (:args (hi-bits :scs (signed-reg) + :load-if (not (sc-is hi-bits signed-stack))) + (lo-bits :scs (unsigned-reg) + :load-if (not (sc-is lo-bits signed-stack)))) (:results (res :scs (double-reg))) - (:temporary (:sc double-stack) temp) (:arg-types signed-num unsigned-num) (:result-types double-float) (:translate make-double-float) + (:temporary (:sc double-reg) temp) (:policy :fast-safe) (:vop-var vop) - (:generator 2 - (let ((offset (1+ (tn-offset temp)))) - (storew hi-bits ebp-tn (- offset)) - (storew lo-bits ebp-tn (- (1+ offset))) - (inst movsd res (make-ea :dword :base ebp-tn - :disp (- (* (1+ offset) word-bytes))))))) + (:generator 4 + (inst movd temp hi-bits) + (inst psllq temp 32) + (inst movd res lo-bits) + (inst orpd res temp))) (define-vop (single-float-bits) ===================================== src/compiler/x86/insts.lisp ===================================== --- a/src/compiler/x86/insts.lisp +++ b/src/compiler/x86/insts.lisp @@ -3146,6 +3146,8 @@ ;; logical (define-regular-sse-inst andpd #x66 #x54 t) (define-regular-sse-inst andps nil #x54) + (define-regular-sse-inst orpd #x66 #x56 t) + (define-regular-sse-inst orps nil #x56) (define-regular-sse-inst xorpd #x66 #x57 t) (define-regular-sse-inst xorps nil #x57) ;; comparison View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/compare/351351dfc04be5578dc76650…

1 0

[Git][cmucl/cmucl][master] 2 commits: Add orps and orpd SSE2 instructions.
by Raymond Toy 23 Jan '16

23 Jan '16

Raymond Toy pushed to branch master at cmucl / cmucl Commits: 23209c84 by Raymond Toy at 2016-01-23T14:28:45Z Add orps and orpd SSE2 instructions. - - - - - 187d987e by Raymond Toy at 2016-01-23T14:31:09Z Use SSE2 instructions for MAKE-DOUBLE-FLOAT Instead of storing the high and low words to memory and then loading it into the double-reg, use SSE2 instructions to directly create the double-float from the high and low words. - - - - - 2 changed files: - src/compiler/x86/float-sse2.lisp - src/compiler/x86/insts.lisp Changes: ===================================== src/compiler/x86/float-sse2.lisp ===================================== --- a/src/compiler/x86/float-sse2.lisp +++ b/src/compiler/x86/float-sse2.lisp @@ -1178,21 +1178,22 @@ (inst movd res bits))))))) (define-vop (make-double-float) - (:args (hi-bits :scs (signed-reg)) - (lo-bits :scs (unsigned-reg))) + (:args (hi-bits :scs (signed-reg) + :load-if (not (sc-is hi-bits signed-stack))) + (lo-bits :scs (unsigned-reg) + :load-if (not (sc-is lo-bits signed-stack)))) (:results (res :scs (double-reg))) - (:temporary (:sc double-stack) temp) (:arg-types signed-num unsigned-num) (:result-types double-float) (:translate make-double-float) + (:temporary (:sc double-reg) temp) (:policy :fast-safe) (:vop-var vop) - (:generator 2 - (let ((offset (1+ (tn-offset temp)))) - (storew hi-bits ebp-tn (- offset)) - (storew lo-bits ebp-tn (- (1+ offset))) - (inst movsd res (make-ea :dword :base ebp-tn - :disp (- (* (1+ offset) word-bytes))))))) + (:generator 4 + (inst movd temp hi-bits) + (inst psllq temp 32) + (inst movd res lo-bits) + (inst orpd res temp))) (define-vop (single-float-bits) ===================================== src/compiler/x86/insts.lisp ===================================== --- a/src/compiler/x86/insts.lisp +++ b/src/compiler/x86/insts.lisp @@ -3146,6 +3146,8 @@ ;; logical (define-regular-sse-inst andpd #x66 #x54 t) (define-regular-sse-inst andps nil #x54) + (define-regular-sse-inst orpd #x66 #x56 t) + (define-regular-sse-inst orps nil #x56) (define-regular-sse-inst xorpd #x66 #x57 t) (define-regular-sse-inst xorps nil #x57) ;; comparison View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/compare/351351dfc04be5578dc76650…

1 0

[Git][cmucl/cmucl][master] Simplify bignum-shld and bignum-shrd vops.
by Raymond Toy 18 Jan '16

18 Jan '16

Raymond Toy pushed to branch master at cmucl / cmucl Commits: 351351df by Raymond Toy at 2016-01-17T23:53:43Z Simplify bignum-shld and bignum-shrd vops. One temp variable for bignum-shld can be removed and the only temp variable for bignum-shld-c can be removed. Base this on the digit-ashr vops. This makes the vops simpler and faster. - - - - - 1 changed file: - src/compiler/x86/arith.lisp Changes: ===================================== src/compiler/x86/arith.lisp ===================================== --- a/src/compiler/x86/arith.lisp +++ b/src/compiler/x86/arith.lisp @@ -1583,80 +1583,48 @@ (define-vop (bignum-shld) (:policy :fast-safe) (:translate bignum::%shld) - (:args (x :scs (unsigned-reg) :target r) - (shift-in :scs (unsigned-reg)) + (:args (x :scs (unsigned-reg unsigned-stack) :target r) + (shift-in :scs (unsigned-reg) :to :result) (amount :scs (unsigned-reg) :target cl)) (:arg-types unsigned-num unsigned-num unsigned-num) - (:results (r :scs (unsigned-reg))) + (:results (r :scs (unsigned-reg) + :load-if (not (and (sc-is r unsigned-stack) + (location= x r))))) (:result-types unsigned-num) - (:temporary (:sc unsigned-reg :from (:argument 0) :to (:result 0)) temp) (:temporary (:sc unsigned-reg :offset ecx-offset - :from (:argument 2) :to (:result 0)) cl) - (:generator 4 + :from (:argument 2)) cl) + (:generator 3 (move cl amount) - (cond ((location= x r) - (inst shld x shift-in :cl)) - (t - (move temp x) - (inst shld temp shift-in :cl) - (move r temp))))) + (move r x) + (inst shld r shift-in :cl))) (define-vop (bignum-shld-c) (:policy :fast-safe) (:translate bignum::%shld) - (:args (x :scs (unsigned-reg) :target r) - (shift-in :scs (unsigned-reg))) + (:args (x :scs (unsigned-reg unsigned-stack) :target r) + (shift-in :scs (unsigned-reg) :to :save)) (:info shift) (:arg-types unsigned-num unsigned-num (:constant (unsigned-byte 5))) - (:results (r :scs (unsigned-reg))) + (:results (r :scs (unsigned-reg) + :load-if (not (and (sc-is r unsigned-stack) + (location= x r))))) (:result-types unsigned-num) - (:temporary (:sc unsigned-reg :from (:argument 0) :to (:result 0)) temp) - (:generator 3 - (cond ((location= x r) - (inst shld x shift-in shift)) - (t - (move temp x) - (inst shld temp shift-in shift) - (move r temp))))) + (:generator 2 + (move r x) + (inst shld r shift-in shift))) -(define-vop (bignum-shrd) - (:policy :fast-safe) +(define-vop (bignum-shrd bignum-shld) (:translate bignum::%shrd) - (:args (x :scs (unsigned-reg) :target r) - (shift-in :scs (unsigned-reg)) - (amount :scs (unsigned-reg) :target cl)) - (:arg-types unsigned-num unsigned-num unsigned-num) - (:results (r :scs (unsigned-reg))) - (:result-types unsigned-num) - (:temporary (:sc unsigned-reg :from (:argument 0) :to (:result 0)) temp) - (:temporary (:sc unsigned-reg :offset ecx-offset - :from (:argument 2) :to (:result 0)) cl) - (:generator 4 + (:generator 3 (move cl amount) - (cond ((location= x r) - (inst shrd x shift-in :cl)) - (t - (move temp x) - (inst shrd temp shift-in :cl) - (move r temp))))) + (move r x) + (inst shrd r shift-in :cl))) -(define-vop (bignum-shrd-c) - (:policy :fast-safe) +(define-vop (bignum-shrd-c bignum-shld-c) (:translate bignum::%shrd) - (:args (x :scs (unsigned-reg)) - (shift-in :scs (unsigned-reg))) - (:info shift) - (:arg-types unsigned-num unsigned-num (:constant (unsigned-byte 5))) - (:results (r :scs (unsigned-reg))) - (:result-types unsigned-num) - (:temporary (:sc unsigned-reg :from (:argument 0) :to (:result 0)) temp) - (:generator 3 - (cond ((location= x r) - (inst shrd x shift-in shift)) - (t - (move temp x) - (inst shrd temp shift-in shift) - (move r temp))))) + (:generator 2 + (move r x) + (inst shrd r shift-in shift))) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/351351dfc04be5578dc76650c…

1 0

[Git][cmucl/cmucl][master] Indent nicely.
by Raymond Toy 18 Jan '16

18 Jan '16

Raymond Toy pushed to branch master at cmucl / cmucl Commits: 909ad007 by Raymond Toy at 2016-01-17T20:57:41Z Indent nicely. - - - - - 1 changed file: - src/code/bignum.lisp Changes: ===================================== src/code/bignum.lisp ===================================== --- a/src/code/bignum.lisp +++ b/src/code/bignum.lisp @@ -3721,5 +3721,5 @@ friends is working. (%shrd x carry-in shift) #-x86 (ldb (byte vm:word-bits 0) - (logior (ash x (- shift)) - (ash carry-in (- vm:word-bits shift))))) + (logior (ash x (- shift)) + (ash carry-in (- vm:word-bits shift))))) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/909ad0074d079350b658f0f66…

1 0

[Git][cmucl/cmucl][master] Add bignum::%shld and bignum::%shrd
by Raymond Toy 16 Jan '16

16 Jan '16

Raymond Toy pushed to branch master at cmucl / cmucl Commits: ddc980d5 by Raymond Toy at 2016-01-16T14:34:19Z Add bignum::%shld and bignum::%shrd These are useful for multi-precision shifts. For x86, we can use the shld and shrd instructions. For others, we just use basic logical operations. - - - - - 3 changed files: - src/code/bignum.lisp - src/compiler/generic/vm-fndb.lisp - src/compiler/x86/arith.lisp Changes: ===================================== src/code/bignum.lisp ===================================== --- a/src/code/bignum.lisp +++ b/src/code/bignum.lisp @@ -3697,3 +3697,29 @@ friends is working. (unless (= newlen len) (%bignum-set-length result newlen)) result)) + +;; Shift X left by Shift bits, shifting in bits from Carry-in. +;; Basically treat x:carry-in as a 64-bit value and shift it left, +;; returning the top bignum-type bits. +(defun %shld (x carry-in shift) + (declare (type bignum-element-type x carry-in) + (type (unsigned-byte 5) shift)) + #+x86 + (%shld x carry-in shift) + #-x86 + (ldb (byte vm:word-bits 0) + (logior (ash x shift) + (ash carry-in (- shift vm:word-bits))))) + +;; Shift X right by Shift bits, shifting in bits from Carry-in. +;; Basically treat carry-in:x as a 64-bit value and shift it right, +;; returning the low bignum-type bits. +(defun %shrd (x carry-in shift) + (declare (type bignum-element-type x carry-in) + (type (unsigned-byte 5) shift)) + #+x86 + (%shrd x carry-in shift) + #-x86 + (ldb (byte vm:word-bits 0) + (logior (ash x (- shift)) + (ash carry-in (- vm:word-bits shift))))) ===================================== src/compiler/generic/vm-fndb.lisp ===================================== --- a/src/compiler/generic/vm-fndb.lisp +++ b/src/compiler/generic/vm-fndb.lisp @@ -288,6 +288,13 @@ (bignum-element-type (mod #+amd64 64 #-amd64 32)) bignum-element-type (foldable flushable movable)) + +#+x86 +(defknown (bignum::%shld bignum::%shrd) + (bignum-element-type bignum-element-type (unsigned-byte 5)) + bignum-element-type + (foldable flushable movable)) + ;;;; Bit-bashing routines. ===================================== src/compiler/x86/arith.lisp ===================================== --- a/src/compiler/x86/arith.lisp +++ b/src/compiler/x86/arith.lisp @@ -1579,6 +1579,86 @@ (inst mov tmp y) (inst shr tmp 18) (inst xor y tmp))) + +(define-vop (bignum-shld) + (:policy :fast-safe) + (:translate bignum::%shld) + (:args (x :scs (unsigned-reg) :target r) + (shift-in :scs (unsigned-reg)) + (amount :scs (unsigned-reg) :target cl)) + (:arg-types unsigned-num unsigned-num unsigned-num) + (:results (r :scs (unsigned-reg))) + (:result-types unsigned-num) + (:temporary (:sc unsigned-reg :from (:argument 0) :to (:result 0)) temp) + (:temporary (:sc unsigned-reg :offset ecx-offset + :from (:argument 2) :to (:result 0)) cl) + (:generator 4 + (move cl amount) + (cond ((location= x r) + (inst shld x shift-in :cl)) + (t + (move temp x) + (inst shld temp shift-in :cl) + (move r temp))))) + +(define-vop (bignum-shld-c) + (:policy :fast-safe) + (:translate bignum::%shld) + (:args (x :scs (unsigned-reg) :target r) + (shift-in :scs (unsigned-reg))) + (:info shift) + (:arg-types unsigned-num unsigned-num (:constant (unsigned-byte 5))) + (:results (r :scs (unsigned-reg))) + (:result-types unsigned-num) + (:temporary (:sc unsigned-reg :from (:argument 0) :to (:result 0)) temp) + (:generator 3 + (cond ((location= x r) + (inst shld x shift-in shift)) + (t + (move temp x) + (inst shld temp shift-in shift) + (move r temp))))) + +(define-vop (bignum-shrd) + (:policy :fast-safe) + (:translate bignum::%shrd) + (:args (x :scs (unsigned-reg) :target r) + (shift-in :scs (unsigned-reg)) + (amount :scs (unsigned-reg) :target cl)) + (:arg-types unsigned-num unsigned-num unsigned-num) + (:results (r :scs (unsigned-reg))) + (:result-types unsigned-num) + (:temporary (:sc unsigned-reg :from (:argument 0) :to (:result 0)) temp) + (:temporary (:sc unsigned-reg :offset ecx-offset + :from (:argument 2) :to (:result 0)) cl) + (:generator 4 + (move cl amount) + (cond ((location= x r) + (inst shrd x shift-in :cl)) + (t + (move temp x) + (inst shrd temp shift-in :cl) + (move r temp))))) + +(define-vop (bignum-shrd-c) + (:policy :fast-safe) + (:translate bignum::%shrd) + (:args (x :scs (unsigned-reg)) + (shift-in :scs (unsigned-reg))) + (:info shift) + (:arg-types unsigned-num unsigned-num (:constant (unsigned-byte 5))) + (:results (r :scs (unsigned-reg))) + (:result-types unsigned-num) + (:temporary (:sc unsigned-reg :from (:argument 0) :to (:result 0)) temp) + (:generator 3 + (cond ((location= x r) + (inst shrd x shift-in shift)) + (t + (move temp x) + (inst shrd temp shift-in shift) + (move r temp))))) + + ;;; Modular arithmetic ;;; logical operations View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/ddc980d5637cb21305e35c1a9…

1 0

[Git][cmucl/cmucl][master] Fix up shld/shrd instructions.
by Raymond Toy 16 Jan '16

16 Jan '16

Raymond Toy pushed to branch master at cmucl / cmucl Commits: 8058d410 by Raymond Toy at 2016-01-16T13:01:37Z Fix up shld/shrd instructions. o Need to define a new instruction format for these double shifts; they look like ext-reg-reg/mem but there's no width field. o Clean up emit-double-shift slightly. o Update double-shift-inst-printer-list to support both immediate shift or shifts in CL. - - - - - 1 changed file: - src/compiler/x86/insts.lisp Changes: ===================================== src/compiler/x86/insts.lisp ===================================== --- a/src/compiler/x86/insts.lisp +++ b/src/compiler/x86/insts.lisp @@ -859,6 +859,18 @@ ;; optional fields (imm)) +;; Double shift instructions. Like ext-reg-reg/mem but there's no +;; width field. +(disassem:define-instruction-format (ext-reg-reg/mem-shift 24) + (prefix :field (byte 8 0) :value #b00001111) + (op :field (byte 8 8)) + (reg/mem :fields (list (byte 2 22) (byte 3 16)) + :type 'reg/mem) + (reg :field (byte 3 19) :type 'reg) + ;; optional fields + (imm)) + + ;;; ---------------------------------------------------------------- ;;; this section added by jrd, for fp instructions. @@ -1535,24 +1547,22 @@ (defun emit-double-shift (segment opcode dst src amt) (let ((size (matching-operand-size dst src))) (when (eq size :byte) - (error "Double shifts can only be used with words.")) + (error "Double shifts cannot be used with byte registers.")) (maybe-emit-operand-size-prefix segment size) (emit-byte segment #b00001111) (emit-byte segment (dpb opcode (byte 1 3) (if (eq amt :cl) #b10100101 #b10100100))) - #+nil - (emit-ea segment dst src) - (emit-ea segment dst (reg-tn-encoding src)) ; pw tries this + (emit-ea segment dst (reg-tn-encoding src)) (unless (eq amt :cl) (emit-byte segment amt)))) (eval-when (compile eval) (defun double-shift-inst-printer-list (op) - `(#+nil - (ext-reg-reg/mem-imm ((op ,(logior op #b100)) - (imm nil :type signed-imm-byte))) - (ext-reg-reg/mem ((op ,(logior op #b101))) - (:name :tab reg/mem ", " 'cl))))) + `((ext-reg-reg/mem-shift ((op ,(logior op #b100)) + (imm nil :type signed-imm-byte)) + (:name :tab reg/mem ", " reg ", " imm)) + (ext-reg-reg/mem-shift ((op ,(logior op #b101))) + (:name :tab reg/mem ", " reg ", " 'cl))))) (define-instruction shld (segment dst src amt) (:declare (type (or (member :cl) (mod 32)) amt)) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/8058d410e86a77a6839d4c422…

1 0

[Git][cmucl/cmucl][master] Regenerated.
by Raymond Toy 16 Jan '16

16 Jan '16

Raymond Toy pushed to branch master at cmucl / cmucl Commits: 06a68321 by Raymond Toy at 2016-01-16T12:58:43Z Regenerated. - - - - - 1 changed file: - src/i18n/locale/cmucl.pot Changes: ===================================== src/i18n/locale/cmucl.pot ===================================== --- a/src/i18n/locale/cmucl.pot +++ b/src/i18n/locale/cmucl.pot @@ -6654,7 +6654,9 @@ msgid "" msgstr "" #: src/code/save.lisp -msgid "An alist mapping environment variables (as keywords) to either values" +msgid "" +"An alist mapping each environment variable (as a keyword) to its\n" +" value." msgstr "" #: src/code/save.lisp @@ -13122,8 +13124,9 @@ msgid "" "\n" " The keyword arguments have the following meanings:\n" " :env -\n" -" An A-LIST mapping keyword environment variables to simple-string\n" -" values.\n" +" An A-LIST mapping keyword environment variables to\n" +" simple-string values. This is the shell environment for\n" +" Program. Defaults to *environment-list*.\n" " :wait -\n" " If non-NIL (default), wait until the created process finishes. If\n" " NIL, continue running Lisp until the program finishes.\n" View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/06a683219621cc8e381b3d6ee…

1 0

[Git][cmucl/cmucl][master] Add comment on why RESTORE_FPU is needed.
by Raymond Toy 16 Jan '16

16 Jan '16

Raymond Toy pushed to branch master at cmucl / cmucl Commits: 6feaee2d by Raymond Toy at 2016-01-16T08:37:03Z Add comment on why RESTORE_FPU is needed. - - - - - 1 changed file: - src/lisp/x86-arch.c Changes: ===================================== src/lisp/x86-arch.c ===================================== --- a/src/lisp/x86-arch.c +++ b/src/lisp/x86-arch.c @@ -320,6 +320,12 @@ sigtrap_handler(HANDLER_ARGS) /* This is just for info in case monitor wants to print an approx */ current_control_stack_pointer = (unsigned long *) SC_SP(os_context); + + /* + * In many places in the switch below, we eventually throw instead + * of returning from the signal handler. So, just in case, set + * the current FPU modes from the saved context. + */ RESTORE_FPU(os_context); /* View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/6feaee2df686c62509f7c2292…

1 0

[Git][cmucl/cmucl][master] Actually remove RESTORE_FPU's that were #if'ed out.
by Raymond Toy 16 Jan '16

16 Jan '16

Raymond Toy pushed to branch master at cmucl / cmucl Commits: 17932a00 by Raymond Toy at 2016-01-16T08:33:55Z Actually remove RESTORE_FPU's that were #if'ed out. - - - - - 1 changed file: - src/lisp/interrupt.c Changes: ===================================== src/lisp/interrupt.c ===================================== --- a/src/lisp/interrupt.c +++ b/src/lisp/interrupt.c @@ -252,10 +252,6 @@ interrupt_handle_now(HANDLER_ARGS) handler = interrupt_handlers[signal]; -#if 0 - RESTORE_FPU(context); -#endif - if (handler.c == (void (*)(HANDLER_ARGS)) SIG_IGN) return; @@ -335,9 +331,6 @@ maybe_now_maybe_later(HANDLER_ARGS) setup_pending_signal(signal, code, context); arch_set_pseudo_atomic_interrupted(context); } else { -#if 0 - RESTORE_FPU(context); -#endif interrupt_handle_now(signal, code, context); } View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/17932a00d691bb2dada5da81f…

1 0

[Git][cmucl/cmucl][master] Better description for run-program :env
by Raymond Toy 16 Jan '16

16 Jan '16

Raymond Toy pushed to branch master at cmucl / cmucl Commits: f613124b by Raymond Toy at 2016-01-16T08:24:09Z Better description for run-program :env Fix #18. - - - - - 1 changed file: - src/code/run-program.lisp Changes: ===================================== src/code/run-program.lisp ===================================== --- a/src/code/run-program.lisp +++ b/src/code/run-program.lisp @@ -471,8 +471,9 @@ The keyword arguments have the following meanings: :env - - An A-LIST mapping keyword environment variables to simple-string - values. + An A-LIST mapping keyword environment variables to + simple-string values. This is the shell environment for + Program. Defaults to *environment-list*. :wait - If non-NIL (default), wait until the created process finishes. If NIL, continue running Lisp until the program finishes. View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/f613124b7479c364d557e5f70…

1 0

[Git][cmucl/cmucl][master] Better docstring for *environment-list*
by Raymond Toy 16 Jan '16

16 Jan '16

Raymond Toy pushed to branch master at cmucl / cmucl Commits: 6ac8b5f6 by Raymond Toy at 2016-01-16T08:18:00Z Better docstring for *environment-list* Fix #17. - - - - - 1 changed file: - src/code/save.lisp Changes: ===================================== src/code/save.lisp ===================================== --- a/src/code/save.lisp +++ b/src/code/save.lisp @@ -36,7 +36,8 @@ might not be.") (defvar *environment-list* nil - "An alist mapping environment variables (as keywords) to either values") + "An alist mapping each environment variable (as a keyword) to its + value.") (defvar *environment-list-initialized* nil "Non-NIL if environment-init has been called") View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/6ac8b5f6ee9fd9553d6ed2885…

1 0

[Git][cmucl/cmucl][master] 6 commits: Handle FP exceptions better.
by Raymond Toy 16 Jan '16

16 Jan '16

Raymond Toy pushed to branch master at cmucl / cmucl Commits: e63bc1e9 by Raymond Toy at 2016-01-09T19:00:37Z Handle FP exceptions better. Don't restore the fpu state from the context in the interrupt handler code (interrupt_handle_now) because that just makes the fpu state the same as the sigcontext that received the exception. I think this was done to reset the x87 fpu precision to 53-bit so that lisp can continue with default double-float rounding. This isn't needed anymore since lisp doesn't use x87 anymore. In SIGFPE-HANDLER, don't modify the current fp state based on the state from the sigcontext. These two items cause the arithmetic-error exception printer to trigger inexact when printing out the args. We add a few debugging prints for now so we can see what the FP state is in the handler. Remove them later. - - - - - da2ff74d by Raymond Toy at 2016-01-10T14:13:10Z Handle FPU exceptions better. In sigfpe-handler, don't modify the modes; just use whatever they are. (They should be the default values.) In with-float-traps-*, actually just restore the floating-point mode to the exact original mode instead of trying to mask things out. - - - - - d9763e90 by Raymond Toy at 2016-01-10T15:42:41Z In WITH-FLOAT-TRAPS-*, remove the unused junk modifying the state. We just want to return the original modes, so remove all the old commented out stuff that was modifying the original modes to some strange state. This makes a lot more sense to me if WITH-FLOAT-TRAPS-* actually restored the modes exactly as they were before running the body. - - - - - d7850f57 by Raymond Toy at 2016-01-12T21:21:40Z Restore the FPU state before exiting. Put an unwind-protect around the error calls. The cleanup form restores the floating-point modes from the sigcontext so that the mode is restored. This is needed, I think, because we throw so that the signal handler doesn't return so the sigcontext isn't restored. If we don't restore the fpu state, it's set to the default processor state. We want the default state when calling error. In this way, things like (* 1d300 1d300) signals an overflow, and when we throw to top-level, the floating-point modes are restored to their original values they had before. - - - - - 1fab9bf3 by Raymond Toy at 2016-01-13T21:34:39Z Clean up sigfpe-handler; add comments. - - - - - 94bb2d9d by Raymond Toy at 2016-01-16T16:02:25Z Merge branch 'rtoy-15-handle-fpu-exceptions' into 'master' Handle FPU exceptions better Fix #15 Handle FPU exceptions better in sigfpe-handler. Linux now passes all of the tests, including the inexact tests. We can correctly print out the operands (if available) when we receive an inexact exception. The floating point modes are preserved as much as possible when we throw from an arithmetic-error. See merge request !7 - - - - - 2 changed files: - src/code/float-trap.lisp - src/lisp/interrupt.c Changes: ===================================== src/code/float-trap.lisp ===================================== --- a/src/code/float-trap.lisp +++ b/src/code/float-trap.lisp @@ -319,102 +319,118 @@ (alien:sap-alien scp (* unix:sigcontext)))) (traps (logand (ldb float-exceptions-byte modes) (ldb float-traps-byte modes)))) - #+(and darwin ppc) - (let* ((new-modes modes) - (new-exceptions (logandc2 (ldb float-exceptions-byte new-modes) - traps))) - ;; (format t "sigfpe: modes = #B~32,'0b~%" modes) - ;; (format t "sigfpe: new-exc = #B~32,'0b~%" new-exceptions) - (setf (ldb float-exceptions-byte new-modes) new-exceptions) - ;; Clear out all exceptions and save them to the context. - ;; - ;; XXX: Should we just clear out the bits for the traps that are - ;; enabled? If we did that then the accrued exceptions would be - ;; correct. - (setf (ldb float-sticky-bits new-modes) 0) - ;; Clear out the various sticky invalid operation bits too. - ;; - ;; XXX: Should we only do that if the invalid trap is enabled? - (setf (ldb float-invalid-op-1-byte new-modes) 0) - (setf (ldb float-invalid-op-2-byte new-modes) 0) - ;; Clear the FP exception summary bit too. - (setf (ldb float-exceptions-summary-byte new-modes) 0) - ;; (format t "sigfpe: new modes = #B~32,'0b~%" new-modes) - (setf (floating-point-modes) new-modes) - (setf (sigcontext-floating-point-modes - (alien:sap-alien scp (* unix:sigcontext))) - new-modes)) - - #+sse2 - (let* ((new-modes modes) - (new-exceptions (logandc2 (ldb float-exceptions-byte new-modes) - traps))) - ;; Clear out the status for any enabled traps. With SSE2, if - ;; the current exception is enabled, the next FP instruction - ;; will cause the exception to be signaled again. Hence, we - ;; need to clear out the exceptions that we are handling here. - (setf (ldb float-exceptions-byte new-modes) new-exceptions) - ;; XXX: This seems not right. Shouldn't we be setting the modes - ;; in the sigcontext instead? This however seems to do what we - ;; want. - (setf (vm:floating-point-modes) new-modes)) + (multiple-value-bind (fop operands) (let ((sym (find-symbol "GET-FP-OPERANDS" "VM"))) (if (fboundp sym) (funcall sym (alien:sap-alien scp (* unix:sigcontext)) modes) (values nil nil))) - (cond ((not (zerop (logand float-divide-by-zero-trap-bit traps))) - (error 'division-by-zero - :operation fop - :operands operands)) - ((not (zerop (logand float-invalid-trap-bit traps))) - (error 'floating-point-invalid-operation - :operation fop - :operands operands)) - ((not (zerop (logand float-overflow-trap-bit traps))) - (error 'floating-point-overflow - :operation fop - :operands operands)) - ((not (zerop (logand float-underflow-trap-bit traps))) - (error 'floating-point-underflow - :operation fop - :operands operands)) - ((not (zerop (logand float-inexact-trap-bit traps))) - (error 'floating-point-inexact - :operation fop - :operands operands)) - #+x86 - ((not (zerop (logand float-denormal-trap-bit traps))) - (error 'floating-point-denormal-operand - :operation fop - :operands operands)) - (t - ;; It looks like the sigcontext on Solaris/x86 doesn't - ;; actually save the status word of the FPU. The - ;; operands also seem to be missing. Signal a general - ;; arithmetic error. - #+(and x86 solaris) - (error _"SIGFPE with no exceptions currently enabled? (si-code = ~D)" - code) - ;; For all other x86 ports, we should only get here if - ;; the SIGFPE was caused by an integer overflow on - ;; division. For sparc and ppc, I (rtoy) don't think - ;; there's any other way to get here since integer - ;; overflows aren't signaled. - ;; - ;; In that case, FOP should be /, so we can generate a - ;; nice arithmetic-error. It's possible to use CODE, - ;; which is supposed to indicate what caused the - ;; exception, but each OS is different, so we don't; FOP - ;; can tell us. - #-(and x86 solaris) - (if fop - (error 'arithmetic-error - :operation fop - :operands operands) - (error _"SIGFPE with no exceptions currently enabled? (si-code = ~D)" - code))))))) + ;; Don't let throws get away without resetting the + ;; floating-point modes back to the original values which we get + ;; from the sigcontext. Because we can throw, we never return + ;; from the signal handler so the sigcontext is never restored. + ;; This means we need to restore the fpu state ourselves. + (unwind-protect + (cond ((not (zerop (logand float-divide-by-zero-trap-bit traps))) + (error 'division-by-zero + :operation fop + :operands operands)) + ((not (zerop (logand float-invalid-trap-bit traps))) + (error 'floating-point-invalid-operation + :operation fop + :operands operands)) + ((not (zerop (logand float-overflow-trap-bit traps))) + (error 'floating-point-overflow + :operation fop + :operands operands)) + ((not (zerop (logand float-underflow-trap-bit traps))) + (error 'floating-point-underflow + :operation fop + :operands operands)) + ((not (zerop (logand float-inexact-trap-bit traps))) + (error 'floating-point-inexact + :operation fop + :operands operands)) + #+x86 + ((not (zerop (logand float-denormal-trap-bit traps))) + (error 'floating-point-denormal-operand + :operation fop + :operands operands)) + (t + ;; It looks like the sigcontext on Solaris/x86 doesn't + ;; actually save the status word of the FPU. The + ;; operands also seem to be missing. Signal a general + ;; arithmetic error. + #+(and x86 solaris) + (error _"SIGFPE with no exceptions currently enabled? (si-code = ~D)" + code) + ;; For all other x86 ports, we should only get here if + ;; the SIGFPE was caused by an integer overflow on + ;; division. For sparc and ppc, I (rtoy) don't think + ;; there's any other way to get here since integer + ;; overflows aren't signaled. + ;; + ;; In that case, FOP should be /, so we can generate a + ;; nice arithmetic-error. It's possible to use CODE, + ;; which is supposed to indicate what caused the + ;; exception, but each OS is different, so we don't; FOP + ;; can tell us. + #-(and x86 solaris) + (if fop + (error 'arithmetic-error + :operation fop + :operands operands) + (error _"SIGFPE with no exceptions currently enabled? (si-code = ~D)" + code)))) + ;; Cleanup + (let* ((new-modes modes) + (new-exceptions (logandc2 (ldb float-exceptions-byte new-modes) + traps))) + #+(and darwin ppc) + (progn + ;; (format t "sigfpe: modes = #B~32,'0b~%" modes) + ;; (format t "sigfpe: new-exc = #B~32,'0b~%" new-exceptions) + (setf (ldb float-exceptions-byte new-modes) new-exceptions) + ;; Clear out all exceptions. + ;; + ;; XXX: Should we just clear out the bits for the traps that are + ;; enabled? If we did that then the accrued exceptions would be + ;; correct. + (setf (ldb float-sticky-bits new-modes) 0) + ;; Clear out the various sticky invalid operation bits too. + ;; + ;; XXX: Should we only do that if the invalid trap is enabled? + (setf (ldb float-invalid-op-1-byte new-modes) 0) + (setf (ldb float-invalid-op-2-byte new-modes) 0) + ;; Clear the FP exception summary bit too. + (setf (ldb float-exceptions-summary-byte new-modes) 0) + ;; (format t "sigfpe: new modes = #B~32,'0b~%" new-modes) + (setf (floating-point-modes) new-modes)) + + #+sse2 + (progn + ;; Clear out the status for any enabled traps. With SSE2, if + ;; the current exception is enabled, the next FP instruction + ;; will cause the exception to be signaled again. Hence, we + ;; need to clear out the exceptions that we are handling here. + (setf (ldb float-exceptions-byte new-modes) new-exceptions) + #+nil + (progn + (format *debug-io* "sigcontext modes: #x~4x (~A)~%" + modes (decode-floating-point-modes modes)) + (format *debug-io* "current modes: #x~4x (~A)~%" + (vm:floating-point-modes) (get-floating-point-modes)) + (format *debug-io* "new modes: #x~x (~A)~%" + new-modes (decode-floating-point-modes new-modes))) + (setf (vm:floating-point-modes) new-modes)) + + #-(or sse2 (and darwin ppc)) + (progn + ;; Apparently nothing needed for sparc it seems The FPU + ;; state in the signal handler is unchanged and it seems we + ;; don't need to reset it any way when we throw out. + )))))) (macrolet ((with-float-traps (name merge-traps docstring) @@ -440,6 +456,10 @@ ;; representing the invalid operation. Otherwise, if we ;; enable the invalid trap later, these sticky bits will cause ;; an exception. + ;; + ;; FIXME: Consider removing these for ppc. Since + ;; we now restore the original modes exactly, I + ;; don't think these are needed anymore. #+ppc (invalid-mask (if (member :invalid traps) (dpb 0 @@ -456,14 +476,8 @@ (logand (,',merge-traps ,orig-modes ,trap-mask) ,exception-mask))) ,@body) - ;; Restore the original traps and exceptions. - (setf (floating-point-modes) - (logior (logand ,orig-modes ,(logior traps exceptions)) - (logand (floating-point-modes) - ,(logand trap-mask exception-mask) - #+ppc - ,invalid-mask - #+mips ,(dpb 0 float-exceptions-byte #xffffffff)))))))))))) + ;; Restore the modes exactly as they were. + (setf (floating-point-modes) ,orig-modes))))))))) ;; WITH-FLOAT-TRAPS-MASKED -- Public (with-float-traps masked logand ===================================== src/lisp/interrupt.c ===================================== --- a/src/lisp/interrupt.c +++ b/src/lisp/interrupt.c @@ -252,7 +252,9 @@ interrupt_handle_now(HANDLER_ARGS) handler = interrupt_handlers[signal]; +#if 0 RESTORE_FPU(context); +#endif if (handler.c == (void (*)(HANDLER_ARGS)) SIG_IGN) return; @@ -333,7 +335,9 @@ maybe_now_maybe_later(HANDLER_ARGS) setup_pending_signal(signal, code, context); arch_set_pseudo_atomic_interrupted(context); } else { +#if 0 RESTORE_FPU(context); +#endif interrupt_handle_now(signal, code, context); } View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/compare/5c10ab93105fa6e095bbcbb0…

1 0

[Git][cmucl/cmucl][rtoy-15-handle-fpu-exceptions] Clean up sigfpe-handler; add comments.
by Raymond Toy 14 Jan '16

14 Jan '16

Raymond Toy pushed to branch rtoy-15-handle-fpu-exceptions at cmucl / cmucl Commits: 1fab9bf3 by Raymond Toy at 2016-01-13T21:34:39Z Clean up sigfpe-handler; add comments. - - - - - 1 changed file: - src/code/float-trap.lisp Changes: ===================================== src/code/float-trap.lisp ===================================== --- a/src/code/float-trap.lisp +++ b/src/code/float-trap.lisp @@ -312,7 +312,6 @@ ;;; ;;; Signal the appropriate condition when we get a floating-point error. ;;; -(defvar *debug-sigfpe-handler* nil) (defun sigfpe-handler (signal code scp) (declare (ignore signal) (type system-area-pointer scp)) @@ -385,54 +384,53 @@ (error _"SIGFPE with no exceptions currently enabled? (si-code = ~D)" code)))) ;; Cleanup - #+(and darwin ppc) (let* ((new-modes modes) (new-exceptions (logandc2 (ldb float-exceptions-byte new-modes) traps))) - ;; (format t "sigfpe: modes = #B~32,'0b~%" modes) - ;; (format t "sigfpe: new-exc = #B~32,'0b~%" new-exceptions) - (setf (ldb float-exceptions-byte new-modes) new-exceptions) - ;; Clear out all exceptions and save them to the context. - ;; - ;; XXX: Should we just clear out the bits for the traps that are - ;; enabled? If we did that then the accrued exceptions would be - ;; correct. - (setf (ldb float-sticky-bits new-modes) 0) - ;; Clear out the various sticky invalid operation bits too. - ;; - ;; XXX: Should we only do that if the invalid trap is enabled? - (setf (ldb float-invalid-op-1-byte new-modes) 0) - (setf (ldb float-invalid-op-2-byte new-modes) 0) - ;; Clear the FP exception summary bit too. - (setf (ldb float-exceptions-summary-byte new-modes) 0) - ;; (format t "sigfpe: new modes = #B~32,'0b~%" new-modes) - (setf (floating-point-modes) new-modes) - #+nil - (setf (sigcontext-floating-point-modes - (alien:sap-alien scp (* unix:sigcontext))) - new-modes)) - - #+sse2 - (let* ((new-modes modes) - (new-exceptions (logandc2 (ldb float-exceptions-byte new-modes) - traps))) - ;; Clear out the status for any enabled traps. With SSE2, if - ;; the current exception is enabled, the next FP instruction - ;; will cause the exception to be signaled again. Hence, we - ;; need to clear out the exceptions that we are handling here. - (setf (ldb float-exceptions-byte new-modes) new-exceptions) - ;; XXX: This seems not right. Shouldn't we be setting the modes - ;; in the sigcontext instead? This however seems to do what we - ;; want. - - (when *debug-sigfpe-handler* - (format *debug-io* "sigcontext modes: #x~4x (~A)~%" - modes (decode-floating-point-modes modes)) - (format *debug-io* "current modes: #x~4x (~A)~%" - (vm:floating-point-modes) (get-floating-point-modes)) - (format *debug-io* "new modes: #x~x (~A)~%" - new-modes (decode-floating-point-modes new-modes))) - (setf (vm:floating-point-modes) new-modes)))))) + #+(and darwin ppc) + (progn + ;; (format t "sigfpe: modes = #B~32,'0b~%" modes) + ;; (format t "sigfpe: new-exc = #B~32,'0b~%" new-exceptions) + (setf (ldb float-exceptions-byte new-modes) new-exceptions) + ;; Clear out all exceptions. + ;; + ;; XXX: Should we just clear out the bits for the traps that are + ;; enabled? If we did that then the accrued exceptions would be + ;; correct. + (setf (ldb float-sticky-bits new-modes) 0) + ;; Clear out the various sticky invalid operation bits too. + ;; + ;; XXX: Should we only do that if the invalid trap is enabled? + (setf (ldb float-invalid-op-1-byte new-modes) 0) + (setf (ldb float-invalid-op-2-byte new-modes) 0) + ;; Clear the FP exception summary bit too. + (setf (ldb float-exceptions-summary-byte new-modes) 0) + ;; (format t "sigfpe: new modes = #B~32,'0b~%" new-modes) + (setf (floating-point-modes) new-modes)) + + #+sse2 + (progn + ;; Clear out the status for any enabled traps. With SSE2, if + ;; the current exception is enabled, the next FP instruction + ;; will cause the exception to be signaled again. Hence, we + ;; need to clear out the exceptions that we are handling here. + (setf (ldb float-exceptions-byte new-modes) new-exceptions) + #+nil + (progn + (format *debug-io* "sigcontext modes: #x~4x (~A)~%" + modes (decode-floating-point-modes modes)) + (format *debug-io* "current modes: #x~4x (~A)~%" + (vm:floating-point-modes) (get-floating-point-modes)) + (format *debug-io* "new modes: #x~x (~A)~%" + new-modes (decode-floating-point-modes new-modes))) + (setf (vm:floating-point-modes) new-modes)) + + #-(or sse2 (and darwin ppc)) + (progn + ;; Apparently nothing needed for sparc it seems The FPU + ;; state in the signal handler is unchanged and it seems we + ;; don't need to reset it any way when we throw out. + )))))) (macrolet ((with-float-traps (name merge-traps docstring) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/1fab9bf37ce138dba85e5fb85…

1 0

[Git][cmucl/cmucl][rtoy-15-handle-fpu-exceptions] Restore the FPU state before exiting.
by Raymond Toy 13 Jan '16

13 Jan '16

Raymond Toy pushed to branch rtoy-15-handle-fpu-exceptions at cmucl / cmucl Commits: d7850f57 by Raymond Toy at 2016-01-12T21:21:40Z Restore the FPU state before exiting. Put an unwind-protect around the error calls. The cleanup form restores the floating-point modes from the sigcontext so that the mode is restored. This is needed, I think, because we throw so that the signal handler doesn't return so the sigcontext isn't restored. If we don't restore the fpu state, it's set to the default processor state. We want the default state when calling error. In this way, things like (* 1d300 1d300) signals an overflow, and when we throw to top-level, the floating-point modes are restored to their original values they had before. - - - - - 1 changed file: - src/code/float-trap.lisp Changes: ===================================== src/code/float-trap.lisp ===================================== --- a/src/code/float-trap.lisp +++ b/src/code/float-trap.lisp @@ -312,7 +312,6 @@ ;;; ;;; Signal the appropriate condition when we get a floating-point error. ;;; -#+nil (defvar *debug-sigfpe-handler* nil) (defun sigfpe-handler (signal code scp) (declare (ignore signal) @@ -321,111 +320,119 @@ (alien:sap-alien scp (* unix:sigcontext)))) (traps (logand (ldb float-exceptions-byte modes) (ldb float-traps-byte modes)))) - #+(and darwin ppc) - (let* ((new-modes modes) - (new-exceptions (logandc2 (ldb float-exceptions-byte new-modes) - traps))) - ;; (format t "sigfpe: modes = #B~32,'0b~%" modes) - ;; (format t "sigfpe: new-exc = #B~32,'0b~%" new-exceptions) - (setf (ldb float-exceptions-byte new-modes) new-exceptions) - ;; Clear out all exceptions and save them to the context. - ;; - ;; XXX: Should we just clear out the bits for the traps that are - ;; enabled? If we did that then the accrued exceptions would be - ;; correct. - (setf (ldb float-sticky-bits new-modes) 0) - ;; Clear out the various sticky invalid operation bits too. - ;; - ;; XXX: Should we only do that if the invalid trap is enabled? - (setf (ldb float-invalid-op-1-byte new-modes) 0) - (setf (ldb float-invalid-op-2-byte new-modes) 0) - ;; Clear the FP exception summary bit too. - (setf (ldb float-exceptions-summary-byte new-modes) 0) - ;; (format t "sigfpe: new modes = #B~32,'0b~%" new-modes) - (setf (floating-point-modes) new-modes) - (setf (sigcontext-floating-point-modes - (alien:sap-alien scp (* unix:sigcontext))) - new-modes)) - - #+nil - (let* ((new-modes modes) - (new-exceptions (logandc2 (ldb float-exceptions-byte new-modes) - traps))) - ;; Clear out the status for any enabled traps. With SSE2, if - ;; the current exception is enabled, the next FP instruction - ;; will cause the exception to be signaled again. Hence, we - ;; need to clear out the exceptions that we are handling here. - (setf (ldb float-exceptions-byte new-modes) new-exceptions) - ;; XXX: This seems not right. Shouldn't we be setting the modes - ;; in the sigcontext instead? This however seems to do what we - ;; want. - - (when *debug-sigfpe-handler* - (format *debug-io* "sigcontext modes: #x~4x (~A)~%" - modes (decode-floating-point-modes modes)) - (format *debug-io* "current modes: #x~4x (~A)~%" - (vm:floating-point-modes) (get-floating-point-modes)) - (format *debug-io* "new modes: #x~x (~A)~%" - new-modes (decode-floating-point-modes new-modes))) - #+nil - (setf (vm:floating-point-modes) new-modes)) + (multiple-value-bind (fop operands) (let ((sym (find-symbol "GET-FP-OPERANDS" "VM"))) (if (fboundp sym) (funcall sym (alien:sap-alien scp (* unix:sigcontext)) modes) (values nil nil))) - (cond ((not (zerop (logand float-divide-by-zero-trap-bit traps))) - (error 'division-by-zero - :operation fop - :operands operands)) - ((not (zerop (logand float-invalid-trap-bit traps))) - (error 'floating-point-invalid-operation - :operation fop - :operands operands)) - ((not (zerop (logand float-overflow-trap-bit traps))) - (error 'floating-point-overflow - :operation fop - :operands operands)) - ((not (zerop (logand float-underflow-trap-bit traps))) - (error 'floating-point-underflow - :operation fop - :operands operands)) - ((not (zerop (logand float-inexact-trap-bit traps))) - (error 'floating-point-inexact - :operation fop - :operands operands)) - #+x86 - ((not (zerop (logand float-denormal-trap-bit traps))) - (error 'floating-point-denormal-operand - :operation fop - :operands operands)) - (t - ;; It looks like the sigcontext on Solaris/x86 doesn't - ;; actually save the status word of the FPU. The - ;; operands also seem to be missing. Signal a general - ;; arithmetic error. - #+(and x86 solaris) - (error _"SIGFPE with no exceptions currently enabled? (si-code = ~D)" - code) - ;; For all other x86 ports, we should only get here if - ;; the SIGFPE was caused by an integer overflow on - ;; division. For sparc and ppc, I (rtoy) don't think - ;; there's any other way to get here since integer - ;; overflows aren't signaled. - ;; - ;; In that case, FOP should be /, so we can generate a - ;; nice arithmetic-error. It's possible to use CODE, - ;; which is supposed to indicate what caused the - ;; exception, but each OS is different, so we don't; FOP - ;; can tell us. - #-(and x86 solaris) - (if fop - (error 'arithmetic-error - :operation fop - :operands operands) - (error _"SIGFPE with no exceptions currently enabled? (si-code = ~D)" - code))))))) + ;; Don't let throws get away without resetting the + ;; floating-point modes back to the original values which we get + ;; from the sigcontext. Because we can throw, we never return + ;; from the signal handler so the sigcontext is never restored. + ;; This means we need to restore the fpu state ourselves. + (unwind-protect + (cond ((not (zerop (logand float-divide-by-zero-trap-bit traps))) + (error 'division-by-zero + :operation fop + :operands operands)) + ((not (zerop (logand float-invalid-trap-bit traps))) + (error 'floating-point-invalid-operation + :operation fop + :operands operands)) + ((not (zerop (logand float-overflow-trap-bit traps))) + (error 'floating-point-overflow + :operation fop + :operands operands)) + ((not (zerop (logand float-underflow-trap-bit traps))) + (error 'floating-point-underflow + :operation fop + :operands operands)) + ((not (zerop (logand float-inexact-trap-bit traps))) + (error 'floating-point-inexact + :operation fop + :operands operands)) + #+x86 + ((not (zerop (logand float-denormal-trap-bit traps))) + (error 'floating-point-denormal-operand + :operation fop + :operands operands)) + (t + ;; It looks like the sigcontext on Solaris/x86 doesn't + ;; actually save the status word of the FPU. The + ;; operands also seem to be missing. Signal a general + ;; arithmetic error. + #+(and x86 solaris) + (error _"SIGFPE with no exceptions currently enabled? (si-code = ~D)" + code) + ;; For all other x86 ports, we should only get here if + ;; the SIGFPE was caused by an integer overflow on + ;; division. For sparc and ppc, I (rtoy) don't think + ;; there's any other way to get here since integer + ;; overflows aren't signaled. + ;; + ;; In that case, FOP should be /, so we can generate a + ;; nice arithmetic-error. It's possible to use CODE, + ;; which is supposed to indicate what caused the + ;; exception, but each OS is different, so we don't; FOP + ;; can tell us. + #-(and x86 solaris) + (if fop + (error 'arithmetic-error + :operation fop + :operands operands) + (error _"SIGFPE with no exceptions currently enabled? (si-code = ~D)" + code)))) + ;; Cleanup + #+(and darwin ppc) + (let* ((new-modes modes) + (new-exceptions (logandc2 (ldb float-exceptions-byte new-modes) + traps))) + ;; (format t "sigfpe: modes = #B~32,'0b~%" modes) + ;; (format t "sigfpe: new-exc = #B~32,'0b~%" new-exceptions) + (setf (ldb float-exceptions-byte new-modes) new-exceptions) + ;; Clear out all exceptions and save them to the context. + ;; + ;; XXX: Should we just clear out the bits for the traps that are + ;; enabled? If we did that then the accrued exceptions would be + ;; correct. + (setf (ldb float-sticky-bits new-modes) 0) + ;; Clear out the various sticky invalid operation bits too. + ;; + ;; XXX: Should we only do that if the invalid trap is enabled? + (setf (ldb float-invalid-op-1-byte new-modes) 0) + (setf (ldb float-invalid-op-2-byte new-modes) 0) + ;; Clear the FP exception summary bit too. + (setf (ldb float-exceptions-summary-byte new-modes) 0) + ;; (format t "sigfpe: new modes = #B~32,'0b~%" new-modes) + (setf (floating-point-modes) new-modes) + #+nil + (setf (sigcontext-floating-point-modes + (alien:sap-alien scp (* unix:sigcontext))) + new-modes)) + + #+sse2 + (let* ((new-modes modes) + (new-exceptions (logandc2 (ldb float-exceptions-byte new-modes) + traps))) + ;; Clear out the status for any enabled traps. With SSE2, if + ;; the current exception is enabled, the next FP instruction + ;; will cause the exception to be signaled again. Hence, we + ;; need to clear out the exceptions that we are handling here. + (setf (ldb float-exceptions-byte new-modes) new-exceptions) + ;; XXX: This seems not right. Shouldn't we be setting the modes + ;; in the sigcontext instead? This however seems to do what we + ;; want. + + (when *debug-sigfpe-handler* + (format *debug-io* "sigcontext modes: #x~4x (~A)~%" + modes (decode-floating-point-modes modes)) + (format *debug-io* "current modes: #x~4x (~A)~%" + (vm:floating-point-modes) (get-floating-point-modes)) + (format *debug-io* "new modes: #x~x (~A)~%" + new-modes (decode-floating-point-modes new-modes))) + (setf (vm:floating-point-modes) new-modes)))))) (macrolet ((with-float-traps (name merge-traps docstring) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/d7850f57887c6762fcb6c79a5…

1 0

[Git][cmucl/cmucl][rtoy-15-handle-fpu-exceptions] In WITH-FLOAT-TRAPS-*, remove the unused junk modifying the state.
by Raymond Toy 10 Jan '16

10 Jan '16

Raymond Toy pushed to branch rtoy-15-handle-fpu-exceptions at cmucl / cmucl Commits: d9763e90 by Raymond Toy at 2016-01-10T15:42:41Z In WITH-FLOAT-TRAPS-*, remove the unused junk modifying the state. We just want to return the original modes, so remove all the old commented out stuff that was modifying the original modes to some strange state. This makes a lot more sense to me if WITH-FLOAT-TRAPS-* actually restored the modes exactly as they were before running the body. - - - - - 1 changed file: - src/code/float-trap.lisp Changes: ===================================== src/code/float-trap.lisp ===================================== --- a/src/code/float-trap.lisp +++ b/src/code/float-trap.lisp @@ -451,6 +451,10 @@ ;; representing the invalid operation. Otherwise, if we ;; enable the invalid trap later, these sticky bits will cause ;; an exception. + ;; + ;; FIXME: Consider removing these for ppc. Since + ;; we now restore the original modes exactly, I + ;; don't think these are needed anymore. #+ppc (invalid-mask (if (member :invalid traps) (dpb 0 @@ -467,21 +471,8 @@ (logand (,',merge-traps ,orig-modes ,trap-mask) ,exception-mask))) ,@body) - ;; Restore the original traps and exceptions. - (format *debug-io* "Saved fpu mode: #x~4,'0x: ~S~%" - ,orig-modes (decode-floating-point-modes ,orig-modes)) - (format *debug-io* "Current fpu mode: #x~4,'0x: ~S~%" - (floating-point-modes) (get-floating-point-modes)) - #+nil - (setf (floating-point-modes) - (logior (logand ,orig-modes ,(logior traps exceptions)) - (logand ,orig-modes - ,(logand trap-mask exception-mask) - #+ppc - ,invalid-mask - #+mips ,(dpb 0 float-exceptions-byte #xffffffff)))) - (setf (floating-point-modes) ,orig-modes) - )))))))) + ;; Restore the modes exactly as they were. + (setf (floating-point-modes) ,orig-modes))))))))) ;; WITH-FLOAT-TRAPS-MASKED -- Public (with-float-traps masked logand View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/d9763e9075310cfbbae3f43f0…

1 0

[Git][cmucl/cmucl][rtoy-15-handle-fpu-exceptions] Handle FPU exceptions better.
by Raymond Toy 10 Jan '16

10 Jan '16

Raymond Toy pushed to branch rtoy-15-handle-fpu-exceptions at cmucl / cmucl Commits: da2ff74d by Raymond Toy at 2016-01-10T14:13:10Z Handle FPU exceptions better. In sigfpe-handler, don't modify the modes; just use whatever they are. (They should be the default values.) In with-float-traps-*, actually just restore the floating-point mode to the exact original mode instead of trying to mask things out. - - - - - 1 changed file: - src/code/float-trap.lisp Changes: ===================================== src/code/float-trap.lisp ===================================== --- a/src/code/float-trap.lisp +++ b/src/code/float-trap.lisp @@ -312,6 +312,8 @@ ;;; ;;; Signal the appropriate condition when we get a floating-point error. ;;; +#+nil +(defvar *debug-sigfpe-handler* nil) (defun sigfpe-handler (signal code scp) (declare (ignore signal) (type system-area-pointer scp)) @@ -345,7 +347,7 @@ (alien:sap-alien scp (* unix:sigcontext))) new-modes)) - #+sse2 + #+nil (let* ((new-modes modes) (new-exceptions (logandc2 (ldb float-exceptions-byte new-modes) traps))) @@ -358,12 +360,13 @@ ;; in the sigcontext instead? This however seems to do what we ;; want. - (format *debug-io* "sigcontext modes: #x~4x (~A)~%" - modes (decode-floating-point-modes modes)) - (format *debug-io* "current modes: #x~4x (~A)~%" - (vm:floating-point-modes) (get-floating-point-modes)) - (format *debug-io* "new modes: #x~x (~A)~%" - new-modes (decode-floating-point-modes new-modes)) + (when *debug-sigfpe-handler* + (format *debug-io* "sigcontext modes: #x~4x (~A)~%" + modes (decode-floating-point-modes modes)) + (format *debug-io* "current modes: #x~4x (~A)~%" + (vm:floating-point-modes) (get-floating-point-modes)) + (format *debug-io* "new modes: #x~x (~A)~%" + new-modes (decode-floating-point-modes new-modes))) #+nil (setf (vm:floating-point-modes) new-modes)) @@ -465,13 +468,20 @@ ,exception-mask))) ,@body) ;; Restore the original traps and exceptions. + (format *debug-io* "Saved fpu mode: #x~4,'0x: ~S~%" + ,orig-modes (decode-floating-point-modes ,orig-modes)) + (format *debug-io* "Current fpu mode: #x~4,'0x: ~S~%" + (floating-point-modes) (get-floating-point-modes)) + #+nil (setf (floating-point-modes) (logior (logand ,orig-modes ,(logior traps exceptions)) - (logand (floating-point-modes) + (logand ,orig-modes ,(logand trap-mask exception-mask) #+ppc ,invalid-mask - #+mips ,(dpb 0 float-exceptions-byte #xffffffff)))))))))))) + #+mips ,(dpb 0 float-exceptions-byte #xffffffff)))) + (setf (floating-point-modes) ,orig-modes) + )))))))) ;; WITH-FLOAT-TRAPS-MASKED -- Public (with-float-traps masked logand View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/da2ff74d54707ab52b4b61675…

1 0

[Git][cmucl/cmucl] Pushed new branch rtoy-15-handle-fpu-exceptions
by Raymond Toy 10 Jan '16

10 Jan '16

Raymond Toy pushed new branch rtoy-15-handle-fpu-exceptions at cmucl / cmucl

1 0

[Git][cmucl/cmucl][master] Add list of features to README.
by Raymond Toy 09 Jan '16

09 Jan '16

Raymond Toy pushed to branch master at cmucl / cmucl Commits: 5c10ab93 by Raymond Toy at 2016-01-09T10:50:21Z Add list of features to README. (Taken from the wiki intro.) - - - - - 1 changed file: - README.md Changes: ===================================== README.md ===================================== --- a/README.md +++ b/README.md @@ -8,3 +8,45 @@ debugger and code profiler; and an Emacs-like editor implemented in Common Lisp. CMUCL is maintained by a team of volunteers collaborating over the Internet, and is mostly in the public domain. +Here is a summary of its main features: + +* support for **static arrays** that are never moved by GC but are + properly removed when no longer referenced. +* **Unicode** support, including many of the most common external + formats such as UTF-8 and support for handling Unix, DOS, and + Mac end-of-line schemes. +* native **double-double floats** including complex double-double + floats and specialized arrays for double-double floats and and + complex double-double floats that give approximately 106 bits + (32 digits) of precision. +* a **sophisticated native-code compiler** which is capable of + powerful type inferences, and generates code competitive in + speed with C compilers. +* **generational garbage collection** on all supported + architectures. +* **multiprocessing capability** on the x86 ports. +* a foreign function interface which allows interfacing with C code + and system libraries, including shared libraries on most platforms, + and direct access to Unix system calls. +* support for interprocess communication and remote procedure calls. +* an implementation of CLOS, the [Common Lisp Object + System](http://en.wikipedia.org/wiki/Common_Lisp_Object_System), + which includes multimethods and a metaobject protocol. +* a graphical source-level debugger using a Motif interface, and a + code profiler. +* an interface to the X11 Window System (CLX), and a sophisticated + graphical widget library ([Garnet](https://www.cs.cmu.edu/~garnet/), + available separately). +* programmer-extensible input and output streams ([Gray + Streams](http://www.nhplace.com/kent/CL/Issues/stream-definition-by-user.ht… + and + [simple-streams](http://www.franz.com/support/documentation/current/doc/stre…) +* an Emacs-like editor, + [Hemlock](http://cmucl.org/hemlock/index.html), implemented in + Common Lisp. +* **freely redistributable**: free, with full source code (most of + which is in the public domain) and no strings attached (and no + warranty). Like the GNU/Linux and *BSD operating systems, CMUCL is + maintained and improved by a team of volunteers collaborating over + the Internet. + View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/5c10ab93105fa6e095bbcbb05…

1 0

[Git][cmucl/cmucl] Pushed new tag snapshot-2016-01
by Raymond Toy 09 Jan '16

09 Jan '16

Raymond Toy pushed new tag snapshot-2016-01 at cmucl / cmucl

1 0

[Git][cmucl/cmucl][master] Fix bug in setting max heap size on sparc.
by Raymond Toy 09 Jan '16

09 Jan '16

Raymond Toy pushed to branch master at cmucl / cmucl Commits: 7fe61a25 by Raymond Toy at 2016-01-09T09:43:13Z Fix bug in setting max heap size on sparc. Forgot to put in an else clause if the specified size was 0. - - - - - 1 changed file: - src/lisp/lisp.c Changes: ===================================== src/lisp/lisp.c ===================================== --- a/src/lisp/lisp.c +++ b/src/lisp/lisp.c @@ -657,8 +657,9 @@ main(int argc, const char *argv[], const char *envp[]) } if (dynamic_space_size == 0) { dynamic_space_size = DYNAMIC_SPACE_SIZE; - } - dynamic_space_size *= 1024 * 1024; + } else { + dynamic_space_size *= 1024 * 1024; + } } #endif if (dynamic_space_size > DYNAMIC_SPACE_SIZE) { View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/7fe61a2535a4866f8d5b359a0…

1 0

[Git][cmucl/cmucl][master] 2 commits: Update to asdf 3.1.6.9 to get one fix for cmucl.
by Raymond Toy 09 Jan '16

09 Jan '16

Raymond Toy pushed to branch master at cmucl / cmucl Commits: d437c0f6 by Raymond Toy at 2016-01-09T01:29:32Z Update to asdf 3.1.6.9 to get one fix for cmucl. - - - - - ccabe7f8 by Raymond Toy at 2016-01-09T01:29:32Z Update from logs - - - - - 5 changed files: - src/contrib/asdf/asdf.lisp - src/contrib/asdf/doc/asdf.html - src/contrib/asdf/doc/asdf.info - src/contrib/asdf/doc/asdf.pdf - src/general-info/release-21b.txt Changes: ===================================== src/contrib/asdf/asdf.lisp ===================================== --- a/src/contrib/asdf/asdf.lisp +++ b/src/contrib/asdf/asdf.lisp @@ -1,5 +1,5 @@ -;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; buffer-read-only: t; -*- -;;; This is ASDF 3.1.6: Another System Definition Facility. +;;; -*- mode: Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; buffer-read-only: t; -*- +;;; This is ASDF 3.1.6.9: Another System Definition Facility. ;;; ;;; Feedback, bug reports, and patches are all welcome: ;;; please mail to <asdf-devel(a)common-lisp.net>. @@ -46,43 +46,6 @@ ;;; we can't use defsystem to compile it. Hence, all in one file. #+xcvb (module ()) - -(in-package :cl-user) - -#+cmu -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf ext:*gc-verbose* nil)) - -;;; pre 1.3.0 ABCL versions do not support the bundle-op on Mac OS X -#+abcl -(eval-when (:load-toplevel :compile-toplevel :execute) - (unless (and (member :darwin *features*) - (second (third (sys::arglist 'directory)))) - (push :abcl-bundle-op-supported *features*))) - -;; Punt on hard package upgrade: from ASDF1 always, and even from ASDF2 on most implementations. -(eval-when (:load-toplevel :compile-toplevel :execute) - (unless (member :asdf3 *features*) - (let* ((existing-version - (when (find-package :asdf) - (or (symbol-value (find-symbol (string :*asdf-version*) :asdf)) - (let ((ver (symbol-value (find-symbol (string :*asdf-revision*) :asdf)))) - (etypecase ver - (string ver) - (cons (format nil "~{~D~^.~}" ver)) - (null "1.0")))))) - (first-dot (when existing-version (position #\. existing-version))) - (second-dot (when first-dot (position #\. existing-version :start (1+ first-dot)))) - (existing-major-minor (subseq existing-version 0 second-dot)) - (existing-version-number (and existing-version (read-from-string existing-major-minor))) - (away (format nil "~A-~A" :asdf existing-version))) - (when (and existing-version - (< existing-version-number - #+(or allegro clisp lispworks sbcl) 2.0 - #-(or allegro clisp lispworks sbcl) 2.27)) - (rename-package :asdf away) - (when *load-verbose* - (format t "~&; Renamed old ~A package away to ~A~%" :asdf away)))))) ;;;; --------------------------------------------------------------------------- ;;;; Handle ASDF package upgrade, including implementation-dependent magic. ;; @@ -822,19 +785,6 @@ UNINTERN -- Remove symbols here from PACKAGE." #+(or clasp ecl gcl mkcl) (defpackage ,package (:use)) (eval-when (:compile-toplevel :load-toplevel :execute) ,ensure-form)))) - -;;;; Final tricks to keep various implementations happy. -;; We want most such tricks in common-lisp.lisp, -;; but these need to be done before the define-package form there, -;; that we nevertheless want to be the very first form. -(eval-when (:load-toplevel :compile-toplevel :execute) - #+allegro ;; We need to disable autoloading BEFORE any mention of package ASDF. - (setf excl::*autoload-package-name-alist* - (remove "asdf" excl::*autoload-package-name-alist* - :test 'equalp :key 'car))) - -;; Compatibility with whoever calls asdf/package -(define-package :asdf/package (:use :cl :uiop/package) (:reexport :uiop/package)) ;;;; ------------------------------------------------------------------------- ;;;; Handle compatibility with multiple implementations. ;;; This file is for papering over the deficiencies and peculiarities @@ -844,10 +794,9 @@ UNINTERN -- Remove symbols here from PACKAGE." ;;; from this package only common-lisp symbols are exported. (uiop/package:define-package :uiop/common-lisp - (:nicknames :uoip/cl :asdf/common-lisp :asdf/cl) + (:nicknames :uoip/cl) (:use :uiop/package) (:use-reexport #-genera :common-lisp #+genera :future-common-lisp) - (:recycle :uiop/common-lisp :uoip/cl :asdf/common-lisp :asdf/cl :asdf) #+allegro (:intern #:*acl-warn-save*) #+cormanlisp (:shadow #:user-homedir-pathname) #+cormanlisp @@ -856,10 +805,10 @@ UNINTERN -- Remove symbols here from PACKAGE." #:make-broadcast-stream #:file-namestring) #+genera (:shadowing-import-from :scl #:boolean) #+genera (:export #:boolean #:ensure-directories-exist #:read-sequence #:write-sequence) - #+mcl (:shadow #:user-homedir-pathname)) + #+(or mcl cmucl) (:shadow #:user-homedir-pathname)) (in-package :uiop/common-lisp) -#-(or abcl allegro clasp clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl mkcl sbcl scl xcl) +#-(or abcl allegro clasp clisp clozure cmucl cormanlisp ecl gcl genera lispworks mcl mkcl sbcl scl xcl) (error "ASDF is not supported on your implementation. Please help us port it.") ;; (declaim (optimize (speed 1) (debug 3) (safety 3))) ; DON'T: trust implementation defaults. @@ -867,17 +816,23 @@ UNINTERN -- Remove symbols here from PACKAGE." ;;;; Early meta-level tweaks -#+(or abcl allegro clasp clisp cmu ecl mkcl clozure lispworks mkcl sbcl scl) +#+(or allegro clasp clisp cmucl ecl mkcl mkcl sbcl) (eval-when (:load-toplevel :compile-toplevel :execute) - ;; Check for unicode at runtime, so that a hypothetical FASL compiled with unicode - ;; but loaded in a non-unicode setting (e.g. on Allegro) won't tell a lie. (when (and #+allegro (member :ics *features*) - #+(or clasp clisp cmu ecl mkcl) (member :unicode *features*) + #+(or clasp clisp cmucl ecl mkcl) (member :unicode *features*) #+sbcl (member :sb-unicode *features*)) + ;; Check for unicode at runtime, so that a hypothetical FASL compiled with unicode + ;; but loaded in a non-unicode setting (e.g. on Allegro) won't tell a lie. (pushnew :asdf-unicode *features*))) #+allegro (eval-when (:load-toplevel :compile-toplevel :execute) + ;; We need to disable autoloading BEFORE any mention of package ASDF. + ;; In particular, there must NOT be a mention of package ASDF in the defpackage of this file + ;; or any previous file. + (setf excl::*autoload-package-name-alist* + (remove "asdf" excl::*autoload-package-name-alist* + :test 'equalp :key 'car)) (defparameter *acl-warn-save* (when (boundp 'excl:*warn-on-nested-reader-conditionals*) excl:*warn-on-nested-reader-conditionals*)) @@ -901,7 +856,13 @@ UNINTERN -- Remove symbols here from PACKAGE." (wait-on-semaphore (external-process-completed proc)))) (values (external-process-%exit-code proc) (external-process-%status proc)))))) -#+clozure (in-package :uiop/common-lisp) +#+clozure (in-package :uiop/common-lisp) ;; back in this package. + +#+cmucl +(eval-when (:load-toplevel :compile-toplevel :execute) + (setf ext:*gc-verbose* nil) + (defun user-homedir-pathname () + (first (ext:search-list (cl:user-homedir-pathname))))) #+cormanlisp (eval-when (:load-toplevel :compile-toplevel :execute) @@ -1035,8 +996,6 @@ Return a string made of the parts not omitted or emitted by FROB." ;;;; General Purpose Utilities for ASDF (uiop/package:define-package :uiop/utility - (:nicknames :asdf/utility) - (:recycle :uiop/utility :asdf/utility :asdf) (:use :uiop/common-lisp :uiop/package) ;; import and reexport a few things defined in :uiop/common-lisp (:import-from :uiop/common-lisp #:compatfmt #:loop* #:frob-substrings @@ -1618,11 +1577,11 @@ with later being determined by a lexicographical comparison of minor numbers." #+allegro 'excl::format-control #+clisp 'system::$format-control #+clozure 'ccl::format-control - #+(or cmu scl) 'conditions::format-control + #+(or cmucl scl) 'conditions::format-control #+(or clasp ecl mkcl) 'si::format-control #+(or gcl lispworks) 'conditions::format-string #+sbcl 'sb-kernel:format-control - #-(or abcl allegro clasp clisp clozure cmu ecl gcl lispworks mkcl sbcl scl) nil + #-(or abcl allegro clasp clisp clozure cmucl ecl gcl lispworks mkcl sbcl scl) nil "Name of the slot for FORMAT-CONTROL in simple-condition") (defun match-condition-p (x condition) @@ -1637,7 +1596,7 @@ or a string describing the format-control of a simple-condition." (function (funcall x condition)) (string (and (typep condition 'simple-condition) ;; On SBCL, it's always set and the check triggers a warning - #+(or allegro clozure cmu lispworks scl) + #+(or allegro clozure cmucl lispworks scl) (slot-boundp condition +simple-condition-format-control-slot+) (ignore-errors (equal (simple-condition-format-control condition) x)))))) @@ -1659,8 +1618,6 @@ or a string describing the format-control of a simple-condition." ;;;; Access to the Operating System (uiop/package:define-package :uiop/os - (:nicknames :asdf/os) - (:recycle :uiop/os :asdf/os :asdf) (:use :uiop/common-lisp :uiop/package :uiop/utility) (:export #:featurep #:os-unix-p #:os-macosx-p #:os-windows-p #:os-genera-p #:detect-os ;; features @@ -1744,7 +1701,7 @@ use getenvp to return NIL in such a case." #+(or abcl clasp clisp ecl xcl) (ext:getenv x) #+allegro (sys:getenv x) #+clozure (ccl:getenv x) - #+cmu (unix:unix-getenv x) + #+cmucl (unix:unix-getenv x) #+scl (cdr (assoc x ext:*environment-list* :test #'string=)) #+cormanlisp (let* ((buffer (ct:malloc 1)) @@ -1765,7 +1722,7 @@ use getenvp to return NIL in such a case." (ccl:%get-cstring value)))) #+mkcl (#.(or (find-symbol* 'getenv :si nil) (find-symbol* 'getenv :mk-ext nil)) x) #+sbcl (sb-ext:posix-getenv x) - #-(or abcl allegro clasp clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl mkcl sbcl scl xcl) + #-(or abcl allegro clasp clisp clozure cmucl cormanlisp ecl gcl genera lispworks mcl mkcl sbcl scl xcl) (error "~S is not supported on your implementation" 'getenv)) (defsetf getenv (x) (val) @@ -1774,12 +1731,12 @@ use getenvp to return NIL in such a case." #+allegro `(setf (sys:getenv ,x) ,val) #+clisp `(system::setenv ,x ,val) #+clozure `(ccl:setenv ,x ,val) - #+cmu `(unix:unix-setenv ,x ,val 1) + #+cmucl `(unix:unix-setenv ,x ,val 1) #+ecl `(ext:setenv ,x ,val) #+lispworks `(hcl:setenv ,x ,val) #+mkcl `(mkcl:setenv ,x ,val) #+sbcl `(progn (require :sb-posix) (symbol-call :sb-posix :setenv ,x ,val 1)) - #-(or allegro clisp clozure cmu ecl lispworks mkcl sbcl) + #-(or allegro clisp clozure cmucl ecl lispworks mkcl sbcl) '(error "~S ~S is not supported on your implementation" 'setf 'getenv)) (defun getenvp (x) @@ -1871,7 +1828,7 @@ then returning the non-empty string value of the variable" ccl::*openmcl-major-version* ccl::*openmcl-minor-version* (logand (ccl-fasl-version) #xFF)) - #+cmu (substitute #\- #\/ s) + #+cmucl (substitute #\- #\/ s) #+scl (format nil "~A~A" s ;; ANSI upper case vs lower case. (ecase ext:*case-mode* (:upper "") (:lower "l"))) @@ -1905,7 +1862,7 @@ suitable for use as a directory name to segregate Lisp FASLs, C dynamic librarie (defun hostname () "return the hostname of the current host" ;; Note: untested on RMCL - #+(or abcl clasp clozure cmu ecl genera lispworks mcl mkcl sbcl scl xcl) (machine-instance) + #+(or abcl clasp clozure cmucl ecl genera lispworks mcl mkcl sbcl scl xcl) (machine-instance) #+cormanlisp "localhost" ;; is there a better way? Does it matter? #+allegro (symbol-call :excl.osi :gethostname) #+clisp (first (split-string (machine-instance) :separator " ")) @@ -1915,7 +1872,7 @@ suitable for use as a directory name to segregate Lisp FASLs, C dynamic librarie ;;; Current directory (with-upgradability () - #+cmu + #+cmucl (defun parse-unix-namestring* (unix-namestring) "variant of LISP::PARSE-UNIX-NAMESTRING that returns a pathname object" (multiple-value-bind (host device directory name type version) @@ -1929,7 +1886,7 @@ suitable for use as a directory name to segregate Lisp FASLs, C dynamic librarie #+allegro (excl::current-directory) #+clisp (ext:default-directory) #+clozure (ccl:current-directory) - #+(or cmu scl) (#+cmu parse-unix-namestring* #+scl lisp::parse-unix-namestring + #+(or cmucl scl) (#+cmucl parse-unix-namestring* #+scl lisp::parse-unix-namestring (strcat (nth-value 1 (unix:unix-current-directory)) "/")) #+cormanlisp (pathname (pl::get-current-directory)) ;; Q: what type does it return? #+(or clasp ecl) (ext:getcwd) @@ -1947,7 +1904,7 @@ suitable for use as a directory name to segregate Lisp FASLs, C dynamic librarie #+allegro (excl:chdir x) #+clisp (ext:cd x) #+clozure (setf (ccl:current-directory) x) - #+(or cmu scl) (unix:unix-chdir (ext:unix-namestring x)) + #+(or cmucl scl) (unix:unix-chdir (ext:unix-namestring x)) #+cormanlisp (unless (zerop (win32::_chdir (namestring x))) (error "Could not set current directory to ~A" x)) #+(or clasp ecl) (ext:chdir x) @@ -1955,7 +1912,7 @@ suitable for use as a directory name to segregate Lisp FASLs, C dynamic librarie #+lispworks (hcl:change-directory x) #+mkcl (mk-ext:chdir x) #+sbcl (progn (require :sb-posix) (symbol-call :sb-posix :chdir (sb-ext:native-namestring x))) - #-(or abcl allegro clasp clisp clozure cmu cormanlisp ecl gcl genera lispworks mkcl sbcl scl xcl) + #-(or abcl allegro clasp clisp clozure cmucl cormanlisp ecl gcl genera lispworks mkcl sbcl scl xcl) (error "chdir not supported on your implementation")))) @@ -2048,8 +2005,7 @@ the number having BYTES octets (defaulting to 4)." ;; which all is necessary prior to any access the filesystem or environment. (uiop/package:define-package :uiop/pathname - (:nicknames :asdf/pathname) - (:recycle :uiop/pathname :asdf/pathname :asdf) + (:nicknames :asdf/pathname) ;; deprecated. Used by ceramic (:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/os) (:export ;; Making and merging pathnames, portably @@ -2092,7 +2048,7 @@ the number having BYTES octets (defaulting to 4)." implementation's MAKE-PATHNAME and other primitives to a CLHS-standard format that is a list and not a string." (cond - #-(or cmu sbcl scl) ;; these implementations already normalize directory components. + #-(or cmucl sbcl scl) ;; these implementations already normalize directory components. ((stringp directory) `(:absolute ,directory)) ((or (null directory) (and (consp directory) (member (first directory) '(:absolute :relative)))) @@ -2135,22 +2091,17 @@ by the underlying implementation's MAKE-PATHNAME and other primitives" ;; See CLHS make-pathname and 19.2.2.2.3. ;; This will be :unspecific if supported, or NIL if not. (defparameter *unspecific-pathname-type* - #+(or abcl allegro clozure cmu genera lispworks sbcl scl) :unspecific + #+(or abcl allegro clozure cmucl genera lispworks sbcl scl) :unspecific #+(or clasp clisp ecl mkcl gcl xcl #|These haven't been tested:|# cormanlisp mcl) nil "Unspecific type component to use with the underlying implementation's MAKE-PATHNAME") - (defun make-pathname* (&rest keys &key (directory nil) - host (device () #+allegro devicep) name type version defaults + (defun make-pathname* (&rest keys &key directory host device name type version defaults #+scl &allow-other-keys) "Takes arguments like CL:MAKE-PATHNAME in the CLHS, and tries hard to make a pathname that will actually behave as documented, - despite the peculiarities of each implementation" - ;; TODO: reimplement defaulting for MCL, whereby an explicit NIL should override the defaults. - (declare (ignorable host device directory name type version defaults)) - (apply 'make-pathname - (append - #+allegro (when (and devicep (null device)) `(:device :unspecific)) - keys))) + despite the peculiarities of each implementation. DEPRECATED: just use MAKE-PATHNAME." + (declare (ignore host device directory name type version defaults)) + (apply 'make-pathname keys)) (defun make-pathname-component-logical (x) "Make a pathname component suitable for use in a logical-pathname" @@ -2163,7 +2114,7 @@ by the underlying implementation's MAKE-PATHNAME and other primitives" (defun make-pathname-logical (pathname host) "Take a PATHNAME's directory, name, type and version components, and make a new pathname with corresponding components and specified logical HOST" - (make-pathname* + (make-pathname :host host :directory (make-pathname-component-logical (pathname-directory pathname)) :name (make-pathname-component-logical (pathname-name pathname)) @@ -2206,10 +2157,10 @@ by default *DEFAULT-PATHNAME-DEFAULTS*, which cannot be NIL." (pathname-device defaults) (merge-pathname-directory-components directory (pathname-directory defaults)) (unspecific-handler defaults)))) - (make-pathname* :host host :device device :directory directory - :name (funcall unspecific-handler name) - :type (funcall unspecific-handler type) - :version (funcall unspecific-handler version)))))) + (make-pathname :host host :device device :directory directory + :name (funcall unspecific-handler name) + :type (funcall unspecific-handler type) + :version (funcall unspecific-handler version)))))) (defun logical-pathname-p (x) "is X a logical-pathname?" @@ -2234,13 +2185,13 @@ when merging, making or parsing pathnames" ;; But CMUCL decides to die on NIL. ;; MCL has issues with make-pathname, nil and defaulting (declare (ignorable defaults)) - #.`(make-pathname* :directory nil :name nil :type nil :version nil - :device (or #+(and mkcl unix) :unspecific) - :host (or #+cmu lisp::*unix-host* #+(and mkcl unix) "localhost") - #+scl ,@'(:scheme nil :scheme-specific-part nil - :username nil :password nil :parameters nil :query nil :fragment nil) - ;; the default shouldn't matter, but we really want something physical - #-mcl ,@'(:defaults defaults))) + #.`(make-pathname :directory nil :name nil :type nil :version nil + :device (or #+(and mkcl unix) :unspecific) + :host (or #+cmucl lisp::*unix-host* #+(and mkcl unix) "localhost") + #+scl ,@'(:scheme nil :scheme-specific-part nil + :username nil :password nil :parameters nil :query nil :fragment nil) + ;; the default shouldn't matter, but we really want something physical + #-mcl ,@'(:defaults defaults))) (defvar *nil-pathname* (nil-pathname (physicalize-pathname (user-homedir-pathname))) "A pathname that is as neutral as possible for use as defaults @@ -2318,9 +2269,9 @@ actually-existing file. Returns the (parsed) PATHNAME when true" (when pathname - (let* ((pathname (pathname pathname)) - (name (pathname-name pathname))) - (when (not (member name '(nil :unspecific "") :test 'equal)) + (let ((pathname (pathname pathname))) + (unless (and (member (pathname-name pathname) '(nil :unspecific "") :test 'equal) + (member (pathname-type pathname) '(nil :unspecific "") :test 'equal)) pathname))))) @@ -2337,10 +2288,10 @@ and NIL NAME, TYPE and VERSION components" i.e. removing one level of depth in the DIRECTORY component. e.g. if pathname is Unix pathname /foo/bar/baz/file.type then return /foo/bar/" (when pathname - (make-pathname* :name nil :type nil :version nil - :directory (merge-pathname-directory-components - '(:relative :back) (pathname-directory pathname)) - :defaults pathname))) + (make-pathname :name nil :type nil :version nil + :directory (merge-pathname-directory-components + '(:relative :back) (pathname-directory pathname)) + :defaults pathname))) (defun directory-pathname-p (pathname) "Does PATHNAME represent a directory? @@ -2375,11 +2326,11 @@ actually-existing directory." ((directory-pathname-p pathspec) pathspec) (t - (make-pathname* :directory (append (or (normalize-pathname-directory-component - (pathname-directory pathspec)) - (list :relative)) - (list (file-namestring pathspec))) - :name nil :type nil :version nil :defaults pathspec))))) + (make-pathname :directory (append (or (normalize-pathname-directory-component + (pathname-directory pathspec)) + (list :relative)) + (list (file-namestring pathspec))) + :name nil :type nil :version nil :defaults pathspec))))) ;;; Parsing filenames @@ -2512,7 +2463,7 @@ to throw an error if the pathname is absolute" (t (split-name-type filename))) (apply 'ensure-pathname - (make-pathname* + (make-pathname :directory (unless file-only (cons relative path)) :name name :type type :defaults (or #-mcl defaults *nil-pathname*)) @@ -2581,19 +2532,19 @@ then it is merged with the PATHNAME-DIRECTORY-PATHNAME of PATHNAME." (defun pathname-root (pathname) "return the root directory for the host and device of given PATHNAME" - (make-pathname* :directory '(:absolute) - :name nil :type nil :version nil - :defaults pathname ;; host device, and on scl, *some* - ;; scheme-specific parts: port username password, not others: - . #.(or #+scl '(:parameters nil :query nil :fragment nil)))) + (make-pathname :directory '(:absolute) + :name nil :type nil :version nil + :defaults pathname ;; host device, and on scl, *some* + ;; scheme-specific parts: port username password, not others: + . #.(or #+scl '(:parameters nil :query nil :fragment nil)))) (defun pathname-host-pathname (pathname) "return a pathname with the same host as given PATHNAME, and all other fields NIL" - (make-pathname* :directory nil - :name nil :type nil :version nil :device nil - :defaults pathname ;; host device, and on scl, *some* - ;; scheme-specific parts: port username password, not others: - . #.(or #+scl '(:parameters nil :query nil :fragment nil)))) + (make-pathname :directory nil + :name nil :type nil :version nil :device nil + :defaults pathname ;; host device, and on scl, *some* + ;; scheme-specific parts: port username password, not others: + . #.(or #+scl '(:parameters nil :query nil :fragment nil)))) (defun ensure-absolute-pathname (path &optional defaults (on-error 'error)) "Given a pathname designator PATH, return an absolute pathname as specified by PATH @@ -2660,12 +2611,12 @@ given DEFAULTS-PATHNAME as a base pathname." :version (or #-(or allegro abcl xcl) *wild*)) "A pathname object with wildcards for matching any file in a given directory") (defparameter *wild-directory* - (make-pathname* :directory `(:relative ,*wild-directory-component*) - :name nil :type nil :version nil) + (make-pathname :directory `(:relative ,*wild-directory-component*) + :name nil :type nil :version nil) "A pathname object with wildcards for matching any subdirectory") (defparameter *wild-inferiors* - (make-pathname* :directory `(:relative ,*wild-inferiors-component*) - :name nil :type nil :version nil) + (make-pathname :directory `(:relative ,*wild-inferiors-component*) + :name nil :type nil :version nil) "A pathname object with wildcards for matching any recursive subdirectory") (defparameter *wild-path* (merge-pathnames* *wild-file* *wild-inferiors*) @@ -2692,13 +2643,13 @@ given DEFAULTS-PATHNAME as a base pathname." (defun relativize-pathname-directory (pathspec) "Given a PATHNAME, return a relative pathname with otherwise the same components" (let ((p (pathname pathspec))) - (make-pathname* + (make-pathname :directory (relativize-directory-component (pathname-directory p)) :defaults p))) (defun directory-separator-for-host (&optional (pathname *default-pathname-defaults*)) "Given a PATHNAME, return the character used to delimit directory names on this host and device." - (let ((foo (make-pathname* :directory '(:absolute "FOO") :defaults pathname))) + (let ((foo (make-pathname :directory '(:absolute "FOO") :defaults pathname))) (last-char (namestring foo)))) #-scl @@ -2722,8 +2673,7 @@ added to its DIRECTORY component. This is useful for output translations." (multiple-value-bind (relative path filename) (split-unix-namestring-directory-components root-string :ensure-directory t) (declare (ignore relative filename)) - (let ((new-base - (make-pathname* :defaults root :directory `(:absolute ,@path)))) + (let ((new-base (make-pathname :defaults root :directory `(:absolute ,@path)))) (translate-pathname absolute-pathname wild-root (wilden new-base)))))) #+scl @@ -2745,8 +2695,8 @@ added to its DIRECTORY component. This is useful for output translations." (when (specificp scheme) (setf prefix (strcat scheme prefix))) (assert (and directory (eq (first directory) :absolute))) - (make-pathname* :directory `(:absolute ,prefix ,@(rest directory)) - :defaults pathname))) + (make-pathname :directory `(:absolute ,prefix ,@(rest directory)) + :defaults pathname))) pathname))) (defun* (translate-pathname*) (path absolute-source destination &optional root source) @@ -2785,8 +2735,6 @@ you need to still be able to use compile-op on that lisp file.")) ;;;; Portability layer around Common Lisp filesystem access (uiop/package:define-package :uiop/filesystem - (:nicknames :asdf/filesystem) - (:recycle :uiop/filesystem :asdf/pathname :asdf) (:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/os :uiop/pathname) (:export ;; Native namestrings @@ -2817,9 +2765,9 @@ you need to still be able to use compile-op on that lisp file.")) (when x (let ((p (pathname x))) #+clozure (with-pathname-defaults () (ccl:native-translated-namestring p)) ; see ccl bug 978 - #+(or cmu scl) (ext:unix-namestring p nil) + #+(or cmucl scl) (ext:unix-namestring p nil) #+sbcl (sb-ext:native-namestring p) - #-(or clozure cmu sbcl scl) + #-(or clozure cmucl sbcl scl) (os-cond ((os-unix-p) (unix-namestring p)) (t (namestring p)))))) @@ -2832,8 +2780,10 @@ a CL pathname satisfying all the specified constraints as per ENSURE-PATHNAME" (when string (with-pathname-defaults () #+clozure (ccl:native-to-pathname string) + #+cmucl (uiop/os::parse-unix-namestring* string) #+sbcl (sb-ext:parse-native-namestring string) - #-(or clozure sbcl) + #+scl (lisp::parse-unix-namestring string) + #-(or clozure cmucl sbcl scl) (os-cond ((os-unix-p) (parse-unix-namestring string :ensure-directory ensure-directory)) (t (parse-namestring string)))))) @@ -2918,10 +2868,10 @@ or the original (parsed) pathname if it is false (the default)." (if truename (probe-file p) (and - #+(or cmu scl) (unix:unix-stat (ext:unix-namestring p)) + #+(or cmucl scl) (unix:unix-stat (ext:unix-namestring p)) #+(and lispworks unix) (system:get-file-stat p) #+sbcl (sb-unix:unix-stat (sb-ext:native-namestring p)) - #-(or cmu (and lispworks unix) sbcl scl) (file-write-date p) + #-(or cmucl (and lispworks unix) sbcl scl) (file-write-date p) p)))))) (defun directory-exists-p (x) @@ -2948,7 +2898,7 @@ Try to override the defaults to not resolving symlinks, if implementation allows (append keys '#.(or #+allegro '(:directories-are-files nil :follow-symbolic-links nil) #+(or clozure digitool) '(:follow-links nil) #+clisp '(:circle t :if-does-not-exist :ignore) - #+(or cmu scl) '(:follow-links nil :truenamep nil) + #+(or cmucl scl) '(:follow-links nil :truenamep nil) #+lispworks '(:link-transparency nil) #+sbcl (when (find-symbol* :resolve-symlinks '#:sb-impl nil) '(:resolve-symlinks nil)))))) @@ -3014,9 +2964,9 @@ The behavior in presence of symlinks is not portable. Use IOlib to handle such s (let* ((directory (ensure-directory-pathname directory)) #-(or abcl cormanlisp genera xcl) (wild (merge-pathnames* - #-(or abcl allegro cmu lispworks sbcl scl xcl) + #-(or abcl allegro cmucl lispworks sbcl scl xcl) *wild-directory* - #+(or abcl allegro cmu lispworks sbcl scl xcl) "*.*" + #+(or abcl allegro cmucl lispworks sbcl scl xcl) "*.*" directory)) (dirs #-(or abcl cormanlisp genera xcl) @@ -3025,17 +2975,17 @@ The behavior in presence of symlinks is not portable. Use IOlib to handle such s #+mcl '(:directories t)))) #+(or abcl xcl) (system:list-directory directory) #+cormanlisp (cl::directory-subdirs directory) - #+genera (fs:directory-list directory)) - #+(or abcl allegro cmu genera lispworks sbcl scl xcl) + #+genera (handler-case (fs:directory-list directory) (fs:directory-not-found () nil))) + #+(or abcl allegro cmucl genera lispworks sbcl scl xcl) (dirs (loop :for x :in dirs :for d = #+(or abcl xcl) (extensions:probe-directory x) #+allegro (excl:probe-directory x) - #+(or cmu sbcl scl) (directory-pathname-p x) + #+(or cmucl sbcl scl) (directory-pathname-p x) #+genera (getf (cdr x) :directory) #+lispworks (lw:file-directory-p x) :when d :collect #+(or abcl allegro xcl) d #+genera (ensure-directory-pathname (first x)) - #+(or cmu lispworks sbcl scl) x))) + #+(or cmucl lispworks sbcl scl) x))) (filter-logical-directory-results directory dirs (let ((prefix (or (normalize-pathname-directory-component (pathname-directory directory)) @@ -3080,13 +3030,13 @@ The behavior in presence of symlinks is not portable. Use IOlib to handle such s (loop :while up-components :do (if-let (parent (ignore-errors - (probe-file* (make-pathname* :directory `(:absolute ,@(reverse up-components)) - :name nil :type nil :version nil :defaults p)))) + (probe-file* (make-pathname :directory `(:absolute ,@(reverse up-components)) + :name nil :type nil :version nil :defaults p)))) (if-let (simplified (ignore-errors (merge-pathnames* - (make-pathname* :directory `(:relative ,@down-components) - :defaults p) + (make-pathname :directory `(:relative ,@down-components) + :defaults p) (ensure-directory-pathname parent)))) (return simplified))) (push (pop up-components) down-components) @@ -3332,7 +3282,7 @@ NILs." #+(or allegro clasp ecl mkcl) #p"SYS:" ;;#+clisp custom:*lib-directory* ; causes failure in asdf-pathname-test(!) #+clozure #p"ccl:" - #+cmu (ignore-errors (pathname-parent-directory-pathname (truename #p"modules:"))) + #+cmucl (ignore-errors (pathname-parent-directory-pathname (truename #p"modules:"))) #+gcl system::*system-directory* #+lispworks lispworks:*lispworks-directory* #+sbcl (if-let (it (find-symbol* :sbcl-homedir-pathname :sb-int nil)) @@ -3386,10 +3336,10 @@ in an atomic way if the implementation allows." #+allegro (excl:delete-directory directory-pathname) #+clisp (ext:delete-directory directory-pathname) #+clozure (ccl::delete-empty-directory directory-pathname) - #+(or cmu scl) (multiple-value-bind (ok errno) + #+(or cmucl scl) (multiple-value-bind (ok errno) (unix:unix-rmdir (native-namestring directory-pathname)) (unless ok - #+cmu (error "Error number ~A when trying to delete directory ~A" + #+cmucl (error "Error number ~A when trying to delete directory ~A" errno directory-pathname) #+scl (error "~@<Error deleting ~S: ~A~@:>" directory-pathname (unix:get-unix-error-msg errno)))) @@ -3402,7 +3352,7 @@ in an atomic way if the implementation allows." `(,dd directory-pathname) ;; requires SBCL 1.0.44 or later `(progn (require :sb-posix) (symbol-call :sb-posix :rmdir directory-pathname))) #+xcl (symbol-call :uiop :run-program `("rmdir" ,(native-namestring directory-pathname))) - #-(or abcl allegro clasp clisp clozure cmu cormanlisp digitool ecl gcl genera lispworks mkcl sbcl scl xcl) + #-(or abcl allegro clasp clisp clozure cmucl cormanlisp digitool ecl gcl genera lispworks mkcl sbcl scl xcl) (error "~S not implemented on ~S" 'delete-empty-directory (implementation-type))) ; genera (defun delete-directory-tree (directory-pathname &key (validate nil validatep) (if-does-not-exist :error)) @@ -3436,7 +3386,7 @@ If you're suicidal or extremely confident, just use :VALIDATE T." (error "~S was asked to delete ~S but the directory does not exist" 'delete-directory-tree directory-pathname)) (:ignore nil))) - #-(or allegro cmu clozure genera sbcl scl) + #-(or allegro cmucl clozure genera sbcl scl) ((os-unix-p) ;; On Unix, don't recursively walk the directory and delete everything in Lisp, ;; except on implementations where we can prevent DIRECTORY from following symlinks; ;; instead spawn a standard external program to do the dirty work. @@ -3463,8 +3413,6 @@ If you're suicidal or extremely confident, just use :VALIDATE T." ;;;; Utilities related to streams (uiop/package:define-package :uiop/stream - (:nicknames :asdf/stream) - (:recycle :uiop/stream :asdf/stream :asdf) (:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/os :uiop/pathname :uiop/filesystem) (:export #:*default-stream-element-type* @@ -3495,7 +3443,7 @@ If you're suicidal or extremely confident, just use :VALIDATE T." (with-upgradability () (defvar *default-stream-element-type* - (or #+(or abcl cmu cormanlisp scl xcl) 'character + (or #+(or abcl cmucl cormanlisp scl xcl) 'character #+lispworks 'lw:simple-char :default) "default element-type for open (depends on the current CL implementation)") @@ -3506,7 +3454,7 @@ If you're suicidal or extremely confident, just use :VALIDATE T." (defun setup-stdin () (setf *stdin* #.(or #+clozure 'ccl::*stdin* - #+(or cmu scl) 'system:*stdin* + #+(or cmucl scl) 'system:*stdin* #+(or clasp ecl) 'ext::+process-standard-input+ #+sbcl 'sb-sys:*stdin* '*standard-input*))) @@ -3517,7 +3465,7 @@ If you're suicidal or extremely confident, just use :VALIDATE T." (defun setup-stdout () (setf *stdout* #.(or #+clozure 'ccl::*stdout* - #+(or cmu scl) 'system:*stdout* + #+(or cmucl scl) 'system:*stdout* #+(or clasp ecl) 'ext::+process-standard-output+ #+sbcl 'sb-sys:*stdout* '*standard-output*))) @@ -3529,7 +3477,7 @@ If you're suicidal or extremely confident, just use :VALIDATE T." (setf *stderr* #.(or #+allegro 'excl::*stderr* #+clozure 'ccl::*stderr* - #+(or cmu scl) 'system:*stderr* + #+(or cmucl scl) 'system:*stderr* #+(or clasp ecl) 'ext::+process-error-output+ #+sbcl 'sb-sys:*stderr* '*error-output*))) @@ -4027,7 +3975,7 @@ ELEMENT-TYPE (defaults to *DEFAULT-STREAM-ELEMENT-TYPE*) and EXTERNAL-FORMAT (defaults to *UTF-8-EXTERNAL-FORMAT*). If WANT-STREAM-P is true (the defaults to T), then THUNK will then be CALL-FUNCTION'ed with the stream and the pathname (if WANT-PATHNAME-P is true, defaults to T), -and stream with be closed after the THUNK exits (either normally or abnormally). +and stream will be closed after the THUNK exits (either normally or abnormally). If WANT-STREAM-P is false, then WANT-PATHAME-P must be true, and then THUNK is only CALL-FUNCTION'ed after the stream is closed, with the pathname as argument. Upon exit of THUNK, the AFTER thunk if defined is CALL-FUNCTION'ed with the pathname as argument. @@ -4164,8 +4112,6 @@ For the latter case, we ought pick a random suffix and atomically open it." ;;;; Starting, Stopping, Dumping a Lisp image (uiop/package:define-package :uiop/image - (:nicknames :asdf/image) - (:recycle :uiop/image :asdf/image :xcvb-driver) (:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/pathname :uiop/stream :uiop/os) (:export #:*image-dumped-p* #:raw-command-line-arguments #:*command-line-arguments* @@ -4231,7 +4177,7 @@ This is designed to abstract away the implementation specific quit forms." #+clisp (ext:quit code) #+clozure (ccl:quit code) #+cormanlisp (win32:exitprocess code) - #+(or cmu scl) (unix:unix-exit code) + #+(or cmucl scl) (unix:unix-exit code) #+gcl (system:quit code) #+genera (error "~S: You probably don't want to Halt Genera. (code: ~S)" 'quit code) #+lispworks (lispworks:quit :status code :confirm nil :return nil :ignore-errors-p t) @@ -4242,7 +4188,7 @@ This is designed to abstract away the implementation specific quit forms." (cond (exit `(,exit :code code :abort (not finish-output))) (quit `(,quit :unix-status code :recklessly-p (not finish-output))))) - #-(or abcl allegro clasp clisp clozure cmu ecl gcl genera lispworks mcl mkcl sbcl scl xcl) + #-(or abcl allegro clasp clisp clozure cmucl ecl gcl genera lispworks mcl mkcl sbcl scl xcl) (error "~S called with exit code ~S but there's no quitting on this implementation" 'quit code)) (defun die (code format &rest arguments) @@ -4285,7 +4231,7 @@ This is designed to abstract away the implementation specific quit forms." #+clozure (ccl:print-call-history :count count :start-frame-number 1) #+mcl (ccl:print-call-history :detailed-p nil) (finish-output stream)) - #+(or cmu scl) + #+(or cmucl scl) (let ((debug:*debug-print-level* *print-level*) (debug:*debug-print-length* *print-length*)) (debug:backtrace (or count most-positive-fixnum) stream)) @@ -4389,14 +4335,14 @@ depending on whether *LISP-INTERACTION* is set, enter debugger or die" #+(or clasp ecl) (loop :for i :from 0 :below (si:argc) :collect (si:argv i)) #+clisp (coerce (ext:argv) 'list) #+clozure ccl:*command-line-argument-list* - #+(or cmu scl) extensions:*command-line-strings* + #+(or cmucl scl) extensions:*command-line-strings* #+gcl si:*command-args* #+(or genera mcl) nil #+lispworks sys:*line-arguments-list* #+mkcl (loop :for i :from 0 :below (mkcl:argc) :collect (mkcl:argv i)) #+sbcl sb-ext:*posix-argv* #+xcl system:*argv* - #-(or abcl allegro clasp clisp clozure cmu ecl gcl genera lispworks mcl mkcl sbcl scl xcl) + #-(or abcl allegro clasp clisp clozure cmucl ecl gcl genera lispworks mcl mkcl sbcl scl xcl) (error "raw-command-line-arguments not implemented yet")) (defun command-line-arguments (&optional (arguments (raw-command-line-arguments))) @@ -4425,7 +4371,7 @@ Otherwise, return NIL." (cond ((eq *image-dumped-p* :executable) ; yes, this ARGV0 is our argv0 ! ;; NB: not currently available on ABCL, Corman, Genera, MCL - (or #+(or allegro clisp clozure cmu gcl lispworks sbcl scl xcl) + (or #+(or allegro clisp clozure cmucl gcl lispworks sbcl scl xcl) (first (raw-command-line-arguments)) #+(or clasp ecl) (si:argv 0) #+mkcl (mkcl:argv 0))) (t ;; argv[0] is the name of the interpreter. @@ -4515,7 +4461,7 @@ or COMPRESSION on SBCL, and APPLICATION-TYPE on SBCL/Windows." (setf *image-dump-hook* dump-hook) (call-image-dump-hook) (setf *image-restored-p* nil) - #-(or clisp clozure cmu lispworks sbcl scl) + #-(or clisp clozure cmucl lispworks sbcl scl) (when executable (error "Dumping an executable is not supported on this implementation! Aborting.")) #+allegro @@ -4543,13 +4489,13 @@ or COMPRESSION on SBCL, and APPLICATION-TYPE on SBCL/Windows." (funcall (fdefinition 'ccl::write-elf-symbols-to-file) path) (dump path)) (dump t))) - #+(or cmu scl) + #+(or cmucl scl) (progn (ext:gc :full t) (setf ext:*batch-mode* nil) (setf ext::*gc-run-time* 0) (apply 'ext:save-lisp filename - #+cmu :executable #+cmu t + #+cmucl :executable #+cmucl t (when executable '(:init-function restore-image :process-command-line nil)))) #+gcl (progn @@ -4572,7 +4518,7 @@ or COMPRESSION on SBCL, and APPLICATION-TYPE on SBCL/Windows." #+(and sbcl os-windows) ;; passing :application-type :gui will disable the console window. ;; the default is :console - only works with SBCL 1.1.15 or later. (when application-type (list :application-type application-type))))) - #-(or allegro clisp clozure cmu gcl lispworks sbcl scl) + #-(or allegro clisp clozure cmucl gcl lispworks sbcl scl) (error "Can't ~S ~S: UIOP doesn't support image dumping with ~A.~%" 'dump-image filename (nth-value 1 (implementation-type)))) @@ -4636,8 +4582,7 @@ or COMPRESSION on SBCL, and APPLICATION-TYPE on SBCL/Windows." ;;;; run-program initially from xcvb-driver. (uiop/package:define-package :uiop/run-program - (:nicknames :asdf/run-program) - (:recycle :uiop/run-program :asdf/run-program :xcvb-driver) + (:nicknames :asdf/run-program) ; OBSOLETE. Used by cl-sane, printv. (:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/pathname :uiop/os :uiop/filesystem :uiop/stream) (:export @@ -5554,8 +5499,7 @@ or an indication of failure via the EXIT-CODE of the process" ;;;; Support to build (compile and load) Lisp files (uiop/package:define-package :uiop/lisp-build - (:nicknames :asdf/lisp-build) - (:recycle :uiop/lisp-build :asdf/lisp-build :asdf) + (:nicknames :asdf/lisp-build) ;; OBSOLETE, used by slime/contrib/swank-asdf.lisp (:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/os :uiop/pathname :uiop/filesystem :uiop/stream :uiop/image) (:export @@ -5618,7 +5562,7 @@ This can help you produce more deterministic output for FASLs.")) #+clisp '() ;; system::*optimize* is a constant hash-table! (with non-constant contents) #+clozure '(ccl::*nx-speed* ccl::*nx-space* ccl::*nx-safety* ccl::*nx-debug* ccl::*nx-cspeed*) - #+(or cmu scl) '(c::*default-cookie*) + #+(or cmucl scl) '(c::*default-cookie*) #+(and ecl (not clasp)) (unless (use-ecl-byte-compiler-p) '(c::*speed* c::*space* c::*safety* c::*debug*)) #+clasp '() #+gcl '(compiler::*speed* compiler::*space* compiler::*compiler-new-safety* compiler::*debug*) @@ -5627,11 +5571,11 @@ This can help you produce more deterministic output for FASLs.")) #+sbcl '(sb-c::*policy*))) (defun get-optimization-settings () "Get current compiler optimization settings, ready to PROCLAIM again" - #-(or abcl allegro clasp clisp clozure cmu ecl lispworks mkcl sbcl scl xcl) + #-(or abcl allegro clasp clisp clozure cmucl ecl lispworks mkcl sbcl scl xcl) (warn "~S does not support ~S. Please help me fix that." 'get-optimization-settings (implementation-type)) - #+(or abcl allegro clasp clisp clozure cmu ecl lispworks mkcl sbcl scl xcl) - (let ((settings '(speed space safety debug compilation-speed #+(or cmu scl) c::brevity))) + #+(or abcl allegro clasp clisp clozure cmucl ecl lispworks mkcl sbcl scl xcl) + (let ((settings '(speed space safety debug compilation-speed #+(or cmucl scl) c::brevity))) #.`(loop #+(or allegro clozure) ,@'(:with info = #+allegro (sys:declaration-information 'optimize) #+clozure (ccl:declaration-information 'optimize nil)) @@ -5640,7 +5584,7 @@ This can help you produce more deterministic output for FASLs.")) :for y = (or #+(or allegro clozure) (second (assoc x info)) ; normalize order #+clisp (gethash x system::*optimize* 1) #+(or abcl clasp ecl mkcl xcl) (symbol-value v) - #+(or cmu scl) (slot-value c::*default-cookie* + #+(or cmucl scl) (slot-value c::*default-cookie* (case x (compilation-speed 'c::cspeed) (otherwise x))) #+lispworks (slot-value compiler::*optimization-level* x) @@ -5682,7 +5626,7 @@ This can help you produce more deterministic output for FASLs.")) (defvar *usual-uninteresting-conditions* (append ;;#+clozure '(ccl:compiler-warning) - #+cmu '("Deleting unreachable code.") + #+cmucl '("Deleting unreachable code.") #+lispworks '("~S being redefined in ~A (previously in ~A)." "~S defined more than once in ~A.") ;; lispworks gets confused by eval-when. #+sbcl @@ -5867,7 +5811,7 @@ Simple means made of symbols, numbers, characters, simple-strings, pathnames, co :warning-type warning-type :args (destructuring-bind (fun . more) args (cons (symbolify-function-name fun) more)))))) - #+(or cmu scl) + #+(or cmucl scl) (defun reify-undefined-warning (warning) ;; Extracting undefined-warnings from the compilation-unit ;; To be passed through the above reify/unreify link, it must be a "simple-sexp" @@ -5919,7 +5863,7 @@ WITH-COMPILATION-UNIT. One of three functions required for deferred-warnings sup (if-let (dw ccl::*outstanding-deferred-warnings*) (let ((mdw (ccl::ensure-merged-deferred-warnings dw))) (ccl::deferred-warnings.warnings mdw)))) - #+(or cmu scl) + #+(or cmucl scl) (when lisp::*in-compilation-unit* ;; Try to send nothing through the pipe if nothing needs to be accumulated `(,@(when c::*undefined-warnings* @@ -5965,7 +5909,7 @@ One of three functions required for deferred-warnings support in ASDF." (setf ccl::*outstanding-deferred-warnings* (ccl::%defer-warnings t))))) (appendf (ccl::deferred-warnings.warnings dw) (mapcar 'unreify-deferred-warning reified-deferred-warnings))) - #+(or cmu scl) + #+(or cmucl scl) (dolist (item reified-deferred-warnings) ;; Each item is (symbol . adjustment) where the adjustment depends on the symbol. ;; For *undefined-warnings*, the adjustment is a list of initargs. @@ -6028,7 +5972,7 @@ One of three functions required for deferred-warnings support in ASDF." (if-let (dw ccl::*outstanding-deferred-warnings*) (let ((mdw (ccl::ensure-merged-deferred-warnings dw))) (setf (ccl::deferred-warnings.warnings mdw) nil))) - #+(or cmu scl) + #+(or cmucl scl) (when lisp::*in-compilation-unit* (setf c::*undefined-warnings* nil c::*compiler-error-count* 0 @@ -6344,8 +6288,7 @@ it will filter them appropriately." ;;;; Generic support for configuration files (uiop/package:define-package :uiop/configuration - (:nicknames :asdf/configuration) - (:recycle :uiop/configuration :asdf/configuration :asdf) + (:recycle :uiop/configuration :asdf/configuration) ;; necessary to upgrade from 2.27. (:use :uiop/common-lisp :uiop/utility :uiop/os :uiop/pathname :uiop/filesystem :uiop/stream :uiop/image :uiop/lisp-build) (:export @@ -6541,7 +6484,7 @@ directive.") ;; but what it means to the output-translations is ;; "relative to the root of the source pathname's host and device". (return-from resolve-absolute-location - (let ((p (make-pathname* :directory '(:relative)))) + (let ((p (make-pathname :directory '(:relative)))) (if wilden (wilden p) p)))) ((eql :home) (user-homedir-pathname)) ((eql :here) (resolve-absolute-location @@ -6758,14 +6701,11 @@ objects. Side-effects for cached file location computation." ;;; Hacks for backward-compatibility of the driver (uiop/package:define-package :uiop/backward-driver - (:nicknames :asdf/backward-driver) - (:recycle :uiop/backward-driver :asdf/backward-driver :asdf) (:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/pathname :uiop/stream :uiop/os :uiop/image :uiop/run-program :uiop/lisp-build :uiop/configuration) (:export - #:coerce-pathname #:component-name-to-pathname-components - #+(or clasp ecl mkcl) #:compile-file-keeping-object + #:coerce-pathname #:user-configuration-directories #:system-configuration-directories #:in-first-directory #:in-user-configuration-directory #:in-system-configuration-directory )) @@ -6776,27 +6716,11 @@ objects. Side-effects for cached file location computation." (with-upgradability () (defun coerce-pathname (name &key type defaults) ;; For backward-compatibility only, for people using internals - ;; Reported users in quicklisp: hu.dwim.asdf, asdf-utils, xcvb - ;; Will be removed after 2014-01-16. + ;; Reported users in quicklisp 2015-11: hu.dwim.asdf (removed in next release) + ;; Will be removed after 2015-12. ;;(warn "Please don't use ASDF::COERCE-PATHNAME. Use ASDF/PATHNAME:PARSE-UNIX-NAMESTRING.") (parse-unix-namestring name :type type :defaults defaults)) - (defun component-name-to-pathname-components (unix-style-namestring - &key force-directory force-relative) - ;; Will be removed after 2014-01-16. - ;; (warn "Please don't use ASDF::COMPONENT-NAME-TO-PATHNAME-COMPONENTS, use SPLIT-UNIX-NAMESTRING-DIRECTORY-COMPONENTS") - (multiple-value-bind (relabs path filename file-only) - (split-unix-namestring-directory-components - unix-style-namestring :ensure-directory force-directory) - (declare (ignore file-only)) - (when (and force-relative (not (eq relabs :relative))) - (error (compatfmt "~@<Absolute pathname designator not allowed: ~3i~_~S~@:>") - unix-style-namestring)) - (values relabs path filename))) - - #+(or clasp ecl mkcl) - (defun compile-file-keeping-object (&rest args) (apply #'compile-file* args)) - ;; Backward compatibility for ASDF 2.27 to 3.1.4 (defun user-configuration-directories () "Return the current user's list of user configuration directories @@ -6829,7 +6753,8 @@ for common-lisp. DEPRECATED." ;;;; Re-export all the functionality in UIOP (uiop/package:define-package :uiop/driver - (:nicknames :uiop :asdf/driver :asdf-driver :asdf-utils) + (:nicknames :uiop :asdf/driver) ;; asdf/driver is obsolete (uiop isn't); + ;; but asdf/driver is still used by swap-bytes, static-vectors. (:use :uiop/common-lisp) ;; NB: not reexporting uiop/common-lisp ;; which include all of CL with compatibility modifications on select platforms, @@ -6837,9 +6762,8 @@ for common-lisp. DEPRECATED." ;; or :use (closer-common-lisp uiop), etc. (:use-reexport :uiop/package :uiop/utility - :uiop/os :uiop/pathname :uiop/stream :uiop/filesystem :uiop/image - :uiop/run-program :uiop/lisp-build - :uiop/configuration :uiop/backward-driver)) + :uiop/os :uiop/pathname :uiop/filesystem :uiop/stream :uiop/image + :uiop/run-program :uiop/lisp-build :uiop/configuration :uiop/backward-driver)) ;; Provide both lowercase and uppercase, to satisfy more people. (provide "uiop") (provide "UIOP") @@ -6853,7 +6777,7 @@ for common-lisp. DEPRECATED." (:export #:asdf-version #:*previous-asdf-versions* #:*asdf-version* #:asdf-message #:*verbose-out* - #:upgrading-p #:when-upgrading #:upgrade-asdf #:asdf-upgrade-error #:defparameter* + #:upgrading-p #:when-upgrading #:upgrade-asdf #:defparameter* #:*post-upgrade-cleanup-hook* #:*post-upgrade-restart-hook* #:cleanup-upgraded-asdf ;; There will be no symbol left behind! #:intern*) @@ -6875,7 +6799,16 @@ You can compare this string with e.g.: (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSIO (cons (format nil "~{~D~^.~}" rev)) (null "1.0")))))) ;; Important: define *p-a-v* /before/ *a-v* so that it initializes correctly. - (defvar *previous-asdf-versions* (if-let (previous (asdf-version)) (list previous))) + (defvar *previous-asdf-versions* + (let ((previous (asdf-version))) + (when previous + ;; Punt on hard package upgrade: from ASDF1 or ASDF2 + (when (version< previous "2.27") ;; 2.27 is the first to have the :asdf3 feature. + (let ((away (format nil "~A-~A" :asdf previous))) + (rename-package :asdf away) + (when *load-verbose* + (format t "~&; Renamed old ~A package away to ~A~%" :asdf away))))) + (list previous))) (defvar *asdf-version* nil) ;; We need to clear systems from versions yet older than the below: (defparameter *oldest-forward-compatible-asdf-version* "2.33") ;; 2.32.13 renames a slot in component. @@ -6912,7 +6845,7 @@ previously-loaded version of ASDF." ;; "3.4.5.67" would be a development version in the official branch, on top of 3.4.5. ;; "3.4.5.0.8" would be your eighth local modification of official release 3.4.5 ;; "3.4.5.67.8" would be your eighth local modification of development version 3.4.5.67 - (asdf-version "3.1.6") + (asdf-version "3.1.6.9") (existing-version (asdf-version))) (setf *asdf-version* asdf-version) (when (and existing-version (not (equal asdf-version existing-version))) @@ -6926,21 +6859,7 @@ previously-loaded version of ASDF." (let ((redefined-functions ;; gf signature and/or semantics changed incompatibly. Oops. ;; NB: it's too late to do anything about functions in UIOP! ;; If you introduce some critically incompatibility there, you must change name. - '(#:component-relative-pathname #:component-parent-pathname ;; component - #:source-file-type - #:find-system #:system-source-file #:system-relative-pathname ;; system - #:find-component ;; find-component - #:explain #:perform #:perform-with-restarts #:input-files #:output-files ;; action - #:component-depends-on #:operation-done-p #:component-depends-on - #:traverse ;; backward-interface - #:map-direct-dependencies #:reduce-direct-dependencies #:direct-dependencies ;; plan - #:operate ;; operate - #:parse-component-form ;; defsystem - #:apply-output-translations ;; output-translations - #:process-output-translations-directive - #:inherit-source-registry #:process-source-registry ;; source-registry - #:process-source-registry-directive - #:trivial-system-p)) ;; bundle + '()) ;; empty now that we don't unintern, but wholly punt on ASDF 2.26 or earlier. (redefined-classes ;; redefining the classes causes interim circularities ;; with the old ASDF during upgrade, and many implementations bork @@ -6962,12 +6881,6 @@ previously-loaded version of ASDF." ;;; Self-upgrade functions (with-upgradability () - (defun asdf-upgrade-error () - ;; Important notice for whom it concerns. The crux of the matter is that - ;; TRAVERSE can be completely refactored, and so after the find-system returns, it's too late. - (error "When a system transitively depends on ASDF, it must :defsystem-depends-on (:asdf)~%~ - Otherwise, when you upgrade from ASDF 2, you must do it before you operate on any system.~%")) - (defun cleanup-upgraded-asdf (&optional (old-version (first *previous-asdf-versions*))) (let ((new-version (asdf-version))) (unless (equal old-version new-version) @@ -7072,7 +6985,7 @@ another pathname in a degenerate way.")) ;; condition objects, which in turn does inheritance of :report options at ;; run-time. fortunately, inheritance means we only need this kludge here in ;; order to fix all conditions that build on it. -- rgr, 28-Jul-02.] - #+cmu (:report print-object)) + #+cmucl (:report print-object)) (define-condition duplicate-names (system-definition-error) ((name :initarg :name :reader duplicate-names-name)) @@ -7110,10 +7023,9 @@ another pathname in a degenerate way.")) ;; See our ASDF 2 paper for more complete explanations. (in-order-to :initform nil :initarg :in-order-to :accessor component-in-order-to) - ;; 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) ;; OBSOLETE! DELETE THIS IF NO ONE USES. + ;; Methods defined using the "inline" style inside a defsystem form: + ;; we store them here so we can delete them when the system is re-evaluated. + (inline-methods :accessor component-inline-methods :initform nil) ;; ASDF4: rename it from relative-pathname to specified-pathname. It need not be relative. ;; There is no initform and no direct accessor for this specified pathname, ;; so we only access the information through appropriate methods, after it has been processed. @@ -7502,7 +7414,8 @@ in which the system specification (.asd file) is located." #:remove-entry-from-registry #:coerce-entry-to-directory #:coerce-name #:primary-system-name #:coerce-filename #:find-system #:locate-system #:load-asd - #:system-registered-p #:register-system #:registered-systems #:clear-system #:map-systems + #:system-registered-p #:register-system #:registered-systems* #:registered-systems + #:clear-system #:map-systems #:missing-component #:missing-requires #:missing-parent #:formatted-system-definition-error #:format-control #:format-arguments #:sysdef-error #:load-system-definition-error #:error-name #:error-pathname #:error-condition @@ -7567,9 +7480,12 @@ of which is a system object.") (defun system-registered-p (name) (gethash (coerce-name name) *defined-systems*)) - (defun registered-systems () + (defun registered-systems* () (loop :for registered :being :the :hash-values :of *defined-systems* - :collect (coerce-name (cdr registered)))) + :collect (cdr registered))) + + (defun registered-systems () + (mapcar 'coerce-name (registered-systems*))) (defun register-system (system) (check-type system system) @@ -7788,7 +7704,8 @@ Going forward, we recommend new users should be using the source-registry. (find-system (coerce-name name) error-p)) (defun find-system-if-being-defined (name) - ;; notable side effect: mark the system as being defined, to avoid infinite loops + ;; NB: this depends on a corresponding side-effect in parse-defsystem; + ;; this protocol may change somewhat in the future. (first (gethash `(find-system ,(coerce-name name)) *asdf-cache*))) (defun load-asd (pathname @@ -7809,10 +7726,10 @@ Going forward, we recommend new users should be using the source-registry. ;; resolve logical-pathnames so they won't wreak havoc in parsing namestrings. (pathname-directory-pathname (physicalize-pathname pathname)))) (handler-bind - ((error #'(lambda (condition) - (error 'load-system-definition-error - :name name :pathname pathname - :condition condition)))) + (((and error (not missing-component)) + #'(lambda (condition) + (error 'load-system-definition-error + :name name :pathname pathname :condition condition)))) (asdf-message (compatfmt "~&~@<; ~@;Loading system definition~@[ for ~A~] from ~A~@:>~%") name pathname) (load* pathname :external-format external-format)))))) @@ -8482,9 +8399,11 @@ in some previous image, or T if it needs to be done.") (defmethod component-operation-time ((o operation) (c component)) (gethash (type-of o) (component-operation-times c))) + (defmethod (setf component-operation-time) (stamp (o operation) (c component)) + (setf (gethash (type-of o) (component-operation-times c)) stamp)) + (defmethod mark-operation-done ((o operation) (c component)) - (setf (gethash (type-of o) (component-operation-times c)) - (compute-action-stamp nil o c :just-done t)))) + (setf (component-operation-time o c) (compute-action-stamp nil o c :just-done t)))) ;;;; Perform @@ -9123,6 +9042,8 @@ the action of OPERATION on COMPONENT in the PLAN")) :index (if status ; index of action amongst all nodes in traversal (action-index status) ;; if already visited, keep index (incf (plan-total-action-count plan))))) ; else new index + (when (and done-p (not add-to-plan-p)) + (setf (component-operation-time operation component) stamp)) (when add-to-plan-p ; if it needs to be added to the plan, (incf (plan-planned-action-count plan)) ; count it (unless aniip ; if it's output-producing, @@ -9413,7 +9334,7 @@ to load it in current image." (defun already-loaded-systems () "return a list of the names of the systems that have been successfully loaded so far" - (remove-if-not 'component-loaded-p (registered-systems))) + (mapcar 'coerce-name (remove-if-not 'component-loaded-p (registered-systems*)))) (defun require-system (system &rest keys &key &allow-other-keys) "Ensure the specified SYSTEM is loaded, passing the KEYS to OPERATE, but skip any update to the @@ -9853,7 +9774,7 @@ system names to pathnames of .asd files") (register-clear-configuration-hook 'clear-source-registry) (defparameter *wild-asd* - (make-pathname* :directory nil :name *wild* :type "asd" :version :newest)) + (make-pathname :directory nil :name *wild* :type "asd" :version :newest)) (defun directory-asd-files (directory) (directory-files directory *wild-asd*)) @@ -9978,7 +9899,7 @@ after having found a .asd file? True by default.") #+(or clasp ecl sbcl) (:tree ,(resolve-symlinks* (lisp-implementation-directory))) :inherit-configuration #+mkcl (:tree ,(translate-logical-pathname "CONTRIB:")) - #+cmu (:tree #p"modules:") + #+cmucl (:tree #p"modules:") #+scl (:tree #p"file://modules/"))) (defun default-user-source-registry () `(:source-registry @@ -10295,7 +10216,7 @@ after having found a .asd file? True by default.") ;;; Main parsing function (with-upgradability () - (defun* parse-dependency-def (dd) + (defun parse-dependency-def (dd) (if (listp dd) (case (first dd) (:feature @@ -10316,12 +10237,12 @@ after having found a .asd file? True by default.") (otherwise (sysdef-error "Ill-formed dependency: ~s" dd))) (coerce-name dd))) - (defun* parse-dependency-defs (dd-list) + (defun parse-dependency-defs (dd-list) "Parse the dependency defs in DD-LIST into canonical form by translating all system names contained using COERCE-NAME. Return the result." (mapcar 'parse-dependency-def dd-list)) - (defun* (parse-component-form) (parent options &key previous-serial-component) + (defun (parse-component-form) (parent options &key previous-serial-component) (destructuring-bind (type name &rest rest &key (builtin-system-p () bspp) @@ -10411,6 +10332,15 @@ system names contained using COERCE-NAME. Return the result." (with-asdf-cache () (let* ((name (coerce-name name)) (source-file (if sfp source-file (resolve-symlinks* (load-pathname)))) + ;; NB: handle defsystem-depends-on BEFORE to create the system object, + ;; so that in case it fails, there is no incomplete object polluting the build. + (checked-defsystem-depends-on + (let* ((dep-forms (parse-dependency-defs defsystem-depends-on)) + (deps (loop :for spec :in dep-forms + :when (resolve-dependency-spec nil spec) + :collect :it))) + (load-systems* deps) + dep-forms)) (registered (system-registered-p name)) (registered! (if registered (rplaca registered (get-file-stamp source-file)) @@ -10419,17 +10349,12 @@ system names contained using COERCE-NAME. Return the result." (system (reset-system (cdr registered!) :name name :source-file source-file)) (component-options - (remove-plist-keys '(:defsystem-depends-on :class) options)) - (defsystem-dependencies (loop :for spec :in defsystem-depends-on - :when (resolve-dependency-spec nil spec) - :collect :it))) - ;; cache defsystem-depends-on in canonical form - (when defsystem-depends-on - (setf component-options - (append `(:defsystem-depends-on ,(parse-dependency-defs defsystem-depends-on)) - component-options))) + (append + (remove-plist-keys '(:defsystem-depends-on :class) options) + ;; cache defsystem-depends-on in canonical form + (when checked-defsystem-depends-on + `(:defsystem-depends-on ,checked-defsystem-depends-on))))) (set-asdf-cache-entry `(find-system ,name) (list system)) - (load-systems* defsystem-dependencies) ;; We change-class AFTER we loaded the defsystem-depends-on ;; since the class might be defined as part of those. (let ((class (class-for-type nil class))) @@ -11023,16 +10948,6 @@ for all the linkable object files associated with the system or its dependencies :extra-object-files (or (extra-object-files o) (when programp (extra-object-files c))) :no-uiop (no-uiop c) (when programp `(:entry-point ,(component-entry-point c)))))))) - -#+(and (not asdf-use-unsafe-mac-bundle-op) - (or (and clasp ecl darwin) - (and abcl darwin (not abcl-bundle-op-supported)))) -(defmethod perform :before ((o basic-compile-bundle-op) (c component)) - (unless (featurep :asdf-use-unsafe-mac-bundle-op) - (cerror "Continue after modifying *FEATURES*." - "BASIC-COMPILE-BUNDLE-OP operations are not supported on Mac OS X for this lisp.~%~T~ -To continue, push :asdf-use-unsafe-mac-bundle-op onto *FEATURES*.~%~T~ -Please report to ASDF-DEVEL if this works for you."))) ;;;; ------------------------------------------------------------------------- ;;;; Concatenate-source @@ -11219,11 +11134,12 @@ otherwise return a default system name computed from PACKAGE-NAME." (remove t (mapcar 'package-name-system (package-dependencies defpackage-form))) (error 'package-inferred-system-missing-package-error :system system :pathname file))) - (defun same-package-inferred-system-p (system name directory subpath dependencies) + (defun same-package-inferred-system-p (system name directory subpath around-compile dependencies) (and (eq (type-of system) 'package-inferred-system) (equal (component-name system) name) (pathname-equal directory (component-pathname system)) (equal dependencies (component-sideway-dependencies system)) + (equal around-compile (around-compile-hook system)) (let ((children (component-children system))) (and (length=n-p children 1) (let ((child (first children))) @@ -11243,14 +11159,16 @@ otherwise return a default system name computed from PACKAGE-NAME." :truename *resolve-symlinks*))) (when (file-pathname-p f) (let ((dependencies (package-inferred-system-file-dependencies f system)) - (previous (cdr (system-registered-p system)))) - (if (same-package-inferred-system-p previous system dir sub dependencies) + (previous (cdr (system-registered-p system))) + (around-compile (around-compile-hook top))) + (if (same-package-inferred-system-p previous system dir sub around-compile dependencies) previous (eval `(defsystem ,system :class package-inferred-system :source-file nil :pathname ,dir :depends-on ,dependencies + :around-compile ,around-compile :components ((cl-source-file "lisp" :pathname ,sub))))))))))))))) (with-upgradability () @@ -11264,27 +11182,14 @@ otherwise return a default system name computed from PACKAGE-NAME." (uiop/package:define-package :asdf/backward-internals (:recycle :asdf/backward-internals :asdf) (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/find-system) - (:export ;; for internal use - #:make-sub-operation - #:load-sysdef #:make-temporary-package)) + (:export #:load-sysdef)) (in-package :asdf/backward-internals) -(when-upgrading (:when (fboundp 'make-sub-operation)) - (defun make-sub-operation (c o dep-c dep-o) - (declare (ignore c o dep-c dep-o)) (asdf-upgrade-error))) - -;;;; load-sysdef (with-upgradability () (defun load-sysdef (name pathname) - (load-asd pathname :name name)) - - (defun make-temporary-package () - ;; For loading a .asd file, we don't make a temporary package anymore, - ;; but use ASDF-USER. I'd like to have this function do this, - ;; but since whoever uses it is likely to delete-package the result afterwards, - ;; this would be a bad idea, so preserve the old behavior. - (make-package (fresh-package-name :prefix :asdf :index 0) :use '(:cl :asdf)))) - + (declare (ignore name pathname)) + ;; Needed for backward compatibility with swank-asdf from SLIME 2015-12-01 or older. + (error "Use asdf:load-asd instead of asdf::load-sysdef"))) ;;;; ------------------------------------------------------------------------- ;;; Backward-compatible interfaces @@ -11654,12 +11559,12 @@ Please use UIOP:RUN-PROGRAM instead." (in-package :asdf/footer) ;;;; Hook ASDF into the implementation's REQUIRE and other entry points. -#+(or abcl clasp clisp clozure cmu ecl mkcl sbcl) +#+(or abcl clasp clisp clozure cmucl ecl mkcl sbcl) (with-upgradability () (if-let (x (and #+clisp (find-symbol* '#:*module-provider-functions* :custom nil))) (eval `(pushnew 'module-provide-asdf #+abcl sys::*module-provider-functions* - #+(or clasp cmu ecl) ext:*module-provider-functions* + #+(or clasp cmucl ecl) ext:*module-provider-functions* #+clisp ,x #+clozure ccl:*module-provider-functions* #+mkcl mk-ext:*module-provider-functions* @@ -11683,7 +11588,7 @@ Please use UIOP:RUN-PROGRAM instead." (and (first l) (register-preloaded-system (coerce-name name))) (values-list l)))))))) -#+cmu ;; Hook into the CMUCL herald. +#+cmucl ;; Hook into the CMUCL herald. (with-upgradability () (defun herald-asdf (stream) (format stream " ASDF ~A" (asdf-version))) @@ -11694,7 +11599,7 @@ Please use UIOP:RUN-PROGRAM instead." (with-upgradability () #+allegro (when (boundp 'excl:*warn-on-nested-reader-conditionals*) - (setf excl:*warn-on-nested-reader-conditionals* asdf/common-lisp::*acl-warn-save*)) + (setf excl:*warn-on-nested-reader-conditionals* uiop/common-lisp::*acl-warn-save*)) (dolist (f '(:asdf :asdf2 :asdf3 :asdf3.1 :asdf-package-system)) (pushnew f *features*)) ===================================== src/contrib/asdf/doc/asdf.html ===================================== --- a/src/contrib/asdf/doc/asdf.html +++ b/src/contrib/asdf/doc/asdf.html @@ -84,7 +84,6 @@ ul.no-bullet {list-style: none} - <a name="SEC_Contents"></a> <h2 class="contents-heading">Table of Contents</h2> @@ -275,7 +274,7 @@ ul.no-bullet {list-style: none} <a name="Top"></a> <a name="ASDF_003a-Another-System-Definition-Facility"></a> <h1 class="top">ASDF: Another System Definition Facility</h1> -<p>Manual for Version 3.1.6 +<p>Manual for Version 3.1.6.9 </p> <p>This manual describes ASDF, a system definition facility @@ -1263,7 +1262,7 @@ simple-component-name := string pathname-specifier := pathname | string | symbol method-form := (operation-name qual lambda-list &rest body) -qual := method qualifier +qual := method qualifier? component-dep-fail-option := :fail | :try-next | :ignore @@ -1787,6 +1786,7 @@ whereas earlier versions ignore this option and use the <code>system-source-dire where the <samp>.asd</samp> file resides. </p> + <hr> <a name="The-object-model-of-ASDF"></a> <a name="The-Object-model-of-ASDF"></a> @@ -1799,7 +1799,7 @@ Both a system’s structure and the operations that can be performed on syst follow a extensible protocol, allowing programmers to add new behaviours to ASDF. For example, <code>cffi</code> adds support for special FFI description files that interface with C libraries and for wrapper files that embed C code in Lisp. -<code>abcl-jar</code> supports creating Java JAR archives in ABCL. +<code>asdf-jar</code> supports creating Java JAR archives in ABCL. <code>poiu</code> supports compiling code in parallel using background processes. </p> <p>The key classes in ASDF are <code>component</code> and <code>operation</code>. ===================================== src/contrib/asdf/doc/asdf.info ===================================== --- a/src/contrib/asdf/doc/asdf.info +++ b/src/contrib/asdf/doc/asdf.info @@ -43,7 +43,7 @@ File: asdf.info, Node: Top, Next: Introduction, Prev: (dir), Up: (dir) ASDF: Another System Definition Facility **************************************** -Manual for Version 3.1.6 +Manual for Version 3.1.6.9 This manual describes ASDF, a system definition facility for Common Lisp programs and libraries. @@ -1173,7 +1173,7 @@ File: asdf.info, Node: The defsystem grammar, Next: Other code in .asd files, pathname-specifier := pathname | string | symbol method-form := (operation-name qual lambda-list &rest body) - qual := method qualifier + qual := method qualifier? component-dep-fail-option := :fail | :try-next | :ignore @@ -1630,7 +1630,7 @@ system's structure and the operations that can be performed on systems follow a extensible protocol, allowing programmers to add new behaviours to ASDF. For example, 'cffi' adds support for special FFI description files that interface with C libraries and for wrapper files that embed C -code in Lisp. 'abcl-jar' supports creating Java JAR archives in ABCL. +code in Lisp. 'asdf-jar' supports creating Java JAR archives in ABCL. 'poiu' supports compiling code in parallel using background processes. The key classes in ASDF are 'component' and 'operation'. A @@ -5647,136 +5647,136 @@ Variable Index Tag Table: Node: Top1684 -Node: Introduction7633 -Node: Quick start summary9936 -Node: Loading ASDF11643 -Node: Loading a pre-installed ASDF11945 -Ref: Loading a pre-installed ASDF-Footnote-113758 -Node: Checking whether ASDF is loaded13940 -Node: Upgrading ASDF14854 -Node: Replacing your implementation's ASDF15842 -Node: Loading ASDF from source17265 -Node: Configuring ASDF18366 -Node: Configuring ASDF to find your systems19139 -Ref: Configuring ASDF to find your systems-Footnote-122444 -Ref: Configuring ASDF to find your systems-Footnote-222691 -Ref: Configuring ASDF to find your systems-Footnote-322973 -Node: Configuring ASDF to find your systems --- old style23434 -Ref: Configuring ASDF to find your systems --- old style-Footnote-125861 -Ref: Configuring ASDF to find your systems --- old style-Footnote-226093 -Ref: Configuring ASDF to find your systems --- old style-Footnote-326860 -Node: Configuring where ASDF stores object files27016 -Node: Resetting the ASDF configuration28419 -Node: Using ASDF29476 -Node: Loading a system29687 -Node: Convenience Functions30704 -Ref: Convenience Functions-Footnote-133849 -Node: Moving on33927 -Node: Defining systems with defsystem34298 -Node: The defsystem form34726 -Node: A more involved example38132 -Ref: A more involved example-Footnote-145114 -Node: The defsystem grammar45796 -Ref: if-feature-option61935 -Node: Other code in .asd files63767 -Node: The package-inferred-system extension64903 -Node: The object model of ASDF69170 -Ref: The object model of ASDF-Footnote-171500 -Ref: The object model of ASDF-Footnote-271852 -Node: Operations72179 -Ref: operate73284 -Node: Predefined operations of ASDF75767 -Ref: test-op77882 -Node: Creating new operations85765 -Node: Components90978 -Ref: System names94462 -Ref: Components-Footnote-199134 -Ref: Components-Footnote-299430 -Node: Common attributes of components99752 -Ref: required-features101314 -Node: Pre-defined subclasses of component107161 -Node: Creating new component types109595 -Node: Dependencies110885 -Node: Functions112756 -Node: Controlling where ASDF searches for systems114590 -Node: Configurations115212 -Node: Truenames and other dangers118687 -Node: XDG base directory119973 -Node: Backward Compatibility121387 -Node: Configuration DSL122103 -Node: Configuration Directories127658 -Node: The here directive129485 -Node: Shell-friendly syntax for configuration131378 -Node: Search Algorithm132395 -Node: Caching Results133896 -Node: Configuration API137140 -Node: Introspection139179 -Node: *source-registry-parameter* variable139443 -Node: Information about system dependencies140012 -Node: Status140928 -Node: Rejected ideas141383 -Node: TODO143764 -Node: Credits for the source-registry143949 -Node: Controlling where ASDF saves compiled files144484 -Ref: Controlling where ASDF saves compiled files-Footnote-1145896 -Node: Output Configurations145940 -Ref: Output Configurations-Footnote-1148801 -Node: Output Backward Compatibility148867 -Node: Output Configuration DSL151593 -Node: Output Configuration Directories157048 -Node: Output Shell-friendly syntax for configuration158605 -Node: Semantics of Output Translations159914 -Node: Output Caching Results161483 -Node: Output location API161963 -Node: Credits for output translations164385 -Node: Error handling164905 -Node: Miscellaneous additional functionality165746 -Node: Controlling file compilation166218 -Node: Controlling source file character encoding169484 -Node: Miscellaneous Functions176299 -Ref: system-relative-pathname176596 -Ref: Miscellaneous Functions-Footnote-1182220 -Node: Some Utility Functions182331 -Node: Getting the latest version193059 -Node: FAQ194004 -Node: Where do I report a bug?194399 -Node: Mailing list194764 -Node: What has changed between ASDF 1 ASDF 2 and ASDF 3?195099 -Node: What are ASDF 1 2 3?197273 -Node: How do I detect the ASDF version?198314 -Node: ASDF can portably name files in subdirectories200621 -Node: Output translations202171 -Node: Source Registry Configuration203198 -Node: Usual operations are made easier to the user204825 -Node: Many bugs have been fixed205411 -Node: ASDF itself is versioned207243 -Node: ASDF can be upgraded208118 -Node: Decoupled release cycle209270 -Node: Pitfalls of the transition to ASDF 2210199 -Node: Pitfalls of the upgrade to ASDF 3214469 -Ref: Pitfalls of the upgrade to ASDF 3-Footnote-1218836 -Node: What happened to the bundle operations219006 -Node: Issues with installing the proper version of ASDF220108 -Node: My Common Lisp implementation comes with an outdated version of ASDF. What to do?220579 -Node: I'm a Common Lisp implementation vendor. When and how should I upgrade ASDF?221512 -Node: Issues with configuring ASDF225395 -Node: How can I customize where fasl files are stored?225770 -Node: How can I wholly disable the compiler output cache?226863 -Node: Issues with using and extending ASDF to define systems228242 -Node: How can I cater for unit-testing in my system?228966 -Node: How can I cater for documentation generation in my system?229855 -Node: How can I maintain non-Lisp (e.g. C) source files?230376 -Ref: report-bugs230808 -Node: I want to put my module's files at the top level. How do I do this?230808 -Node: How do I create a system definition where all the source files have a .cl extension?233958 -Node: How do I mark a source file to be loaded only and not compiled?235931 -Node: How do I work with readtables?236927 -Node: ASDF development FAQs240613 -Node: How do I run the tests interactively in a REPL?240852 -Node: Ongoing Work242718 -Node: Bibliography242997 -Node: Concept Index246433 -Node: Function and Class Index252725 -Node: Variable Index264553 +Node: Introduction7635 +Node: Quick start summary9938 +Node: Loading ASDF11645 +Node: Loading a pre-installed ASDF11947 +Ref: Loading a pre-installed ASDF-Footnote-113760 +Node: Checking whether ASDF is loaded13942 +Node: Upgrading ASDF14856 +Node: Replacing your implementation's ASDF15844 +Node: Loading ASDF from source17267 +Node: Configuring ASDF18368 +Node: Configuring ASDF to find your systems19141 +Ref: Configuring ASDF to find your systems-Footnote-122446 +Ref: Configuring ASDF to find your systems-Footnote-222693 +Ref: Configuring ASDF to find your systems-Footnote-322975 +Node: Configuring ASDF to find your systems --- old style23436 +Ref: Configuring ASDF to find your systems --- old style-Footnote-125863 +Ref: Configuring ASDF to find your systems --- old style-Footnote-226095 +Ref: Configuring ASDF to find your systems --- old style-Footnote-326862 +Node: Configuring where ASDF stores object files27018 +Node: Resetting the ASDF configuration28421 +Node: Using ASDF29478 +Node: Loading a system29689 +Node: Convenience Functions30706 +Ref: Convenience Functions-Footnote-133851 +Node: Moving on33929 +Node: Defining systems with defsystem34300 +Node: The defsystem form34728 +Node: A more involved example38134 +Ref: A more involved example-Footnote-145116 +Node: The defsystem grammar45798 +Ref: if-feature-option61938 +Node: Other code in .asd files63770 +Node: The package-inferred-system extension64906 +Node: The object model of ASDF69173 +Ref: The object model of ASDF-Footnote-171503 +Ref: The object model of ASDF-Footnote-271855 +Node: Operations72182 +Ref: operate73287 +Node: Predefined operations of ASDF75770 +Ref: test-op77885 +Node: Creating new operations85768 +Node: Components90981 +Ref: System names94465 +Ref: Components-Footnote-199137 +Ref: Components-Footnote-299433 +Node: Common attributes of components99755 +Ref: required-features101317 +Node: Pre-defined subclasses of component107164 +Node: Creating new component types109598 +Node: Dependencies110888 +Node: Functions112759 +Node: Controlling where ASDF searches for systems114593 +Node: Configurations115215 +Node: Truenames and other dangers118690 +Node: XDG base directory119976 +Node: Backward Compatibility121390 +Node: Configuration DSL122106 +Node: Configuration Directories127661 +Node: The here directive129488 +Node: Shell-friendly syntax for configuration131381 +Node: Search Algorithm132398 +Node: Caching Results133899 +Node: Configuration API137143 +Node: Introspection139182 +Node: *source-registry-parameter* variable139446 +Node: Information about system dependencies140015 +Node: Status140931 +Node: Rejected ideas141386 +Node: TODO143767 +Node: Credits for the source-registry143952 +Node: Controlling where ASDF saves compiled files144487 +Ref: Controlling where ASDF saves compiled files-Footnote-1145899 +Node: Output Configurations145943 +Ref: Output Configurations-Footnote-1148804 +Node: Output Backward Compatibility148870 +Node: Output Configuration DSL151596 +Node: Output Configuration Directories157051 +Node: Output Shell-friendly syntax for configuration158608 +Node: Semantics of Output Translations159917 +Node: Output Caching Results161486 +Node: Output location API161966 +Node: Credits for output translations164388 +Node: Error handling164908 +Node: Miscellaneous additional functionality165749 +Node: Controlling file compilation166221 +Node: Controlling source file character encoding169487 +Node: Miscellaneous Functions176302 +Ref: system-relative-pathname176599 +Ref: Miscellaneous Functions-Footnote-1182223 +Node: Some Utility Functions182334 +Node: Getting the latest version193062 +Node: FAQ194007 +Node: Where do I report a bug?194402 +Node: Mailing list194767 +Node: What has changed between ASDF 1 ASDF 2 and ASDF 3?195102 +Node: What are ASDF 1 2 3?197276 +Node: How do I detect the ASDF version?198317 +Node: ASDF can portably name files in subdirectories200624 +Node: Output translations202174 +Node: Source Registry Configuration203201 +Node: Usual operations are made easier to the user204828 +Node: Many bugs have been fixed205414 +Node: ASDF itself is versioned207246 +Node: ASDF can be upgraded208121 +Node: Decoupled release cycle209273 +Node: Pitfalls of the transition to ASDF 2210202 +Node: Pitfalls of the upgrade to ASDF 3214472 +Ref: Pitfalls of the upgrade to ASDF 3-Footnote-1218839 +Node: What happened to the bundle operations219009 +Node: Issues with installing the proper version of ASDF220111 +Node: My Common Lisp implementation comes with an outdated version of ASDF. What to do?220582 +Node: I'm a Common Lisp implementation vendor. When and how should I upgrade ASDF?221515 +Node: Issues with configuring ASDF225398 +Node: How can I customize where fasl files are stored?225773 +Node: How can I wholly disable the compiler output cache?226866 +Node: Issues with using and extending ASDF to define systems228245 +Node: How can I cater for unit-testing in my system?228969 +Node: How can I cater for documentation generation in my system?229858 +Node: How can I maintain non-Lisp (e.g. C) source files?230379 +Ref: report-bugs230811 +Node: I want to put my module's files at the top level. How do I do this?230811 +Node: How do I create a system definition where all the source files have a .cl extension?233961 +Node: How do I mark a source file to be loaded only and not compiled?235934 +Node: How do I work with readtables?236930 +Node: ASDF development FAQs240616 +Node: How do I run the tests interactively in a REPL?240855 +Node: Ongoing Work242721 +Node: Bibliography243000 +Node: Concept Index246436 +Node: Function and Class Index252728 +Node: Variable Index264556 End Tag Table ===================================== src/contrib/asdf/doc/asdf.pdf ===================================== Binary files a/src/contrib/asdf/doc/asdf.pdf and b/src/contrib/asdf/doc/asdf.pdf differ ===================================== src/general-info/release-21b.txt ===================================== --- a/src/general-info/release-21b.txt +++ b/src/general-info/release-21b.txt @@ -22,7 +22,7 @@ New in this release: * Feature enhancements * Changes - * Update to ASDF 3.1.6 + * Update to ASDF 3.1.6.9 * Add support for asdf's static-image-op * This mostly entails internal changes in how executables are handled. lisp.a is not complete; it must be linked with View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/compare/95f2932bc350b3a89930f45a…

1 0

[Git][cmucl/cmucl][master] Update according to logs.
by Raymond Toy 08 Jan '16

08 Jan '16

Raymond Toy pushed to branch master at cmucl / cmucl Commits: 95f2932b by Raymond Toy at 2016-01-07T17:37:42Z Update according to logs. - - - - - 1 changed file: - src/general-info/release-21b.txt Changes: ===================================== src/general-info/release-21b.txt ===================================== --- a/src/general-info/release-21b.txt +++ b/src/general-info/release-21b.txt @@ -44,18 +44,32 @@ New in this release: Thus, src/code/unix-glibc2.lisp is no longer used. * Micro-optimize modular shifts on x86. * Update lisp-unit to commit e6c259f. + * Added EXT:WITH-FLOAT-TRAPS-ENABLED to complement + WITH-FLOAT-TRAPS-MASKED. + * (EXPT 0 power) doesn't throw INTEXP-LIMIT-ERROR anymore for any + integer value of power. + * Starting cmucl with "-dyanmic-space-size 0" means using the + maximum possible heap size for the platform. * ANSI compliance fixes: + * PATHNAME-MATCH-P did not accept search-lists. * Bugfixes: * Linux was missing unix-setitimer which prevented saving cores. + * Generate inxact exceptions more carefully. + * Fix FP issue when building with Xcode 7.2 (and newer versions of + clang). (See ticket #12.) * Trac Tickets: * Gitlab tickets: * Ticket #10 fixed: setting an element of a 1, 2, or 4-bit array with a constant index did not always set the element - appropriately. + appropriately. + * Ticket #12 fixed. It looks like a possible compiler bug, but + worked around by explicitly setting inexact instead of using FP + instructions to generate inexact. + * Ticket #16 fixed: search-lists are handled correctly. * Other changes: View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/95f2932bc350b3a89930f45ac…

1 0

[Git][cmucl/cmucl][master] Regenerated.
by Raymond Toy 07 Jan '16

07 Jan '16

Raymond Toy pushed to branch master at cmucl / cmucl Commits: 90855b07 by Raymond Toy at 2016-01-06T21:02:16Z Regenerated. - - - - - 1 changed file: - src/i18n/locale/cmucl.pot Changes: ===================================== src/i18n/locale/cmucl.pot ===================================== --- a/src/i18n/locale/cmucl.pot +++ b/src/i18n/locale/cmucl.pot @@ -6065,8 +6065,9 @@ msgstr "" #: src/code/commandline.lisp msgid "" "Specifies the number of megabytes that should be allocated to the\n" -" heap. If not specified, a platform-specific default is used. The\n" -" actual maximum allowed heap size is platform-specific." +" heap. If not specified, a platform-specific default is used. If 0,\n" +" the platform-specific maximum heap size is used. The actual maximum\n" +" allowed heap size is platform-specific." msgstr "" #: src/code/commandline.lisp @@ -9171,9 +9172,12 @@ msgid "" " The standard streams are sys::*stdin*, sys::*stdout*, and\n" " sys::*stderr*, which are normally the input and/or output streams\n" " for *standard-input* and *standard-output*. Also sets sys::*tty*\n" -" (normally *terminal-io* to the given external format. If the\n" -" optional argument Filenames is gvien, then the filename encoding is\n" -" set to the specified format." +" (normally *terminal-io* to the given external format. The value of\n" +" *default-external-format* is not changed.\n" +"\n" +" If the optional argument Filenames is given, then the filename\n" +" encoding is set to the specified format, if it has not already been\n" +" specified previously." msgstr "" #: src/code/extfmts.lisp View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/90855b079b2d6cd010e4b6eb7…

1 0

[Git][cmucl/cmucl][master] If -dynamic-space-size is 0, use the max heap.
by Raymond Toy 07 Jan '16

07 Jan '16

Raymond Toy pushed to branch master at cmucl / cmucl Commits: a5805ca0 by Raymond Toy at 2016-01-06T21:00:07Z If -dynamic-space-size is 0, use the max heap. If the user specifies -dynamic-space-size 0, then use the platform-specific maximum heap size. Update the docstring for the switch too. - - - - - 2 changed files: - src/code/commandline.lisp - src/lisp/lisp.c Changes: ===================================== src/code/commandline.lisp ===================================== --- a/src/code/commandline.lisp +++ b/src/code/commandline.lisp @@ -283,8 +283,9 @@ (defswitch "dynamic-space-size" nil "Specifies the number of megabytes that should be allocated to the - heap. If not specified, a platform-specific default is used. The - actual maximum allowed heap size is platform-specific." + heap. If not specified, a platform-specific default is used. If 0, + the platform-specific maximum heap size is used. The actual maximum + allowed heap size is platform-specific." "megabytes") (defswitch "read-only-space-size" nil ===================================== src/lisp/lisp.c ===================================== --- a/src/lisp/lisp.c +++ b/src/lisp/lisp.c @@ -622,7 +622,16 @@ main(int argc, const char *argv[], const char *envp[]) exit(1); } #ifndef sparc - dynamic_space_size = atoi(str) * 1024 * 1024; + dynamic_space_size = atoi(str); + + /* + * A size of 0 means using the largest possible space + */ + if (dynamic_space_size == 0) { + dynamic_space_size = DYNAMIC_SPACE_SIZE; + } else { + dynamic_space_size *= 1024 * 1024; + } #else { int val; @@ -646,6 +655,9 @@ main(int argc, const char *argv[], const char *envp[]) "Note: Rounding dynamic-space-size from %d MB to %d MB\n", val, dynamic_space_size); } + if (dynamic_space_size == 0) { + dynamic_space_size = DYNAMIC_SPACE_SIZE; + } dynamic_space_size *= 1024 * 1024; } #endif View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/a5805ca073019b470b8b21ac7…

1 0