February 2005 - movitz-cvs@common-lisp.net

[movitz-cvs] CVS update: movitz/losp/muerte/typep.lisp
by ffjeld＠common-lisp.net 28 Feb '05

28 Feb '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv7466 Modified Files: typep.lisp Log Message: Added (typep code-vector) Date: Tue Mar 1 00:39:04 2005 Author: ffjeld Index: movitz/losp/muerte/typep.lisp diff -u movitz/losp/muerte/typep.lisp:1.41 movitz/losp/muerte/typep.lisp:1.42 --- movitz/losp/muerte/typep.lisp:1.41 Tue Jan 25 14:55:36 2005 +++ movitz/losp/muerte/typep.lisp Tue Mar 1 00:39:04 2005 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Dec 8 11:07:53 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: typep.lisp,v 1.41 2005/01/25 13:55:36 ffjeld Exp $ +;;;; $Id: typep.lisp,v 1.42 2005/02/28 23:39:04 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -577,6 +577,9 @@ (define-simple-typep (hash-table hash-table-p)) (define-simple-typep (package packagep)) + +(define-simple-typep (code-vector code-vector-p) (x) + (typep x 'code-vector)) ;;;

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/basic-macros.lisp
by ffjeld＠common-lisp.net 28 Feb '05

28 Feb '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv7432 Modified Files: basic-macros.lisp Log Message: Fixed boundp to accept nil as argument. Date: Tue Mar 1 00:38:05 2005 Author: ffjeld Index: movitz/losp/muerte/basic-macros.lisp diff -u movitz/losp/muerte/basic-macros.lisp:1.55 movitz/losp/muerte/basic-macros.lisp:1.56 --- movitz/losp/muerte/basic-macros.lisp:1.55 Fri Feb 25 08:59:04 2005 +++ movitz/losp/muerte/basic-macros.lisp Tue Mar 1 00:38:03 2005 @@ -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.55 2005/02/25 07:59:04 ffjeld Exp $ +;;;; $Id: basic-macros.lisp,v 1.56 2005/02/28 23:38:03 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1059,8 +1059,8 @@ `(with-inline-assembly-case () (do-case (t :boolean-zf=0 :labels (boundp-done)) (:compile-form (:result-mode :ebx) ,symbol) - (:leal (:ebx ,(- (movitz:tag :symbol))) :ecx) - (:testb 7 :cl) + (:leal (:ebx ,(- (movitz:tag :null))) :ecx) + (:testb 5 :cl) (:jne '(:sub-program () (:int 66))) (:call-local-pf dynamic-variable-lookup) (:globally (:cmpl (:edi (:edi-offset new-unbound-value)) :eax)))))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/packages.lisp
by ffjeld＠common-lisp.net 28 Feb '05

28 Feb '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv7392 Modified Files: packages.lisp Log Message: Improved do-all-symbols expansion so that (block nil ...) is installed correctly. Date: Tue Mar 1 00:36:15 2005 Author: ffjeld Index: movitz/losp/muerte/packages.lisp diff -u movitz/losp/muerte/packages.lisp:1.6 movitz/losp/muerte/packages.lisp:1.7 --- movitz/losp/muerte/packages.lisp:1.6 Sat Nov 13 15:50:13 2004 +++ movitz/losp/muerte/packages.lisp Tue Mar 1 00:36:08 2005 @@ -1,6 +1,6 @@ ;;;;------------------------------------------------------------------ ;;;; -;;;; Copyright (C) 2001, 2002-2004 +;;;; Copyright (C) 2001, 2002-2005 ;;;; Department of Computer Science, University of Tromso, Norway. ;;;; ;;;; For distribution policy, see the accompanying file COPYING. @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Thu Aug 30 15:19:43 2001 ;;;; -;;;; $Id: packages.lisp,v 1.6 2004/11/13 14:50:13 ffjeld Exp $ +;;;; $Id: packages.lisp,v 1.7 2005/02/28 23:36:08 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -105,10 +105,11 @@ (dummy (gensym)) (package-var (gensym)) (package-hash-var (gensym)) - (state-var (gensym "do-all-symbols-state-")) (next-symbol (gensym)) (more-symbols-var (gensym)) - (symbol-var (gensym))) + (symbol-var (gensym)) + (loop-tag (gensym)) + (end-tag (gensym))) `(with-hash-table-iterator (,next-package (get-global-property :packages)) (do () (nil) (multiple-value-bind (,more-packages-var ,dummy ,package-var) @@ -116,18 +117,22 @@ (declare (ignore ,dummy)) (unless ,more-packages-var (return ,result-form)) - (do ((,state-var '(:externals :internals) (cdr ,state-var)) - (,package-hash-var (package-object-external-symbols ,package-var) - (package-object-internal-symbols ,package-var))) - ((null ,state-var)) - (with-hash-table-iterator (,next-symbol ,package-hash-var) - (do () (nil) - (multiple-value-bind (,more-symbols-var ,dummy ,symbol-var) - (,next-symbol) - (declare (ignore ,dummy)) - (unless ,more-symbols-var (return nil)) - (let ((,var ,symbol-var)) - ,@declarations-and-body)))))))))) + (let ((,package-hash-var (package-object-external-symbols ,package-var))) + (tagbody ,loop-tag + (with-hash-table-iterator (,next-symbol ,package-hash-var) + (tagbody ,loop-tag + (multiple-value-bind (,more-symbols-var ,dummy ,symbol-var) + (,next-symbol) + (declare (ignore ,dummy)) + (unless ,more-symbols-var (go ,end-tag)) + (let ((,var ,symbol-var)) + ,@declarations-and-body)) + (go ,loop-tag) + ,end-tag)) + (let ((internals (package-object-internal-symbols ,package-var))) + (unless (eq ,package-hash-var internals) + (setf ,package-hash-var internals) + (go ,loop-tag)))))))))) (defmacro do-external-symbols ((var &optional (package *package*) result-form) &body declarations-and-body) (let ((next-var (gensym)) @@ -185,3 +190,5 @@ (do-all-symbols (symbol) (apropos-symbol symbol string))))) (values)) + +

