movitz-cvs

movitz-cvs@common-lisp.net

2595 discussions

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

14 Apr '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv11289 Modified Files: memref.lisp Log Message: Added :code-vector storage-type for memref and (setf memref). Date: Wed Apr 14 08:31:08 2004 Author: ffjeld Index: movitz/losp/muerte/memref.lisp diff -u movitz/losp/muerte/memref.lisp:1.11 movitz/losp/muerte/memref.lisp:1.12 --- movitz/losp/muerte/memref.lisp:1.11 Tue Apr 6 20:15:02 2004 +++ movitz/losp/muerte/memref.lisp Wed Apr 14 08:31:08 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Mar 6 21:25:49 2001 ;;;; -;;;; $Id: memref.lisp,v 1.11 2004/04/07 00:15:02 ffjeld Exp $ +;;;; $Id: memref.lisp,v 1.12 2004/04/14 12:31:08 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -207,6 +207,43 @@ (:load-lexical (:lexical-binding ,object-var) :eax) (:addl :ebx :ecx) (:movl (:eax :ecx ,(offset-by 4)) :eax))))))) + (:code-vector + ;; A code-vector is like a normal lisp word pointer, + ;; except it's known to point to a code-vector, and + ;; the pointer value is offset by 2. The trick is to + ;; perform this pointer arithmetics while never + ;; keeping a non-lisp-word pointer in a register. + (cond + ((and (eql 0 index) (eql 0 offset)) + `(with-inline-assembly (:returns :eax) + (:compile-form (:result-mode :ebx) ,object) + (:movl ,(ldb (byte 32 0) (- movitz:+code-vector-word-offset+)) :eax) + (:addl (:ebx ,(offset-by 4)) :eax))) + ((eql 0 offset) + `(with-inline-assembly (:returns :eax) + (:compile-two-forms (:ebx :ecx) ,object ,index) + ,@(when (cl:plusp (cl:- movitz::+movitz-fixnum-shift+ 2)) + `((:sarl ,(cl:- movitz::+movitz-fixnum-shift+ 2)) :ecx)) + (:movl ,(ldb (byte 32 0) (- movitz:+code-vector-word-offset+)) :eax) + (:addl (:ebx :ecx ,(offset-by 4)) :eax))) + ((eql 0 index) + `(with-inline-assembly (:returns :eax) + (:compile-two-forms (:ebx :untagged-fixnum-ecx) ,object ,offset) + (:movl ,(ldb (byte 32 0) (- movitz:+code-vector-word-offset+)) :eax) + (:addl (:ebx :ecx ,(offset-by 4)) :eax))) + (t (error "variable memref type :code-vector not implemented.")) + #+ignore + (t (assert (not (movitz:movitz-constantp offset env))) + (assert (not (movitz:movitz-constantp index env))) + (let ((object-var (gensym "memref-object-"))) + (assert (= 4 movitz:+movitz-fixnum-factor+)) + `(let ((,object-var ,object)) + (with-inline-assembly (:returns :eax) + (:compile-two-forms (:ecx :ebx) ,offset ,index) + (:sarl ,movitz:+movitz-fixnum-shift+ :ecx) + (:load-lexical (:lexical-binding ,object-var) :eax) + (:addl :ebx :ecx) + (:movl (:eax :ecx ,(offset-by 4)) :eax))))))) (t (error "Unknown memref type: ~S" (movitz::eval-form type nil nil)) form))))))))) @@ -454,6 +491,41 @@ `((:sarl ,(- movitz:+movitz-fixnum-shift+ 2)) :ecx)) (:movl :eax (:ebx :ecx ,(movitz:movitz-eval offset env))))))) (t (let ((value-var (gensym "memref-value-")) + (object-var (gensym "memref-object-"))) + `(let ((,value-var ,value) (,object-var ,object)) + (with-inline-assembly (:returns :eax) + (:compile-two-forms (:untagged-fixnum-ecx :ebx) ,offset ,index) + (:load-lexical (:lexical-binding ,value-var) :eax) + ,@(when (cl:plusp (cl:- movitz::+movitz-fixnum-shift+ 2)) + `((:sarl ,(cl:- movitz::+movitz-fixnum-shift+ 2)) :ebx)) + (:addl :ebx :ecx) ; index += offset + (:load-lexical (:lexical-binding ,object-var) :ebx) + (:movl :eax (:ebx :ecx)))))))) + (:code-vector + (cond + ((and (movitz:movitz-constantp offset env) + (movitz:movitz-constantp index env)) + `(with-inline-assembly (:returns :eax) + (:compile-two-forms (:eax :ebx) ,value ,object) + (:movl ,movitz:+code-vector-word-offset+ + (:ebx ,(+ (movitz:movitz-eval offset env) + (* 4 (movitz:movitz-eval index env))))) + (:addl :eax (:ebx ,(+ (movitz:movitz-eval offset env) + (* 4 (movitz:movitz-eval index env))))))) + ((movitz:movitz-constantp offset env) + (let ((value-var (gensym "memref-value-"))) + `(let ((,value-var ,value)) + (with-inline-assembly (:returns :eax) + (:compile-two-forms (:ebx :ecx) ,object ,index) + (:load-lexical (:lexical-binding ,value-var) :eax) + ,@(when (plusp (- movitz:+movitz-fixnum-shift+ 2)) + `((:sarl ,(- movitz:+movitz-fixnum-shift+ 2)) :ecx)) + (:movl ,movitz:+code-vector-word-offset+ + (:ebx :ecx ,(movitz:movitz-eval offset env))) + (:addl :eax (:ebx :ecx ,(movitz:movitz-eval offset env))))))) + (t (error "variable (setf memref) type :code-vector not implemented.") + #+ignore + (let ((value-var (gensym "memref-value-")) (object-var (gensym "memref-object-"))) `(let ((,value-var ,value) (,object-var ,object)) (with-inline-assembly (:returns :eax)

1 0

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

14 Apr '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv29291 Modified Files: functions.lisp Log Message: Slight rewrite of some funobj accessors. This still needs work, though. Date: Wed Apr 14 08:25:28 2004 Author: ffjeld Index: movitz/losp/muerte/functions.lisp diff -u movitz/losp/muerte/functions.lisp:1.7 movitz/losp/muerte/functions.lisp:1.8 --- movitz/losp/muerte/functions.lisp:1.7 Sun Mar 28 12:31:41 2004 +++ movitz/losp/muerte/functions.lisp Wed Apr 14 08:25:27 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Mar 12 22:58:54 2002 ;;;; -;;;; $Id: functions.lisp,v 1.7 2004/03/28 17:31:41 ffjeld Exp $ +;;;; $Id: functions.lisp,v 1.8 2004/04/14 12:25:27 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -84,14 +84,13 @@ (defun funobj-code-vector (funobj) (check-type funobj compiled-function) - (%word-offset (memref funobj #.(bt:slot-offset 'movitz:movitz-funobj 'movitz::code-vector) 0 :lisp) - -2)) + (memref funobj #.(bt:slot-offset 'movitz:movitz-funobj 'movitz::code-vector) 0 :code-vector)) (defun (setf funobj-code-vector) (code-vector funobj) (check-type funobj compiled-function) (check-type code-vector vector-u8) - (setf (memref funobj #.(bt:slot-offset 'movitz:movitz-funobj 'movitz::code-vector) 0 :lisp) - (%word-offset code-vector 2))) + (setf (memref funobj #.(bt:slot-offset 'movitz:movitz-funobj 'movitz::code-vector) 0 :code-vector) + code-vector)) (defun funobj-code-vector%1op (funobj) "This slot is not a lisp value, it is a direct address to code entry point. In practice it is either @@ -274,16 +273,18 @@ "Index ~D out of range, ~S has ~D constants." index funobj (funobj-num-constants funobj)) (if (>= index (funobj-num-jumpers funobj)) (memref funobj #.(bt:slot-offset 'movitz:movitz-funobj 'movitz:constant0) index :lisp) - (without-gc - (with-inline-assembly (:returns :eax) - (:compile-two-forms (:eax :untagged-fixnum-ecx) funobj index) - (:movl (:eax #.(bt:slot-offset 'movitz:movitz-funobj 'movitz:code-vector)) - :ebx) - (:negl :ebx) - (:addl ((:ecx 4) :eax #.(bt:slot-offset 'movitz:movitz-funobj 'movitz:constant0)) - :ebx) - (:leal ((:ebx #.movitz:+movitz-fixnum-factor+)) :eax) - (:xorl :ebx :ebx))))) + ;; For a jumper, return its offset relative to the code-vector. + ;; This is tricky wrt. to potential GC interrupts, because we're doing + ;; pointer arithmetics. + (with-inline-assembly (:returns :eax) + (:compile-two-forms (:eax :ecx) funobj index) + (:movl #.movitz:+code-vector-transient-word+ :ebx) + (:addl (:eax #.(bt:slot-offset 'movitz:movitz-funobj 'movitz:code-vector)) + :ebx) ; code-vector (word) into ebx + (:subl (:eax :ecx #.(bt:slot-offset 'movitz:movitz-funobj 'movitz:constant0)) + :ebx) + (:negl :ebx) + (:leal ((:ebx #.movitz:+movitz-fixnum-factor+)) :eax)))) (defun (setf funobj-constant-ref) (value funobj index) (check-type funobj compiled-function) @@ -297,10 +298,10 @@ (assert (below value (length (funobj-code-vector funobj))) (value) "The jumper value ~D is invalid because the code-vector's size is ~D." value (length (funobj-code-vector funobj))) - (without-gc + (progn ;; without-gc (with-inline-assembly (:returns :nothing) - (:compile-two-forms (:eax :untagged-fixnum-ecx) funobj index) - (:leal ((:ecx 4) :eax #.(bt:slot-offset 'movitz:movitz-funobj 'movitz:constant0)) + (:compile-two-forms (:eax :ecx) funobj index) + (:leal (:ecx :eax #.(bt:slot-offset 'movitz:movitz-funobj 'movitz:constant0)) :ebx) ; dest. address into ebx. (:compile-form (:result-mode :untagged-fixnum-ecx) value) (:addl (:eax #.(bt:slot-offset 'movitz:movitz-funobj 'movitz:code-vector))

1 0

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

14 Apr '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv18667 Modified Files: basic-macros.lisp Log Message: Removed bogus macro without-gc. Date: Wed Apr 14 08:21:53 2004 Author: ffjeld Index: movitz/losp/muerte/basic-macros.lisp diff -u movitz/losp/muerte/basic-macros.lisp:1.7 movitz/losp/muerte/basic-macros.lisp:1.8 --- movitz/losp/muerte/basic-macros.lisp:1.7 Tue Apr 13 12:40:53 2004 +++ movitz/losp/muerte/basic-macros.lisp Wed Apr 14 08:21:53 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Wed Nov 8 18:44:57 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: basic-macros.lisp,v 1.7 2004/04/13 16:40:53 ffjeld Exp $ +;;;; $Id: basic-macros.lisp,v 1.8 2004/04/14 12:21:53 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -885,14 +885,6 @@ (:andl #x7 :ecx) (:call (:edi (:ecx 4) ,(movitz::global-constant-offset 'fast-class-of))))) -(define-compiler-macro without-gc (&body body) - `(multiple-value-prog1 - (progn (with-inline-assembly (:returns :nothing) (:std)) - ,@body) - (with-inline-assembly (:returns :nothing) (:cld)))) - -;;; - (defmacro std-instance-reader (slot instance-form) (let ((slot (intern (symbol-name slot) :movitz))) `(with-inline-assembly-case () @@ -1010,7 +1002,6 @@ (let ((infinite-loop-label (make-symbol "infinite-loop"))) `(with-inline-assembly (:returns :nothing) ,infinite-loop-label - (:movl #xabbabeef :eax) (:halt) (:jmp ',infinite-loop-label))))

1 0

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

14 Apr '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv29310 Modified Files: procfs-image.lisp Log Message: Reflect the new interrupt-frame layout in backtrace. Date: Wed Apr 14 08:11:32 2004 Author: ffjeld Index: movitz/procfs-image.lisp diff -u movitz/procfs-image.lisp:1.4 movitz/procfs-image.lisp:1.5 --- movitz/procfs-image.lisp:1.4 Tue Apr 6 10:35:36 2004 +++ movitz/procfs-image.lisp Wed Apr 14 08:11:32 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.4 2004/04/06 14:35:36 ffjeld Exp $ +;;;; $Id: procfs-image.lisp,v 1.5 2004/04/14 12:11:32 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -164,6 +164,10 @@ (when (zerop (ldb (byte 2 0) stack-frame)) (get-word (- stack-frame -4)))) +(defun interrupt-frame-index (name) + (- 5 (position name + '(nil :eflags :eip :error-code :exception :ebp nil + :ecx :eax :edx :ebx :esi :edi)))) (defun backtrace () (format t "~&Backtracing from EIP = #x~X: " (image-register32 *image* :eip)) @@ -182,14 +186,13 @@ (return-from backtrace nil)) (write-string "?") (let* ((r (stack-frame-return-address stack-frame)) - (eax (get-word (+ stack-frame 28 8))) - (ecx (get-word (+ stack-frame 24 8))) - (edi (get-word (+ stack-frame 0 8))) - (eip (get-word (+ stack-frame 40 8))) - (exception (get-word (+ stack-frame 32 8))) - (return (get-word (+ stack-frame 52 8)))) - (when r (format t " (ret #x~X {EAX: #x~X, ECX: #x~X, EDI: #x~X, EIP: #x~X, exception ~D, ret: #x~X})" - r eax ecx edi eip exception return)))) + (eax (get-word (+ (* 4 (interrupt-frame-index :eax)) stack-frame))) + (ecx (get-word (+ (* 4 (interrupt-frame-index :ecx)) stack-frame))) + (edi (get-word (+ (* 4 (interrupt-frame-index :edi)) stack-frame))) + (eip (get-word (+ (* 4 (interrupt-frame-index :eip)) stack-frame))) + (exception (get-word (+ (* 4 (interrupt-frame-index :exception)) stack-frame)))) + (when r (format t " (ret #x~X {EAX: #x~X, ECX: #x~X, EDI: #x~X, EIP: #x~X, exception ~D})" + r eax ecx edi eip exception)))) (movitz-symbol (let ((name (movitz-print movitz-name))) (write-string (symbol-name name))

1 0

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

13 Apr '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv12837 Modified Files: interrupt.lisp Log Message: For exception 98, used to signal an undefined function, use EDX rather than ECX to carry the offending function name, since ECX isn't a GC root. Date: Tue Apr 13 12:55:17 2004 Author: ffjeld Index: movitz/losp/muerte/interrupt.lisp diff -u movitz/losp/muerte/interrupt.lisp:1.2 movitz/losp/muerte/interrupt.lisp:1.3 --- movitz/losp/muerte/interrupt.lisp:1.2 Tue Apr 6 20:34:47 2004 +++ movitz/losp/muerte/interrupt.lisp Tue Apr 13 12:55:17 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Wed Apr 7 01:50:03 2004 ;;;; -;;;; $Id: interrupt.lisp,v 1.2 2004/04/07 00:34:47 ffjeld Exp $ +;;;; $Id: interrupt.lisp,v 1.3 2004/04/13 16:55:17 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -215,7 +215,7 @@ (70 (error "[EIP=~@Z] Index ~@Z out of bounds ~@Z for ~S." $eip $ecx $ebx (@ $eax))) (98 - (let ((name (@ $ecx))) + (let ((name (@ $edx))) (when (symbolp name) (error 'undefined-function :name name)))) (99

1 0

[movitz-cvs] CVS update: movitz/special-operators-cl.lisp
by Frode Vatvedt Fjeld 13 Apr '04

13 Apr '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv11619 Modified Files: special-operators-cl.lisp Log Message: For exception 98, used to signal an undefined function, use EDX rather than ECX to carry the offending function name, since ECX isn't a GC root. Date: Tue Apr 13 12:55:09 2004 Author: ffjeld Index: movitz/special-operators-cl.lisp diff -u movitz/special-operators-cl.lisp:1.16 movitz/special-operators-cl.lisp:1.17 --- movitz/special-operators-cl.lisp:1.16 Tue Apr 13 09:28:26 2004 +++ movitz/special-operators-cl.lisp Tue Apr 13 12:55:08 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Nov 24 16:31:11 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: special-operators-cl.lisp,v 1.16 2004/04/13 13:28:26 ffjeld Exp $ +;;;; $Id: special-operators-cl.lisp,v 1.17 2004/04/13 16:55:08 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -895,7 +895,7 @@ (:globally (:cmpl (:edi (:edi-offset unbound-function)) ,register)) (:je '(:sub-program () - (:load-constant ,movitz-name :ecx) + (:load-constant ,movitz-name :edx) (:int 98)))) :modifies nil :functional-p t

1 0

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

13 Apr '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv11686 Modified Files: basic-macros.lisp Log Message: Added a compiler-macro for defparameter. This should reduce the number of file-toplevels that needs to be executed at boot-time just to initialize some variables to constant values. Date: Tue Apr 13 12:40:53 2004 Author: ffjeld Index: movitz/losp/muerte/basic-macros.lisp diff -u movitz/losp/muerte/basic-macros.lisp:1.6 movitz/losp/muerte/basic-macros.lisp:1.7 --- movitz/losp/muerte/basic-macros.lisp:1.6 Tue Apr 6 09:39:47 2004 +++ movitz/losp/muerte/basic-macros.lisp Tue Apr 13 12:40:53 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Wed Nov 8 18:44:57 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: basic-macros.lisp,v 1.6 2004/04/06 13:39:47 ffjeld Exp $ +;;;; $Id: basic-macros.lisp,v 1.7 2004/04/13 16:40:53 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -119,8 +119,20 @@ ;; (muerte::compile-time-setq ,name ,initial-value) (setq ,name ,initial-value))) -(defmacro defvar (name &optional value documentation) - `(defparameter ,name ,value ,documentation)) +(define-compiler-macro defparameter (&whole form name initial-value + &optional docstring &environment env) + (declare (ignore docstring)) + (if (not (movitz:movitz-constantp initial-value env)) + form + (let ((mname (translate-program name :cl :muerte.cl))) + (setf (movitz::movitz-symbol-value (movitz:movitz-read mname)) + (movitz:movitz-eval initial-value env)) + `(declaim (special ,name))))) + +(defmacro defvar (name &optional (value nil valuep) documentation) + (if (not valuep) + `(declaim (special ,name)) + `(defparameter ,name ,value ,documentation))) (defmacro define-compile-time-variable (name value) `(progn

1 0

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

13 Apr '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv20526 Modified Files: eval.lisp Log Message: movitz-constantp should know that a string is indeed constant (self-evaluating, that is) Date: Tue Apr 13 12:30:36 2004 Author: ffjeld Index: movitz/eval.lisp diff -u movitz/eval.lisp:1.4 movitz/eval.lisp:1.5 --- movitz/eval.lisp:1.4 Wed Mar 31 11:31:44 2004 +++ movitz/eval.lisp Tue Apr 13 12:30:36 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Thu Nov 2 17:45:05 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: eval.lisp,v 1.4 2004/03/31 16:31:44 ffjeld Exp $ +;;;; $Id: eval.lisp,v 1.5 2004/04/13 16:30:36 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -63,6 +63,7 @@ (number t) (keyword t) (character t) + (string t) (symbol (or (movitz-env-get form 'constantp nil environment) (typep (movitz-binding form environment) 'constant-object-binding))) (cons (case (car form)

1 0

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

13 Apr '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv26853 Modified Files: print.lisp Log Message: Extracted internal-write from write. *print-safely* should work again. Date: Tue Apr 13 11:15:55 2004 Author: ffjeld Index: movitz/losp/muerte/print.lisp diff -u movitz/losp/muerte/print.lisp:1.6 movitz/losp/muerte/print.lisp:1.7 --- movitz/losp/muerte/print.lisp:1.6 Tue Apr 13 10:22:02 2004 +++ movitz/losp/muerte/print.lisp Tue Apr 13 11:15:55 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.6 2004/04/13 14:22:02 ffjeld Exp $ +;;;; $Id: print.lisp,v 1.7 2004/04/13 15:15:55 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -161,9 +161,8 @@ ((:readably *print-readably*) *print-readably*) right-margin) (numargs-case - (t (object &key safe-recursive-call + (t (object &key stream ;; lines miser-width pprint-dispatch right-margin case circle - ((:stream *standard-output*) *standard-output*) ((:array *print-array*) *print-array*) ((:base *print-base*) *print-base*) ((:escape *print-escape*) *print-escape*) @@ -173,158 +172,161 @@ ((:pretty *print-pretty*) *print-pretty*) ((:radix *print-radix*) *print-radix*) ((:readably *print-readably*) *print-readably*)) - (cond - ((and *print-safely* (not safe-recursive-call)) - (handler-case (write object :safe-recursive-call t) - (t (condition) - (write-string "#<printer error>")))) - (t (write object)))) + (let ((*standard-output* (output-stream-designator stream))) + (write object))) (1 (object) - (let ((stream (output-stream-designator *standard-output*))) - (cond - ((and (not *print-pretty*) - (not *never-use-print-object*)) - (print-object object stream)) - (t (let ((do-escape-p (or *print-escape* *print-readably*)) - (*print-level* (minus-if *print-level* 1))) - (typecase object - (character - (if (not do-escape-p) - (write-char object stream) - (progn - (write-string "#\\" stream) - (let ((name (char-name object))) - (if name - (write-string name stream) - (write-char object stream)))))) - (null - (write-string (symbol-name nil) stream)) - ((or cons tag5) - (let ((level *print-level*) - (length *print-length*)) - (cond - ((and level (minusp level)) - (write-char #\# stream)) - ((and (eq 'quote (car object)) - (not (cddr object))) - (write-char #\' stream) - (write (cadr object))) - (t (labels ((write-cons (c stream length) - (cond - ((and length (= 0 length)) - (write-string "...)")) - (t (write (car c)) - (typecase (cdr c) - (null - (write-char #\) stream)) - (cons - (write-char #\space stream) - (write-cons (cdr c) stream (minus-if length 1))) - (t - (write-string " . " stream) - (write (cdr c)) - (write-char #\) stream))))))) - (write-char #\( stream) - (write-cons object stream length)))))) - (integer - (write-integer object stream *print-base* *print-radix*)) - (string - (if do-escape-p - (stream-write-escaped-string stream object #\") - (write-string object stream))) - (symbol ; 22.1.3.3 Printing Symbols - (flet ((write-symbol-name (symbol stream) - (let ((name (symbol-name symbol))) - (if (and (plusp (length name)) - (every (lambda (c) - (or (upper-case-p c) - (member c '(#\- #\% #\$ #\* #\@ #\. #\& #\< #\> #\=)) - (digit-char-p c))) - name) - (not (every (lambda (c) - (or (digit-char-p c *read-base*) - (member c '(#\.)))) - name))) - (write-string name stream) - (stream-write-escaped-string stream name #\|))))) - (cond - ((not do-escape-p) - (write-symbol-name object stream)) - ((eq (symbol-package object) (find-package "KEYWORD")) - (write-string ":" stream) - (write-symbol-name object stream)) - ((or (eq (symbol-package object) *package*) - (eq (find-symbol (string object)) - object)) - (write-symbol-name object stream)) - ((symbol-package object) - (let ((package (symbol-package object))) - (write-string (package-name package) stream) - (write-string (if (gethash (symbol-name object) - (package-object-external-symbols package)) - ":" "::") - stream) - (write-symbol-name object stream))) - ((not (symbol-package object)) - (when *print-gensym* - (write-string "#:" stream)) - (write-symbol-name object stream)) - (t (error "Huh?"))))) - (vector - (let ((level *print-level*) - (length *print-length*)) - (cond - ((and level (minusp level)) - (write-char #\# stream)) - ((or *print-array* *print-readably*) - (write-string "#(" stream) - (cond - ((and length (< length (length object))) - (dotimes (i length) - (unless (= 0 i) - (write-char #\space stream)) - (write (aref object i))) - (write-string " ...)" stream)) - (t (dotimes (i (length object)) - (unless (= 0 i) - (write-char #\space stream)) - (write (aref object i))) - (write-char #\) stream)))) - (t (print-unreadable-object (object stream :identity t) - (princ (type-of object) stream)))))) - (standard-gf-instance - (print-unreadable-object (object stream) - (format stream "gf ~S" (funobj-name object)))) - (compiled-function - (print-unreadable-object (object stream) - (format stream "function ~S" (funobj-name object)))) - (hash-table + (if (not *print-safely*) + (internal-write object) + (handler-case (internal-write object) + (serious-condition (c) + (format t "#<printer error for ~Z: [~A]>" object c))))))) + +(defun internal-write (object) + (let ((stream *standard-output*)) + (cond + ((and (not *print-pretty*) + (not *never-use-print-object*)) + (print-object object stream)) + (t (let ((do-escape-p (or *print-escape* *print-readably*)) + (*print-level* (minus-if *print-level* 1))) + (typecase object + (character + (if (not do-escape-p) + (write-char object stream) + (progn + (write-string "#\\" stream) + (let ((name (char-name object))) + (if name + (write-string name stream) + (write-char object stream)))))) + (null + (write-string (symbol-name nil) stream)) + ((or cons tag5) + (let ((level *print-level*) + (length *print-length*)) + (cond + ((and level (minusp level)) + (write-char #\# stream)) + ((and (eq 'quote (car object)) + (not (cddr object))) + (write-char #\' stream) + (write (cadr object))) + (t (labels ((write-cons (c stream length) + (cond + ((and length (= 0 length)) + (write-string "...)")) + (t (write (car c)) + (typecase (cdr c) + (null + (write-char #\) stream)) + (cons + (write-char #\space stream) + (write-cons (cdr c) stream (minus-if length 1))) + (t + (write-string " . " stream) + (write (cdr c)) + (write-char #\) stream))))))) + (write-char #\( stream) + (write-cons object stream length)))))) + (integer + (write-integer object stream *print-base* *print-radix*)) + (string + (if do-escape-p + (stream-write-escaped-string stream object #\") + (write-string object stream))) + (symbol ; 22.1.3.3 Printing Symbols + (flet ((write-symbol-name (symbol stream) + (let ((name (symbol-name symbol))) + (if (and (plusp (length name)) + (every (lambda (c) + (or (upper-case-p c) + (member c '(#\- #\% #\$ #\* #\@ #\. #\& #\< #\> #\=)) + (digit-char-p c))) + name) + (not (every (lambda (c) + (or (digit-char-p c *read-base*) + (member c '(#\.)))) + name))) + (write-string name stream) + (stream-write-escaped-string stream name #\|))))) + (cond + ((not do-escape-p) + (write-symbol-name object stream)) + ((eq (symbol-package object) (find-package "KEYWORD")) + (write-string ":" stream) + (write-symbol-name object stream)) + ((or (eq (symbol-package object) *package*) + (eq (find-symbol (string object)) + object)) + (write-symbol-name object stream)) + ((symbol-package object) + (let ((package (symbol-package object))) + (write-string (package-name package) stream) + (write-string (if (gethash (symbol-name object) + (package-object-external-symbols package)) + ":" "::") + stream) + (write-symbol-name object stream))) + ((not (symbol-package object)) + (when *print-gensym* + (write-string "#:" stream)) + (write-symbol-name object stream)) + (t (error "Huh?"))))) + (vector + (let ((level *print-level*) + (length *print-length*)) + (cond + ((and level (minusp level)) + (write-char #\# stream)) + ((or *print-array* *print-readably*) + (write-string "#(" stream) + (cond + ((and length (< length (length object))) + (dotimes (i length) + (unless (= 0 i) + (write-char #\space stream)) + (write (aref object i))) + (write-string " ...)" stream)) + (t (dotimes (i (length object)) + (unless (= 0 i) + (write-char #\space stream)) + (write (aref object i))) + (write-char #\) stream)))) + (t (print-unreadable-object (object stream :identity t) + (princ (type-of object) stream)))))) + (standard-gf-instance + (print-unreadable-object (object stream) + (format stream "gf ~S" (funobj-name object)))) + (compiled-function + (print-unreadable-object (object stream) + (format stream "function ~S" (funobj-name object)))) + (hash-table + (print-unreadable-object (object stream :identity nil :type nil) + (format stream "~S hash-table with ~D entries" + (let ((test (hash-table-test object))) + (if (typep test 'compiled-function) + (funobj-name test) + test)) + (hash-table-count object)))) + (package + (if (package-name object) (print-unreadable-object (object stream :identity nil :type nil) - (format stream "~S hash-table with ~D entries" - (let ((test (hash-table-test object))) - (if (typep test 'compiled-function) - (funobj-name test) - test)) - (hash-table-count object)))) - (package - (if (package-name object) - (print-unreadable-object (object stream :identity nil :type nil) - (format stream "Package ~A with ~D+~D symbols" - (package-name object) - (hash-table-count (package-object-external-symbols object)) - (hash-table-count (package-object-internal-symbols object)))) - (print-unreadable-object (object stream :identity t :type t)))) - (t (if (not *never-use-print-object*) - (print-object object stream) - (print-unreadable-object (object stream :identity t) - (cond - ((typep object 'std-instance) - (write-string "[std-instance]" stream) - (write (standard-instance-access (std-instance-class object) 0))) - ((typep object 'standard-gf-instance) - (write-string "[std-gf-instance]" stream)) - (t (princ (type-of object) stream))))))))))) - object))) + (format stream "Package ~A with ~D+~D symbols" + (package-name object) + (hash-table-count (package-object-external-symbols object)) + (hash-table-count (package-object-internal-symbols object)))) + (print-unreadable-object (object stream :identity t :type t)))) + (t (if (not *never-use-print-object*) + (print-object object stream) + (print-unreadable-object (object stream :identity t) + (cond + ((typep object 'std-instance) + (write-string "[std-instance]" stream) + (write (standard-instance-access (std-instance-class object) 0))) + ((typep object 'standard-gf-instance) + (write-string "[std-gf-instance]" stream)) + (t (princ (type-of object) stream))))))))))) + object) (defun prin1 (object &optional stream) (let ((*standard-output* (output-stream-designator stream))

1 0

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

13 Apr '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv18310 Modified Files: print.lisp Log Message: Tried to be somewhat more clever about avoiding keyword-parsing in calls to write. Date: Tue Apr 13 10:22:02 2004 Author: ffjeld Index: movitz/losp/muerte/print.lisp diff -u movitz/losp/muerte/print.lisp:1.5 movitz/losp/muerte/print.lisp:1.6 --- movitz/losp/muerte/print.lisp:1.5 Tue Apr 6 10:29:33 2004 +++ movitz/losp/muerte/print.lisp Tue Apr 13 10:22:02 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.5 2004/04/06 14:29:33 ffjeld Exp $ +;;;; $Id: print.lisp,v 1.6 2004/04/13 14:22:02 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -100,9 +100,9 @@ (write-char comma-char stream)) nil) -(defun write-integer (x stream &key (base *print-base*) (radix *print-radix*) - mincol (padchar #\space) - (sign-always nil) (comma-char #\,) (comma-interval nil)) +(defun write-integer (x stream base radix + &optional mincol (padchar #\space) + (sign-always nil) (comma-char #\,) (comma-interval nil)) (when radix (case base (10) ; put a #\. at the end. @@ -124,7 +124,7 @@ (8 #.(cl:format cl:nil "~O" movitz::+movitz-most-negative-fixnum+)) (10 #.(cl:format cl:nil "~D" movitz::+movitz-most-negative-fixnum+)) (16 #.(cl:format cl:nil "~X" movitz::+movitz-most-negative-fixnum+)) - (t "minus-hack")) + (t (break "minus-hack!?"))) stream)))) (sign-always (values #\+ x)) @@ -160,170 +160,197 @@ (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)) - (t (let ((do-escape-p (or *print-escape* *print-readably*)) - (stream (output-stream-designator stream)) - (*print-level* (minus-if level 1))) - (typecase object - (character - (if (not do-escape-p) - (write-char object stream) - (progn - (write-string "#\\" stream) - (let ((name (char-name object))) - (if name - (write-string name stream) - (write-char object stream)))))) - (null - (write-string (symbol-name nil) stream)) - ((or cons tag5) - (cond - ((and *print-level* (minusp *print-level*)) - (write-char #\# stream)) - ((and (eq 'quote (car object)) - (not (cddr object))) - (write-char #\' stream) - (write (cadr object) :stream stream)) - (t (labels ((write-cons (c stream length) - (cond - ((and length (= 0 length)) - (write-string "...)")) - (t (write (car c) :stream stream) - (typecase (cdr c) - (null - (write-char #\) stream)) - (cons - (write-char #\space stream) - (write-cons (cdr c) stream (minus-if length 1))) - (t - (write-string " . " stream) - (write (cdr c) :stream stream) - (write-char #\) stream))))))) - (write-char #\( stream) - (write-cons object stream length))))) - (integer - (write-integer object stream :base base :radix radix)) - (string - (if do-escape-p - (stream-write-escaped-string stream object #\") - (write-string object stream))) - (symbol ; 22.1.3.3 Printing Symbols - (flet ((write-symbol-name (symbol stream) - (let ((name (symbol-name symbol))) - (if (and (plusp (length name)) - (every (lambda (c) - (or (upper-case-p c) - (member c '(#\- #\% #\$ #\* #\@ #\. #\& #\< #\> #\=)) - (digit-char-p c))) - name) - (not (every (lambda (c) - (or (digit-char-p c *read-base*) - (member c '(#\.)))) - name))) - (write-string name stream) - (stream-write-escaped-string stream name #\|))))) - (cond - ((not do-escape-p) - (write-symbol-name object stream)) - ((eq (symbol-package object) (find-package "KEYWORD")) - (write-string ":" stream) - (write-symbol-name object stream)) - ((or (eq (symbol-package object) *package*) - (eq (find-symbol (string object)) - object)) - (write-symbol-name object stream)) - ((symbol-package object) - (let ((package (symbol-package object))) - (write-string (package-name package) stream) - (write-string (if (gethash (symbol-name object) - (package-object-external-symbols package)) - ":" "::") - stream) - (write-symbol-name object stream))) - ((not (symbol-package object)) - (when *print-gensym* - (write-string "#:" stream)) - (write-symbol-name object stream)) - (t (error "Huh?"))))) - (vector - (cond - ((and *print-level* (minusp *print-level*)) - (write-char #\# stream)) - ((or array *print-readably*) - (write-string "#(" stream) - (cond - ((and length (< length (length object))) - (dotimes (i length) - (unless (= 0 i) - (write-char #\space stream)) - (write (aref object i))) - (write-string " ...)" stream)) - (t (dotimes (i (length object)) - (unless (= 0 i) - (write-char #\space stream)) - (write (aref object i) :stream stream)) - (write-char #\) stream)))) - (t (print-unreadable-object (object stream :identity t) - (princ (type-of object) stream))))) - (standard-gf-instance - (print-unreadable-object (object stream) - (format stream "gf ~S" (funobj-name object)))) - (compiled-function - (print-unreadable-object (object stream) - (format stream "function ~S" (funobj-name object)))) - (hash-table - (print-unreadable-object (object stream :identity nil :type nil) - (format stream "~S hash-table with ~D entries" - (let ((test (hash-table-test object))) - (if (typep test 'compiled-function) - (funobj-name test) - test)) - (hash-table-count object)))) - (package - (if (package-name object) - (print-unreadable-object (object stream :identity nil :type nil) - (format stream "Package ~A with ~D+~D symbols" - (package-name object) - (hash-table-count (package-object-external-symbols object)) - (hash-table-count (package-object-internal-symbols object)))) - (print-unreadable-object (object stream :identity t :type t)))) - (t (if (not *never-use-print-object*) - (print-object object stream) - (print-unreadable-object (object stream :identity t) - (cond - ((typep object 'std-instance) - (write-string "[std-instance]" stream) - (write (standard-instance-access (std-instance-class object) 0) :stream stream)) - ((typep object 'standard-gf-instance) - (write-string "[std-gf-instance]" stream)) - (t (princ (type-of object) stream)))))))))) - object) + (numargs-case + (t (object &key safe-recursive-call + ;; lines miser-width pprint-dispatch right-margin case circle + ((:stream *standard-output*) *standard-output*) + ((:array *print-array*) *print-array*) + ((:base *print-base*) *print-base*) + ((:escape *print-escape*) *print-escape*) + ((:gensym *print-gensym*) *print-gensym*) + ((:length *print-length*) *print-length*) + ((:level *print-level*) *print-level*) + ((:pretty *print-pretty*) *print-pretty*) + ((:radix *print-radix*) *print-radix*) + ((:readably *print-readably*) *print-readably*)) + (cond + ((and *print-safely* (not safe-recursive-call)) + (handler-case (write object :safe-recursive-call t) + (t (condition) + (write-string "#<printer error>")))) + (t (write object)))) + (1 (object) + (let ((stream (output-stream-designator *standard-output*))) + (cond + ((and (not *print-pretty*) + (not *never-use-print-object*)) + (print-object object stream)) + (t (let ((do-escape-p (or *print-escape* *print-readably*)) + (*print-level* (minus-if *print-level* 1))) + (typecase object + (character + (if (not do-escape-p) + (write-char object stream) + (progn + (write-string "#\\" stream) + (let ((name (char-name object))) + (if name + (write-string name stream) + (write-char object stream)))))) + (null + (write-string (symbol-name nil) stream)) + ((or cons tag5) + (let ((level *print-level*) + (length *print-length*)) + (cond + ((and level (minusp level)) + (write-char #\# stream)) + ((and (eq 'quote (car object)) + (not (cddr object))) + (write-char #\' stream) + (write (cadr object))) + (t (labels ((write-cons (c stream length) + (cond + ((and length (= 0 length)) + (write-string "...)")) + (t (write (car c)) + (typecase (cdr c) + (null + (write-char #\) stream)) + (cons + (write-char #\space stream) + (write-cons (cdr c) stream (minus-if length 1))) + (t + (write-string " . " stream) + (write (cdr c)) + (write-char #\) stream))))))) + (write-char #\( stream) + (write-cons object stream length)))))) + (integer + (write-integer object stream *print-base* *print-radix*)) + (string + (if do-escape-p + (stream-write-escaped-string stream object #\") + (write-string object stream))) + (symbol ; 22.1.3.3 Printing Symbols + (flet ((write-symbol-name (symbol stream) + (let ((name (symbol-name symbol))) + (if (and (plusp (length name)) + (every (lambda (c) + (or (upper-case-p c) + (member c '(#\- #\% #\$ #\* #\@ #\. #\& #\< #\> #\=)) + (digit-char-p c))) + name) + (not (every (lambda (c) + (or (digit-char-p c *read-base*) + (member c '(#\.)))) + name))) + (write-string name stream) + (stream-write-escaped-string stream name #\|))))) + (cond + ((not do-escape-p) + (write-symbol-name object stream)) + ((eq (symbol-package object) (find-package "KEYWORD")) + (write-string ":" stream) + (write-symbol-name object stream)) + ((or (eq (symbol-package object) *package*) + (eq (find-symbol (string object)) + object)) + (write-symbol-name object stream)) + ((symbol-package object) + (let ((package (symbol-package object))) + (write-string (package-name package) stream) + (write-string (if (gethash (symbol-name object) + (package-object-external-symbols package)) + ":" "::") + stream) + (write-symbol-name object stream))) + ((not (symbol-package object)) + (when *print-gensym* + (write-string "#:" stream)) + (write-symbol-name object stream)) + (t (error "Huh?"))))) + (vector + (let ((level *print-level*) + (length *print-length*)) + (cond + ((and level (minusp level)) + (write-char #\# stream)) + ((or *print-array* *print-readably*) + (write-string "#(" stream) + (cond + ((and length (< length (length object))) + (dotimes (i length) + (unless (= 0 i) + (write-char #\space stream)) + (write (aref object i))) + (write-string " ...)" stream)) + (t (dotimes (i (length object)) + (unless (= 0 i) + (write-char #\space stream)) + (write (aref object i))) + (write-char #\) stream)))) + (t (print-unreadable-object (object stream :identity t) + (princ (type-of object) stream)))))) + (standard-gf-instance + (print-unreadable-object (object stream) + (format stream "gf ~S" (funobj-name object)))) + (compiled-function + (print-unreadable-object (object stream) + (format stream "function ~S" (funobj-name object)))) + (hash-table + (print-unreadable-object (object stream :identity nil :type nil) + (format stream "~S hash-table with ~D entries" + (let ((test (hash-table-test object))) + (if (typep test 'compiled-function) + (funobj-name test) + test)) + (hash-table-count object)))) + (package + (if (package-name object) + (print-unreadable-object (object stream :identity nil :type nil) + (format stream "Package ~A with ~D+~D symbols" + (package-name object) + (hash-table-count (package-object-external-symbols object)) + (hash-table-count (package-object-internal-symbols object)))) + (print-unreadable-object (object stream :identity t :type t)))) + (t (if (not *never-use-print-object*) + (print-object object stream) + (print-unreadable-object (object stream :identity t) + (cond + ((typep object 'std-instance) + (write-string "[std-instance]" stream) + (write (standard-instance-access (std-instance-class object) 0))) + ((typep object 'standard-gf-instance) + (write-string "[std-gf-instance]" stream)) + (t (princ (type-of object) stream))))))))))) + object))) (defun prin1 (object &optional stream) - (write object :stream stream :escape t)) + (let ((*standard-output* (output-stream-designator stream)) + (*print-escape* t)) + (write object))) (defun princ (object &optional stream) - (write object :stream stream :escape nil :readably nil)) + (let ((*standard-output* (output-stream-designator stream)) + (*print-escape* nil) + (*print-readably* nil)) + (write object))) (defun print (object &optional stream) - (terpri stream) - (write object :stream stream :escape t) - (write-char #\Space stream) - object) + (let ((*standard-output* (output-stream-designator stream)) + (*print-escape* t)) + (write-char #\newline) + (write object) + (write-char #\Space) + object)) (defun pprint (object &optional stream) - (write object :stream stream :escape t :pretty t) - (values)) + (let ((*standard-output* (output-stream-designator stream)) + (*print-escape* t) + (*print-pretty* t)) + (write object) + (values))) (defun terpri (&optional stream) (write-char #\newline stream)

1 0

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

movitz-cvs