April 2004 - movitz-cvs@common-lisp.net - mailman3.common-lisp.net

[movitz-cvs] CVS update: movitz/losp/x86-pc/interrupt.lisp
by Frode Vatvedt Fjeld 06 Apr '04

06 Apr '04

Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory common-lisp.net:/tmp/cvs-serv9604 Modified Files: interrupt.lisp Log Message: Re-wrote default-interrupt-trampoline. This means the format of "interrupt-frames" is changed completely, thus also int-frame-index. Now, an "interrupt-frame" looks more like an ordinary stack-frame, only with some special rules about the GC-rootness of the slots immediately above (the stuff the CPU pushes on interrupts), and below (the interruptee registers we push) the frame. This is part of adding support for interrupt-frames to map-stack-words in scavenge.lisp. Date: Tue Apr 6 10:42:11 2004 Author: ffjeld Index: movitz/losp/x86-pc/interrupt.lisp diff -u movitz/losp/x86-pc/interrupt.lisp:1.7 movitz/losp/x86-pc/interrupt.lisp:1.8 --- movitz/losp/x86-pc/interrupt.lisp:1.7 Tue Apr 6 06:37:52 2004 +++ movitz/losp/x86-pc/interrupt.lisp Tue Apr 6 10:42:11 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri May 4 18:08:50 2001 ;;;; -;;;; $Id: interrupt.lisp,v 1.7 2004/04/06 10:37:52 ffjeld Exp $ +;;;; $Id: interrupt.lisp,v 1.8 2004/04/06 14:42:11 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -34,14 +34,17 @@ (movitz:movitz-eval name env)))) (if (not name) form - (position name '(:edi :esi :ebp :esp :ebx :edx :ecx :eax - :exception :error-code - :eip :cs :eflags))))) + (- 5 (position name + '(:eip :eflags nil :error-code :exception :ebp nil + :ecx :eax :edx :ebx :esi :edi) + #+ignore '(:edi :esi :ebp :esp :ebx :edx :ecx :eax + :exception :error-code + :eip :cs :eflags)))))) (defun int-frame-index (name) - (position name '(:edi :esi :ebp :esp :ebx :edx :ecx :eax - :exception :error-code - :eip :cs :eflags))) + (- 5 (position name + '(:eip :eflags nil :error-code :exception :ebp nil + :ecx :eax :edx :ebx :esi :edi)))) (define-compiler-macro int-frame-ref (&whole form frame reg type &optional (offset 0) &environment env) `(memref ,frame (+ (* 4 (int-frame-index ,reg)) ,offset) 0 ,type)) @@ -66,22 +69,34 @@ (with-inline-assembly (:returns :multiple-values) ok ;; Stack: - ;; 48: Calling EFLAGS - ;; 44: Calling CS - ;; 40: Calling EIP - ;; 36: error code - ;; 32: exception number - (:pushal) ; push interruptee's registers - ;; 28: eax - ;; 24: ecx - ;; 20: edx - ;; 16: ebx - ;; 12: esp - ;; 8: ebp - ;; 4: esi - ;; 0: edi + ;; 20: Interruptee EFLAGS (later EIP) + ;; 16: Interruptee CS (later EFLAGS) + ;; 12: Interruptee EIP + ;; 8: Error code + ;; 4: Exception number + ;; 0: EBP + (:pushl :ebp) + (:movl :esp :ebp) + (:pushl 0) ; 0 means default-interrupt-trampoline frame + (:pushl :ecx) ; -8 + (:pushl :eax) ; -12 + (:pushl :edx) ; -16 + (:pushl :ebx) ; -20 + (:pushl :esi) ; -24 + (:pushl :edi) ; -28 + + ;; rearrange stack for return + (:movl (:ebp 12) :eax) ; load return address + (:movl (:ebp 20) :ebx) ; load EFLAGS + (:movl :ebx (:ebp 16)) ; EFLAGS at next-to-bottom of stack + (:movl :eax (:ebp 20)) ; return address at bottom of stack + + (:xorl :eax :eax) ; Ensure safe value + (:xorl :edx :edx) ; Ensure safe value + + (:movl ':nil-value :edi) ; We want NIL! - (:pushl (:esp 48)) ; EFLAGS + (:pushl (:ebp 16)) ; EFLAGS (:pushl :cs) ; push CS (:call (:pc+ 0)) ; push EIP. ;; Now add a few bytes to the on-stack EIP so the iret goes to @@ -91,21 +106,12 @@ ;; *DEST* iret branches to here. ;; we're now in the context of the interruptee. - ;; rearrange stack for return - (:movl (:esp 40) :eax) ; load return address - (:movl (:esp 48) :ebx) ; load EFLAGS - (:movl :ebx (:esp 44)) ; EFLAGS at next-to-bottom of stack - - (:movl :eax (:esp 48)) ; return address at bottom of stack - - (:movl ':nil-value :edi) ; We want NIL! - - (:pushl :eax) ; fake stack-frame return address - (:pushl :ebp) ; set up fake stack-frame - (:movl :esp :ebp) ; (GIVES EBP OFFSET 8 RELATIVE TO NUMBERS ABOVE!!) - (:pushl :edi) ; A fake "funobj" for the fake stack-frame.. - ; ..the int-frame will be put here shortly. +;;; (:pushl :eax) ; fake stack-frame return address +;;; (:pushl :ebp) ; set up fake stack-frame +;;; (:movl :esp :ebp) ; (GIVES EBP OFFSET 8 RELATIVE TO NUMBERS ABOVE!!) +;;; (:pushl :edi) ; A fake "funobj" for the fake stack-frame.. +;;; ; ..the int-frame will be put here shortly. ;; Save/push thread-local values (:locally (:movl (:edi (:edi-offset num-values)) :ecx)) @@ -120,7 +126,7 @@ (:locally (:pushl (:edi (:edi-offset num-values)))) ;; call handler - (:movl (32 8 :ebp) :ebx) ; interrupt number into EBX + (:movl (:ebp 4) :ebx) ; interrupt number into EBX (:locally (:movl (:edi (:edi-offset interrupt-handlers)) :eax)) (:movl (:eax 2 (:ebx 4)) :eax) ; symbol at (aref EBX interrupt-handlers) into :esi (:leal (:eax -7) :ecx) @@ -128,9 +134,9 @@ (:jnz 'skip-interrupt-handler) ; if it's not a symbol, never mind. (:movl (:eax #.(movitz::slot-offset 'movitz::movitz-symbol 'movitz::function-value)) :esi) ; load new funobj from symbol into ESI - (:leal (8 :ebp) :ebx) ; pass INT-frame as arg1 - (:movl :ebx (:ebp -4)) ; put INT-frame as our fake stack-frame's funobj. - (:movl (32 8 :ebp) :eax) ; pass interrupt number as arg 0. + (:movl :ebp :ebx) ; pass INT-frame as arg1 + ;; (:movl :ebx (:ebp -4)) ; put INT-frame as our fake stack-frame's funobj. + (:movl (:ebp 4) :eax) ; pass interrupt number as arg 0. (:shll #.movitz::+movitz-fixnum-shift+ :eax) (:call (:esi #.(movitz::slot-offset 'movitz::movitz-funobj 'movitz::code-vector%2op))) @@ -145,11 +151,20 @@ (:subl 1 :ecx) (:jnz 'pop-values-loop) pop-values-done - - - (:leal (:ebp 8) :esp) - (:popal) ; pop interruptee's registers - (:addl 12 :esp) ; skip stack-hole + + (:movl (:ebp -28) :edi) + (:movl (:ebp -24) :esi) + (:movl (:ebp -20) :ebx) + (:movl (:ebp -16) :edx) + (:movl (:ebp -12) :eax) + (:movl (:ebp -8) :ecx) + + (:leave) + (:addl 12 :esp) + +;;; (:leal (:ebp 8) :esp) +;;; (:popal) ; pop interruptee's registers +;;; (:addl 12 :esp) ; skip stack-hole (:popfl) ; pop EFLAGS (:ret))) ; pop EIP @@ -209,7 +224,7 @@ new-bottom) (break "Stack overload exception ~D at ESP=~@Z with bottom #x~X." number - (+ int-frame (int-frame-index :esp)) + (+ int-frame (int-frame-index :ebp)) old-bottom)) (format *debug-io* "~&Stack-warning: Resetting stack-bottom to #x~X.~%" old-bottom)

1 0

[movitz-cvs] CVS update: movitz/losp/lib/repl.lisp
by Frode Vatvedt Fjeld 06 Apr '04

06 Apr '04

Update of /project/movitz/cvsroot/movitz/losp/lib In directory common-lisp.net:/tmp/cvs-serv1346 Modified Files: repl.lisp Log Message: Use *print-safely* mode in read-eval-print. Date: Tue Apr 6 10:37:04 2004 Author: ffjeld Index: movitz/losp/lib/repl.lisp diff -u movitz/losp/lib/repl.lisp:1.9 movitz/losp/lib/repl.lisp:1.10 --- movitz/losp/lib/repl.lisp:1.9 Wed Mar 31 11:38:20 2004 +++ movitz/losp/lib/repl.lisp Tue Apr 6 10:37:04 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Wed Mar 19 14:58:12 2003 ;;;; -;;;; $Id: repl.lisp,v 1.9 2004/03/31 16:38:20 ffjeld Exp $ +;;;; $Id: repl.lisp,v 1.10 2004/04/06 14:37:04 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -35,9 +35,10 @@ (defun read-eval-print (&optional (*repl-readline-context* *repl-readline-context*) (*repl-level* (1+ *repl-level*))) - (if (stringp *repl-prompter*) - (format t *repl-prompter* *repl-level* *package*) - (funcall *repl-prompter*)) + (let ((muerte:*print-safely* t)) + (if (stringp *repl-prompter*) + (format t *repl-prompter* *repl-level* *package*) + (funcall *repl-prompter*))) (handler-case (let ((previous-package *package*) (buffer-string (muerte.readline:contextual-readline *repl-readline-context*))) @@ -62,7 +63,8 @@ (warn "* was unbound!") (setf * nil)) (when printp - (apply #'format t *repl-print-format* results)) + (let ((muerte:*print-safely* t)) + (apply #'format t *repl-print-format* results))) (psetq +++ ++ ++ + + form) (psetq *** ** ** * * (car results)) (psetq /// // // / / (if *repl-consless*

1 0

[movitz-cvs] CVS update: movitz/procfs-image.lisp
by Frode Vatvedt Fjeld 06 Apr '04

06 Apr '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv29825 Modified Files: procfs-image.lisp Log Message: Minor edits. Date: Tue Apr 6 10:35:36 2004 Author: ffjeld Index: movitz/procfs-image.lisp diff -u movitz/procfs-image.lisp:1.3 movitz/procfs-image.lisp:1.4 --- movitz/procfs-image.lisp:1.3 Thu Feb 5 09:19:36 2004 +++ movitz/procfs-image.lisp Tue Apr 6 10:35:36 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Aug 24 11:39:37 2001 ;;;; -;;;; $Id: procfs-image.lisp,v 1.3 2004/02/05 14:19:36 ffjeld Exp $ +;;;; $Id: procfs-image.lisp,v 1.4 2004/04/06 14:35:36 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -270,12 +270,12 @@ #+allegro -(top-level:alias ("bochs" 0) (&rest forms) +(top-level:alias ("bochs" 0) (&optional form) (with-bochs-image () (with-simple-restart (continue "Exit this bochs session [pid=~D]" (image-pid *image*)) - (if forms - (let ((x (multiple-value-list (eval (cons 'progn forms))))) - (format t "~{~&~W~}" x) - (values-list x)) + (if form + (let ((x (eval form))) + (format t "~&~W" x) + x) (invoke-debugger "Established connection to Bochs [pid=~D]." (image-pid *image*))))))