1 0

[movitz-cvs] CVS update: movitz/losp/x86-pc/debugger.lisp
by ffjeld＠common-lisp.net 28 Feb '05

28 Feb '05

Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory common-lisp.net:/tmp/cvs-serv7331 Modified Files: debugger.lisp Log Message: Added find-function-name. Date: Tue Mar 1 00:34:02 2005 Author: ffjeld Index: movitz/losp/x86-pc/debugger.lisp diff -u movitz/losp/x86-pc/debugger.lisp:1.34 movitz/losp/x86-pc/debugger.lisp:1.35 --- movitz/losp/x86-pc/debugger.lisp:1.34 Mon Feb 28 17:44:37 2005 +++ movitz/losp/x86-pc/debugger.lisp Tue Mar 1 00:34:02 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Nov 22 10:09:18 2002 ;;;; -;;;; $Id: debugger.lisp,v 1.34 2005/02/28 16:44:37 ffjeld Exp $ +;;;; $Id: debugger.lisp,v 1.35 2005/02/28 23:34:02 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -606,3 +606,20 @@ c))))))) (values)) +(defun find-function-name (instruction-location) + "Try to find a name bound to a function whose code-vector matches instruction-location." + (check-type instruction-location fixnum) + (or (loop for (slot-name type) in (slot-value (class-of (current-run-time-context)) 'slot-map) + do (when (and (eq type 'code-vector-word) + (location-in-object-p (%run-time-context-slot slot-name) + instruction-location)) + (return (values slot-name :run-time-context)))) + (do-all-symbols (symbol) + (when (and (fboundp symbol) + (location-in-code-vector-p%unsafe (funobj-code-vector (symbol-function symbol)) + instruction-location)) + (return symbol)) + (when (and (boundp symbol) + (typep (symbol-value symbol) 'code-vector) + (location-in-code-vector-p%unsafe (symbol-value symbol) instruction-location)) + (return (values symbol :symbol-value))))))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/inspect.lisp
by ffjeld＠common-lisp.net 28 Feb '05

28 Feb '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv17272 Modified Files: inspect.lisp Log Message: Improved copy-current-control-stack. Date: Mon Feb 28 18:00:09 2005 Author: ffjeld Index: movitz/losp/muerte/inspect.lisp diff -u movitz/losp/muerte/inspect.lisp:1.48 movitz/losp/muerte/inspect.lisp:1.49 --- movitz/losp/muerte/inspect.lisp:1.48 Fri Feb 25 08:59:31 2005 +++ movitz/losp/muerte/inspect.lisp Mon Feb 28 18:00:05 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Oct 24 09:50:41 2003 ;;;; -;;;; $Id: inspect.lisp,v 1.48 2005/02/25 07:59:31 ffjeld Exp $ +;;;; $Id: inspect.lisp,v 1.49 2005/02/28 17:00:05 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -93,8 +93,8 @@ (let ((pos (+ frame index))) (assert (< -1 pos (length stack)) () "Index ~S, pos ~S, len ~S" index pos (length stack)) - (memref stack 2 :index pos :type type))) - (t (memref frame 0 :index index :type type)))) + (memref stack (+ 2 (* 4 pos)) :type type))) + (t (memref frame (* 4 index) :type type)))) (defun (setf stack-frame-ref) (value stack frame index &optional (type ':lisp)) (cond @@ -428,11 +428,29 @@ (stack-frame-ref nil start-frame i :unsigned-byte32))) (do ((frame start-frame)) ((eq 0 frame)) - (let ((uplink (stack-frame-uplink nil frame))) + (let ((uplink (stack-frame-uplink nil frame)) + (copy-frame (- frame start-frame))) (unless (= 0 uplink) - (setf (stack-frame-ref copy 0 (- frame start-frame) :lisp) + (setf (stack-frame-ref copy copy-frame 0 :lisp) (- uplink start-frame)) - - ) + (unless (= 0 copy-frame) ; first frame has only uplink. + ;; Now, make any raw stack-pointers into relative indexes. + ;; XXX TODO: The dynamic-env list. + (case (stack-frame-funobj copy copy-frame) + (0 (let ((ebp (dit-frame-ref nil frame :ebp))) + (setf (dit-frame-ref copy copy-frame :ebp) + (etypecase ebp + (fixnum (- ebp start-frame)) + (null nil)))) + (let ((ac (dit-frame-ref copy copy-frame + :atomically-continuation + :location))) + (when (and (/= 0 ac) + (= 0 (ldb (byte 2 0) + (dit-frame-ref copy copy-frame + :atomically-continuation + :unsigned-byte8)))) + (setf (dit-frame-ref copy copy-frame :atomically-continuation) + (- ac start-frame)))))))) (setf frame uplink))) copy))

1 0

[movitz-cvs] CVS update: movitz/losp/x86-pc/debugger.lisp
by ffjeld＠common-lisp.net 28 Feb '05

28 Feb '05

Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory common-lisp.net:/tmp/cvs-serv16359 Modified Files: debugger.lisp Log Message: Fixed buglet in *call-site-patterns*, the function-value offset for symbols was out of sync. Should fix some {eax unknown}s in backtrace. Date: Mon Feb 28 17:44:37 2005 Author: ffjeld Index: movitz/losp/x86-pc/debugger.lisp diff -u movitz/losp/x86-pc/debugger.lisp:1.33 movitz/losp/x86-pc/debugger.lisp:1.34 --- movitz/losp/x86-pc/debugger.lisp:1.33 Mon Feb 28 17:15:53 2005 +++ movitz/losp/x86-pc/debugger.lisp Mon Feb 28 17:44:37 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Nov 22 10:09:18 2002 ;;;; -;;;; $Id: debugger.lisp,v 1.33 2005/02/28 16:15:53 ffjeld Exp $ +;;;; $Id: debugger.lisp,v 1.34 2005/02/28 16:44:37 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -235,7 +235,7 @@ ))) (:* 1 ((:or ((:or (#x8b #x56 (:edx :esi)) ; (:movl (:esi x) :edx) (#x8b #x54 #x37 (:edx :esi+edi))) ;#<asm MOVL [#x39+%EDI+%ESI] => %EDX> - #x8b #x72 #xfd) ; (:movl (:edx -3) :esi) + #x8b #x72 #xf9) ; (:movl (:edx -7) :esi) (#x8b #x74 #x7e (:any-offset)) ; #<asm MOVL [#x28+%ESI+%EDI*2] => %ESI> (#x8b #x76 (:any-offset))))) ; #<asm MOVL [#x56+%ESI] => %ESI> (:* 1 ((:or (#xb1 (:cl-numargs))))) ; (:movb x :cl)

1 0

[movitz-cvs] CVS update: movitz/losp/x86-pc/debugger.lisp
by ffjeld＠common-lisp.net 28 Feb '05

28 Feb '05

Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory common-lisp.net:/tmp/cvs-serv15120 Modified Files: debugger.lisp Log Message: Improved error-handling in backtrace. Date: Mon Feb 28 17:15:55 2005 Author: ffjeld Index: movitz/losp/x86-pc/debugger.lisp diff -u movitz/losp/x86-pc/debugger.lisp:1.32 movitz/losp/x86-pc/debugger.lisp:1.33 --- movitz/losp/x86-pc/debugger.lisp:1.32 Wed Feb 2 11:23:07 2005 +++ movitz/losp/x86-pc/debugger.lisp Mon Feb 28 17:15:53 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Nov 22 10:09:18 2002 ;;;; -;;;; $Id: debugger.lisp,v 1.32 2005/02/02 10:23:07 ffjeld Exp $ +;;;; $Id: debugger.lisp,v 1.33 2005/02/28 16:15:53 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -507,115 +507,102 @@ (format t "{< ~D}" (stack-frame-call-site stack frame))) (when *backtrace-print-frames* (format t "#x~X " frame)))) - (typecase funobj - ((eql 0) - (let ((eip (dit-frame-ref stack frame :eip :unsigned-byte32)) - (casf (dit-frame-casf stack frame))) - (multiple-value-bind (function-name code-vector-offset) - (let ((casf-funobj (stack-frame-funobj stack casf))) - (cond - ((eq 0 casf-funobj) - (values 'default-interrupt-trampoline - (code-vector-offset (symbol-value 'default-interrupt-trampoline) - eip))) - ((not (typep casf-funobj 'function)) - ;; Hm.. very suspicius - (warn "Weird frame ~S" frame) - (values nil)) - (t (let ((x (code-vector-offset (funobj-code-vector casf-funobj) eip))) - (cond - ((not (eq nil x)) - (values (funobj-name casf-funobj) x)) - ((not (logbitp 10 (dit-frame-ref stack frame :eflags :unsigned-byte16))) - (let ((funobj2 (dit-frame-ref stack frame :esi :lisp))) - (or (when (typep funobj2 'function) - (let ((x (code-vector-offset (funobj-code-vector funobj2) eip))) - (when x - (values (funobj-name funobj2) x)))) - (find-primitive-code-vector-by-eip eip))))))))) - (setf next-frame (dit-frame-casf stack frame)) - (if (and conflate-interrupts conflate - ;; When the interrupted function has a stack-frame, conflate it. - (typep funobj 'function) - (= 1 (ldb (byte 1 5) (funobj-debug-info funobj)))) - (incf conflate-count) - (progn - (incf count) - (print-leadin stack frame count conflate-count) - (setf conflate-count 0) - (let ((exception (dit-frame-ref stack frame :exception-vector :unsigned-byte32))) - (if function-name - (format t "DIT exception ~D in ~W at PC offset ~D." - exception - function-name - code-vector-offset) - (format t "DIT exception ~D at EIP=~S with ESI=~S." - exception - eip - (dit-frame-ref stack frame :esi :unsigned-byte32))) - #+ignore - (typecase funobj - (function - (let ((delta (code-vector-offset (funobj-code-vector funobj) eip))) - (if delta - (format t "DIT Exception ~D in ~W at PC offset ~D." - exception (funobj-name funobj) delta) - (multiple-value-bind (primitive-name primitive-vector) - (find-primitive-code-vector-by-location (truncate eip 4)) - (if (not primitive-name) - (format t "DIT Exception ~D in ~W at EIP=#x~X." - exception (funobj-name funobj) eip) - (format t "DIT Exception ~D in primitive-function ~A at PC offset ~D." - exception - primitive-name - (code-vector-offset primitive-vector eip))))))) - (t ;; This should in principle never happen, but since this - ;; is a debugger, making this an error or break would probably - ;; just be a nuisance. - (format t "DIT Exception ~D. Unable to determine current function (!) with ESI=~Z and EIP=#x~X." - exception funobj eip))))))))) - (function - (let ((name (funobj-name funobj))) - (cond - ((and conflate (member name *backtrace-conflate-names* :test #'equal)) - (incf conflate-count)) - (t (incf count) - #+ignore (when (and *backtrace-stack-frame-barrier* - (<= *backtrace-stack-frame-barrier* stack-frame)) - (write-string " --|") - (return)) - (unless (or (not (integerp length)) - (< count length)) - (write-string " ...") - (return)) - (print-leadin stack frame count conflate-count) - (setf conflate-count 0) - (write-char #\() - (let* ((numargs (stack-frame-numargs stack frame)) - (map (and funobj (funobj-stack-frame-map funobj numargs)))) - (cond - ((and (car map) (eq name 'unbound-function)) - (let ((real-name (stack-frame-ref stack frame (car map)))) - (format t "{unbound ~S}" real-name))) - ((and (car map) - (member name +backtrace-gf-discriminatior-functions+)) - (let ((gf (stack-frame-ref stack frame (car map)))) + (handler-case + (typecase funobj + ((eql 0) + (let ((eip (dit-frame-ref stack frame :eip :unsigned-byte32)) + (casf (dit-frame-casf stack frame))) + (multiple-value-bind (function-name code-vector-offset) + (let ((casf-funobj (stack-frame-funobj stack casf))) (cond - ((typep gf 'muerte::standard-gf-instance) - (format t "{gf ~S}" (funobj-name gf))) - (t (write-string "[not a gf??]"))) - (safe-print-stack-frame-arglist stack frame map :numargs numargs))) - (t (write name) - (safe-print-stack-frame-arglist stack frame map - :numargs numargs - :edx-p (eq 'muerte::&edx - (car (funobj-lambda-list funobj))))))) - (write-char #\)) - (when (and (symbolp name) - (string= name 'toplevel-function)) - (write-char #\.) - (return)))))) - (t (print-leadin stack frame count conflate-count) - (format t "?: ~Z" funobj)))))) + ((eq 0 casf-funobj) + (values 'default-interrupt-trampoline + (code-vector-offset (symbol-value 'default-interrupt-trampoline) + eip))) + ((not (typep casf-funobj 'function)) + ;; Hm.. very suspicius + (warn "Weird frame ~S" frame) + (values nil)) + (t (let ((x (code-vector-offset (funobj-code-vector casf-funobj) eip))) + (cond + ((not (eq nil x)) + (values (funobj-name casf-funobj) x)) + ((not (logbitp 10 (dit-frame-ref stack frame :eflags :unsigned-byte16))) + (let ((funobj2 (dit-frame-ref stack frame :esi :lisp))) + (or (when (typep funobj2 'function) + (let ((x (code-vector-offset (funobj-code-vector funobj2) eip))) + (when x + (values (funobj-name funobj2) x)))) + (find-primitive-code-vector-by-eip eip))))))))) + ;; (setf next-frame (dit-frame-casf stack frame)) + (if (and conflate-interrupts conflate + ;; When the interrupted function has a stack-frame, conflate it. + (typep funobj 'function) + (= 1 (ldb (byte 1 5) (funobj-debug-info funobj)))) + (incf conflate-count) + (progn + (incf count) + (print-leadin stack frame count conflate-count) + (setf conflate-count 0) + (let ((exception (dit-frame-ref stack frame :exception-vector :unsigned-byte32))) + (if function-name + (format t "DIT exception ~D in ~W at PC offset ~D." + exception + function-name + code-vector-offset) + (format t "DIT exception ~D at EIP=~S with ESI=~S." + exception + eip + (dit-frame-ref stack frame :esi :unsigned-byte32))))))))) + (function + (let ((name (funobj-name funobj))) + (cond + ((and conflate (member name *backtrace-conflate-names* :test #'equal)) + (incf conflate-count)) + (t (incf count) + #+ignore (when (and *backtrace-stack-frame-barrier* + (<= *backtrace-stack-frame-barrier* stack-frame)) + (write-string " --|") + (return)) + (unless (or (not (integerp length)) + (< count length)) + (write-string " ...") + (return)) + (print-leadin stack frame count conflate-count) + (setf conflate-count 0) + (write-char #$) + (let* ((numargs (stack-frame-numargs stack frame)) + (map (and funobj (funobj-stack-frame-map funobj numargs)))) + (cond + ((and (car map) (eq name 'unbound-function)) + (let ((real-name (stack-frame-ref stack frame (car map)))) + (format t "{unbound ~S}" real-name))) + ((and (car map) + (member name +backtrace-gf-discriminatior-functions+)) + (let ((gf (stack-frame-ref stack frame (car map)))) + (cond + ((typep gf 'muerte::standard-gf-instance) + (format t "{gf ~S}" (funobj-name gf))) + (t (write-string "[not a gf??]"))) + (safe-print-stack-frame-arglist stack frame map :numargs numargs))) + (t (write name) + (safe-print-stack-frame-arglist stack frame map + :numargs numargs + :edx-p (eq 'muerte::&edx + (car (funobj-lambda-list funobj))))))) + (write-char #$) + (when (and (symbolp name) + (string= name 'toplevel-function)) + (write-char #\.) + (return)) + (write-char #\newline))))) + (t (print-leadin stack frame count conflate-count) + (format t "?: ~Z" funobj))) + (serious-condition (c) + (let ((*print-safely* t)) + (format t " - Error at ~S funobj ~S: ~A" + frame + (stack-frame-funobj nil frame) + c))))))) (values))

1 0

[movitz-cvs] CVS update: movitz/storage-types.lisp
by ffjeld＠common-lisp.net 27 Feb '05

27 Feb '05

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv21356 Modified Files: storage-types.lisp Log Message: Fix make-movitz-vector for lengths over (expt 2 14). Date: Sun Feb 27 03:31:36 2005 Author: ffjeld Index: movitz/storage-types.lisp diff -u movitz/storage-types.lisp:1.49 movitz/storage-types.lisp:1.50 --- movitz/storage-types.lisp:1.49 Mon Jan 17 11:54:21 2005 +++ movitz/storage-types.lisp Sun Feb 27 03:31:34 2005 @@ -9,7 +9,7 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: storage-types.lisp,v 1.49 2005/01/17 10:54:21 ffjeld Exp $ +;;;; $Id: storage-types.lisp,v 1.50 2005/02/27 02:31:34 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -514,9 +514,12 @@ (:any-t (map 'vector #'movitz-read initial-contents)) (t initial-contents)) - :fill-pointer (if (integerp fill-pointer) - fill-pointer - size)))) + :fill-pointer (cond + ((not (typep size '(unsigned-byte 14))) + 0) + ((integerp fill-pointer) + fill-pointer) + (t size))))) (defun make-movitz-string (string) (make-movitz-vector (length string)

1 0

[movitz-cvs] CVS update: movitz/compiler.lisp
by ffjeld＠common-lisp.net 27 Feb '05

27 Feb '05

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv21191 Modified Files: compiler.lisp Log Message: Have compile-lexical-variable always return final-form, even when in :ignored mode. Date: Sun Feb 27 03:30:30 2005 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.134 movitz/compiler.lisp:1.135 --- movitz/compiler.lisp:1.134 Wed Feb 2 08:48:58 2005 +++ movitz/compiler.lisp Sun Feb 27 03:30:22 2005 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.134 2005/02/02 07:48:58 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.135 2005/02/27 02:30:22 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -5704,7 +5704,8 @@ (check-type binding lexical-binding) (case (operator result-mode) (:ignore - (compiler-values ())) + (compiler-values () + :final-form binding)) (t (let ((returns (ecase (result-mode-type result-mode) ((:function :multiple-values :eax) :eax)

1 0

[movitz-cvs] CVS update: movitz/special-operators-cl.lisp
by ffjeld＠common-lisp.net 27 Feb '05

27 Feb '05

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv21082 Modified Files: special-operators-cl.lisp Log Message: Cleaned up the way forwarding-bindings are set up, in the let compiler. Date: Sun Feb 27 03:28:39 2005 Author: ffjeld Index: movitz/special-operators-cl.lisp diff -u movitz/special-operators-cl.lisp:1.45 movitz/special-operators-cl.lisp:1.46 --- movitz/special-operators-cl.lisp:1.45 Thu Feb 3 10:18:45 2005 +++ movitz/special-operators-cl.lisp Sun Feb 27 03:28:33 2005 @@ -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.45 2005/02/03 09:18:45 ffjeld Exp $ +;;;; $Id: special-operators-cl.lisp,v 1.46 2005/02/27 02:28:33 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -98,7 +98,7 @@ else collect (let ((binding (make-instance 'located-binding :name var))) (movitz-env-add-binding local-env binding) - (compiler-values-bind (&code init-code &functional-p functional-p + (compiler-values-bind (&code init-code &functional-p functional-p &type type &returns init-register &final-form final-form) (compiler-call #'compile-form-to-register @@ -225,12 +225,19 @@ #+ignore (warn "replace ~S in ~S with outer ~S" binding (binding-funobj binding) (second (first init-code))) - (let ((target (second (first init-code)))) + (compiler-values-bind (&code new-init-code &final-form target) + (compiler-call #'compile-form-unprotected + :form init-form + :result-mode :ignore + :env init-env + :defaults all) + (check-type target lexical-binding) (change-class binding 'forwarding-binding :target-binding target) - `((:init-lexvar ,binding - :init-with-register ,target - :init-with-type ,target)))) + (append new-init-code + `((:init-lexvar ,binding + :init-with-register ,target + :init-with-type ,target))))) ((and (typep binding 'located-binding) (type-specifier-singleton type) (not (code-uses-binding-p body-code binding

1 0