1 0

[movitz-cvs] CVS update: movitz/packages.lisp
by Frode Vatvedt Fjeld 06 Apr '04

06 Apr '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv13184 Modified Files: packages.lisp Log Message: Added a few symbols. Date: Tue Apr 6 10:35:15 2004 Author: ffjeld Index: movitz/packages.lisp diff -u movitz/packages.lisp:1.12 movitz/packages.lisp:1.13 --- movitz/packages.lisp:1.12 Wed Mar 31 11:32:22 2004 +++ movitz/packages.lisp Tue Apr 6 10:35:14 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Sat Nov 15 21:39:55 2003 ;;;; -;;;; $Id: packages.lisp,v 1.12 2004/03/31 16:32:22 ffjeld Exp $ +;;;; $Id: packages.lisp,v 1.13 2004/04/06 14:35:14 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1101,6 +1101,8 @@ print-word fixnump below print-unreadable-movitz-object + + #:*print-safely* stack-ref with-each-dynamic-context @@ -1287,6 +1289,7 @@ #:+movitz-fixnum-factor+ #:+movitz-fixnum-shift+ + #:+scan-skip-word+ #:constant0 #:movitz-object-browser-properties

1 0

[movitz-cvs] CVS update: movitz/compiler.lisp
by Frode Vatvedt Fjeld 06 Apr '04

06 Apr '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv23008 Modified Files: compiler.lisp Log Message: Default *compiler-auto-stack-checks-p* to t. Date: Tue Apr 6 10:34:46 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.41 movitz/compiler.lisp:1.42 --- movitz/compiler.lisp:1.41 Thu Apr 1 12:27:03 2004 +++ movitz/compiler.lisp Tue Apr 6 10:34:45 2004 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.41 2004/04/01 17:27:03 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.42 2004/04/06 14:34:45 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -28,7 +28,7 @@ "Allow the compiler to emit CMOV instructions, making the code incompatible with pre-pentium CPUs.") -(defvar *compiler-auto-stack-checks-p* nil +(defvar *compiler-auto-stack-checks-p* t "Make every compiled function check upon entry that the stack-pointer is within bounds. Costs 3 code-bytes and a few cycles.") @@ -826,7 +826,8 @@ (let ((offset (cdr (assoc entry-label code-symtab)))) (setf (slot-value funobj slot-name) (cons offset funobj)) - (vector-push offset code-vector))) + (when (< offset #x100) + (vector-push offset code-vector)))) ((some (lambda (label) (assoc label code-symtab)) (mapcar #'car rest)) (vector-push 0 code-vector)))) @@ -4905,7 +4906,7 @@ (values (or (restore-by-pop :eax) `((:addl ,(* 4 stack-displacement) :esp))) :nothing)))))) - + (define-compiler compile-apply-symbol (&form form &funobj funobj &env env &result-mode result-mode) "3.1.2.1.2.3 Function Forms"

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/scavenge.lisp
by Frode Vatvedt Fjeld 06 Apr '04

06 Apr '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv27745 Modified Files: scavenge.lisp Log Message: Minor edit. Date: Tue Apr 6 10:33:11 2004 Author: ffjeld Index: movitz/losp/muerte/scavenge.lisp diff -u movitz/losp/muerte/scavenge.lisp:1.3 movitz/losp/muerte/scavenge.lisp:1.4 --- movitz/losp/muerte/scavenge.lisp:1.3 Wed Mar 31 11:36:34 2004 +++ movitz/losp/muerte/scavenge.lisp Tue Apr 6 10:33:10 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Mon Mar 29 14:54:08 2004 ;;;; -;;;; $Id: scavenge.lisp,v 1.3 2004/03/31 16:36:34 ffjeld Exp $ +;;;; $Id: scavenge.lisp,v 1.4 2004/04/06 14:33:10 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -95,8 +95,8 @@ (loop for nether-frame = start-stack-frame then frame and frame = (stack-frame-uplink start-stack-frame) then (stack-frame-uplink frame) while (plusp frame) - do (let ((funobj (stack-frame-funobj frame))) - (typecase funobj + do (let ((funobj (stack-frame-funobj frame t))) + (etypecase funobj (integer (error "Don't know how to scavenge across an interrupt frame.")) (function

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/segments.lisp
by Frode Vatvedt Fjeld 06 Apr '04

06 Apr '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv22563 Modified Files: segments.lisp Log Message: Re-write of sgdt and new function lgdt. Date: Tue Apr 6 10:32:00 2004 Author: ffjeld Index: movitz/losp/muerte/segments.lisp diff -u movitz/losp/muerte/segments.lisp:1.2 movitz/losp/muerte/segments.lisp:1.3 --- movitz/losp/muerte/segments.lisp:1.2 Mon Jan 19 06:23:47 2004 +++ movitz/losp/muerte/segments.lisp Tue Apr 6 10:32:00 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Thu May 8 14:25:06 2003 ;;;; -;;;; $Id: segments.lisp,v 1.2 2004/01/19 11:23:47 ffjeld Exp $ +;;;; $Id: segments.lisp,v 1.3 2004/04/06 14:32:00 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -51,20 +51,43 @@ value) (defun sgdt () - (without-gc - (with-inline-assembly (:returns :multiple-values) - (:pushl 0) - (:pushl 0) - (:leal (:esp 2) :ecx) - (:sgdt (:ecx)) - (:popl :ecx) - ;; (:andl #xffff :ecx) - (:shrl 16 :ecx) - (:leal ((:ecx #.movitz::+movitz-fixnum-factor+)) :ebx) - (:popl :ecx) - (:leal ((:ecx #.movitz::+movitz-fixnum-factor+)) :eax) - (:movl 2 :ecx) - (:stc)))) + "Return the location of the GDT, and the limit. +Error if the GDT location is not zero modulo 4." + (eval-when (:compile-toplevel) + (assert (= 4 movitz:+movitz-fixnum-factor+))) + (with-inline-assembly (:returns :multiple-values) + (:pushl #.movitz:+scan-skip-word+) + (:pushl 2) + (:pushl 0) + (:pushl 0) + (:leal (:esp 2) :ecx) + (:sgdt (:ecx)) + (:popl :ecx) + (:shrl 16 :ecx) + (:leal ((:ecx #.movitz::+movitz-fixnum-factor+)) :ebx) + (:popl :ecx) + (:testb 3 :cl) + (:jnz '(:sub-program () + (:compile-form (:result-mode :ignore) + (error "The GDT base is not 4-aligned.")))) + (:movl :ecx :eax) + (:movl 2 :ecx) + (:stc))) + +(defun lgdt (base-location limit) + "Set the GDT according to base-location and limit. +This is the setter corresponding to the sgdt getter." + (eval-when (:compile-toplevel) + (assert (= 4 movitz:+movitz-fixnum-factor+))) + (with-inline-assembly (:returns :nothing) + (:compile-two-forms (:eax :ebx) base-location limit) + (:pushl #.movitz:+scan-skip-word+) + (:pushl 2) + (:shll #.(cl:- 16 movitz:+movitz-fixnum-shift+) :ebx) + (:pushl :eax) + (:pushl :ebx) + (:leal (:esp 2) :ecx) + (:lgdt (:ecx)))) ;;;

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/variables.lisp
by Frode Vatvedt Fjeld 06 Apr '04

06 Apr '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv29504 Modified Files: variables.lisp Log Message: Move variable *active-condition-handlers* here. Date: Tue Apr 6 10:31:09 2004 Author: ffjeld Index: movitz/losp/muerte/variables.lisp diff -u movitz/losp/muerte/variables.lisp:1.3 movitz/losp/muerte/variables.lisp:1.4 --- movitz/losp/muerte/variables.lisp:1.3 Wed Mar 24 18:42:49 2004 +++ movitz/losp/muerte/variables.lisp Tue Apr 6 10:31:09 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Wed Nov 5 21:53:34 2003 ;;;; -;;;; $Id: variables.lisp,v 1.3 2004/03/24 23:42:49 ffjeld Exp $ +;;;; $Id: variables.lisp,v 1.4 2004/04/06 14:31:09 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -35,6 +35,7 @@ (defvar +++ nil) (defparameter *debugger-hook* nil) +(defvar *active-condition-handlers* nil) (defvar internal-time-units-per-second)

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/symbols.lisp
by Frode Vatvedt Fjeld 06 Apr '04

06 Apr '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv15010 Modified Files: symbols.lisp Log Message: Add writers (setf symbol-special-variable-p) and (setf symbol-constant-variable-p). Date: Tue Apr 6 10:30:48 2004 Author: ffjeld Index: movitz/losp/muerte/symbols.lisp diff -u movitz/losp/muerte/symbols.lisp:1.6 movitz/losp/muerte/symbols.lisp:1.7 --- movitz/losp/muerte/symbols.lisp:1.6 Sun Mar 28 20:57:48 2004 +++ movitz/losp/muerte/symbols.lisp Tue Apr 6 10:30:48 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Sep 4 23:55:41 2001 ;;;; -;;;; $Id: symbols.lisp,v 1.6 2004/03/29 01:57:48 ffjeld Exp $ +;;;; $Id: symbols.lisp,v 1.7 2004/04/06 14:30:48 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -193,8 +193,18 @@ (defun symbol-special-variable-p (symbol) (logbitp 0 (symbol-flags symbol))) +(defun (setf symbol-special-variable-p) (value symbol) + (setf (ldb (byte 1 0) (symbol-flags symbol)) + (if value 1 0)) + value) + (defun symbol-constant-variable-p (symbol) (logbitp 1 (symbol-flags symbol))) + +(defun (setf symbol-constant-variable-p) (value symbol) + (setf (ldb (byte 1 1) (symbol-flags symbol)) + (if value 1 0)) + value) (defvar *gensym-counter* 0)

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/print.lisp
by Frode Vatvedt Fjeld 06 Apr '04

06 Apr '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv3168 Modified Files: print.lisp Log Message: Added support for *print-safely* in write. In this mode, try to print some opaque error message rather than signal an error condition. Date: Tue Apr 6 10:29:33 2004 Author: ffjeld Index: movitz/losp/muerte/print.lisp diff -u movitz/losp/muerte/print.lisp:1.4 movitz/losp/muerte/print.lisp:1.5 --- movitz/losp/muerte/print.lisp:1.4 Tue Mar 30 16:32:12 2004 +++ movitz/losp/muerte/print.lisp Tue Apr 6 10:29:33 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Mon Sep 3 11:48:19 2001 ;;;; -;;;; $Id: print.lisp,v 1.4 2004/03/30 21:32:12 ffjeld Exp $ +;;;; $Id: print.lisp,v 1.5 2004/04/06 14:29:33 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -33,6 +33,8 @@ (defvar *print-pretty* t) (defvar *print-circle* nil) +(defvar *print-safely* nil) + (defvar *standard-output* #'muerte.x86-pc::textmode-console) (defvar *standard-input* #'muerte.x86-pc::textmode-console) (defvar *debug-io* #'muerte.x86-pc::textmode-console) @@ -148,18 +150,24 @@ (write-char #\Newline stream) string) -(defun write (object &key stream case circle - (array *print-array*) (base *print-base*) - ((:escape *print-escape*) *print-escape*) - ((:gensym *print-gensym*) *print-gensym*) - (length *print-length*) - (level *print-level*) lines miser-width pprint-dispatch - (pretty *print-pretty*) (radix *print-radix*) - ((:readably *print-readably*) *print-readably*) - right-margin) - (declare (special *read-base* *package*) +(defun write (object &rest key-args + &key stream case circle safe-recursive-call + (array *print-array*) (base *print-base*) + ((:escape *print-escape*) *print-escape*) + ((:gensym *print-gensym*) *print-gensym*) + (length *print-length*) + (level *print-level*) lines miser-width pprint-dispatch + (pretty *print-pretty*) (radix *print-radix*) + ((:readably *print-readably*) *print-readably*) + right-margin) + (declare (dynamic-extent key-args) + (special *read-base* *package*) (ignore case circle pprint-dispatch miser-width right-margin lines)) (cond + ((and *print-safely* (not safe-recursive-call)) + (handler-case (apply #'write object :safe-recursive-call t key-args) + (t (condition) + (write-string "#<printer error>" stream)))) ((and (not pretty) (not *never-use-print-object*)) (print-object object stream))

1 0