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

[movitz-cvs] CVS update: movitz/losp/muerte/arrays.lisp
by Frode Vatvedt Fjeld 25 Mar '04

25 Mar '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv32192 Modified Files: arrays.lisp Log Message: Remember to initialize flags fields when constructing simple-vectors. Date: Thu Mar 25 06:17:22 2004 Author: ffjeld Index: movitz/losp/muerte/arrays.lisp diff -u movitz/losp/muerte/arrays.lisp:1.7 movitz/losp/muerte/arrays.lisp:1.8 --- movitz/losp/muerte/arrays.lisp:1.7 Mon Mar 22 11:37:47 2004 +++ movitz/losp/muerte/arrays.lisp Thu Mar 25 06:17:22 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Sun Feb 11 23:14:04 2001 ;;;; -;;;; $Id: arrays.lisp,v 1.7 2004/03/22 16:37:47 ffjeld Exp $ +;;;; $Id: arrays.lisp,v 1.8 2004/03/25 11:17:22 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -555,12 +555,15 @@ :other-tag :vector :wide-other-tag #.(bt:enum-value 'movitz::movitz-vector-element-type :any-t)))) - (setf (memref array #.(bt:slot-offset 'movitz::movitz-vector 'movitz::type) - 0 :unsigned-byte16) - #.(movitz:vector-type-tag :any-t)) (setf (memref array #.(bt:slot-offset 'movitz::movitz-vector 'movitz::num-elements) 0 :unsigned-byte16) dimensions) + (setf (memref array #.(bt:slot-offset 'movitz::movitz-vector 'movitz::flags) + 0 :unsigned-byte16) + 0) + (setf (memref array #.(bt:slot-offset 'movitz::movitz-vector 'movitz::type) + 0 :unsigned-byte16) + #.(movitz:vector-type-tag :any-t)) (setf (fill-pointer array) fill-pointer) (cond (initial-contents

1 0

[movitz-cvs] CVS update: movitz/losp/los0.lisp
by Frode Vatvedt Fjeld 25 Mar '04

25 Mar '04

Update of /project/movitz/cvsroot/movitz/losp In directory common-lisp.net:/tmp/cvs-serv13432 Modified Files: los0.lisp Log Message: Add notification about *build-number* in genesis. Date: Thu Mar 25 04:24:01 2004 Author: ffjeld Index: movitz/losp/los0.lisp diff -u movitz/losp/los0.lisp:1.5 movitz/losp/los0.lisp:1.6 --- movitz/losp/los0.lisp:1.5 Wed Mar 24 08:25:13 2004 +++ movitz/losp/los0.lisp Thu Mar 25 04:24:00 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Dec 1 18:08:32 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: los0.lisp,v 1.5 2004/03/24 13:25:13 ffjeld Exp $ +;;;; $Id: los0.lisp,v 1.6 2004/03/25 09:24:00 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -595,9 +595,6 @@ (memref-int #x1000004 0 0 :unsigned-byte8))) - - - ;;;;; ;;;;;;;;;;;;;;; CL @@ -863,6 +860,7 @@ (let ((* nil) (** nil) (*** nil) (/ nil) (// nil) (/// nil) (+ nil) (++ nil) (+++ nil)) + (format t "~&Movitz image Los0 build ~D." *build-number*) (loop (catch :top-level-repl ; If restarts don't work, you can throw this.. (with-simple-restart (abort "Abort to the top command level.")

1 0

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

25 Mar '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv3327 Modified Files: basic-macros.lisp Log Message: Add "pointer" to the set of types that check-type inlines. Date: Wed Mar 24 19:55:12 2004 Author: ffjeld Index: movitz/losp/muerte/basic-macros.lisp diff -u movitz/losp/muerte/basic-macros.lisp:1.4 movitz/losp/muerte/basic-macros.lisp:1.5 --- movitz/losp/muerte/basic-macros.lisp:1.4 Fri Feb 20 10:10:43 2004 +++ movitz/losp/muerte/basic-macros.lisp Wed Mar 24 19:55:12 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.4 2004/02/20 15:10:43 ffjeld Exp $ +;;;; $Id: basic-macros.lisp,v 1.5 2004/03/25 00:55:12 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -510,7 +510,7 @@ ((movitz:movitz-constantp place env) (assert (typep (movitz::eval-form place env) type)) nil) - (t (if (member type '(standard-gf-instance function + (t (if (member type '(standard-gf-instance function pointer integer fixnum cons symbol character null list string vector simple-vector vector-u8 vector-u16)) `(unless (typep ,place ',type)

1 0

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

25 Mar '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv11463 Modified Files: compiler.lisp Log Message: Fixed nasty little bug in assign-bindings that would mess up everything if a function argument variable was lended to some closure. Date: Wed Mar 24 19:54:07 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.34 movitz/compiler.lisp:1.35 --- movitz/compiler.lisp:1.34 Wed Mar 24 13:38:18 2004 +++ movitz/compiler.lisp Wed Mar 24 19:54:07 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.34 2004/03/24 18:38:18 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.35 2004/03/25 00:54:07 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -2619,7 +2619,7 @@ ((typep binding 'forwarding-binding)) ((typep binding 'borrowed-binding)) ((typep binding 'fixed-required-function-argument) - (prog1 t + (prog1 nil ; may need lending-cons (setf (new-binding-location binding frame-map) :argument-stack))) ((not (plusp (or (car (gethash binding var-counts)) 0)))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/environment.lisp
by Frode Vatvedt Fjeld 25 Mar '04

25 Mar '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv5443 Modified Files: environment.lisp Log Message: Re-wrote the way tracing works. Use a designated closure for each traced function, rather than the same trace-wrapper function for everyone. Seems to work much better. Date: Wed Mar 24 19:52:54 2004 Author: ffjeld Index: movitz/losp/muerte/environment.lisp diff -u movitz/losp/muerte/environment.lisp:1.3 movitz/losp/muerte/environment.lisp:1.4 --- movitz/losp/muerte/environment.lisp:1.3 Wed Mar 24 14:33:40 2004 +++ movitz/losp/muerte/environment.lisp Wed Mar 24 19:52:54 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Sat Oct 20 00:41:57 2001 ;;;; -;;;; $Id: environment.lisp,v 1.3 2004/03/24 19:33:40 ffjeld Exp $ +;;;; $Id: environment.lisp,v 1.4 2004/03/25 00:52:54 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -67,60 +67,52 @@ ((equal name 'eval) (return nil)))))) -(defun trace-wrapper (&edx function-name-symbol &rest args) - (declare (dynamic-extent args)) - (check-type function-name-symbol symbol) - (let ((map (assoc function-name-symbol *trace-map* - :key #'function-name-symbol))) - (assert map () - "~S is not traced!?" function-name-symbol) - (let ((function-name (car map)) - (function (cadr map)) - (callers (caddr map))) - (cond - ((or *trace-escape* - (and (not (eq t callers)) - (notany 'match-caller callers))) - (apply function args)) - (t (let ((*trace-escape* t)) - (fresh-line *trace-output*) - (dotimes (i *trace-level*) - (write-string " " *trace-output*)) - (format *trace-output* "~D: (~S~{ ~S~})~%" - *trace-level* function-name args)) - (multiple-value-call - (lambda (&rest results) - (declare (dynamic-extent results)) - (let ((*trace-escape* t)) - (fresh-line *trace-output*) - (dotimes (i *trace-level*) - (write-string " " *trace-output*)) - (format *trace-output* "~&~D: =>~{ ~W~^,~}.~%" *trace-level* results) - (values-list results))) - (apply function args))))))) - (defun do-trace (function-name &key (callers t)) (when (assoc function-name *trace-map* :test #'equal) (do-untrace function-name)) (let ((function-symbol (function-name-symbol function-name))) (assert (fboundp function-symbol) (function-name) "Can't trace undefined function ~S." function-name) - (push (list function-name - (symbol-function function-symbol) - callers) - *trace-map*) - (setf (symbol-function function-symbol) - #'trace-wrapper)) + (let* ((real-function (symbol-function function-symbol)) + (wrapper (lambda (&rest args) + (declare (dynamic-extent args)) + (if *trace-escape* + (apply real-function args) + (let ((*trace-escape* t)) + (cond + ((and (not (eq t callers)) + (notany 'match-caller callers)) + (apply real-function args)) + (t (let ((*trace-escape* t)) + (fresh-line *trace-output*) + (dotimes (i *trace-level*) + (write-string " " *trace-output*)) + (format *trace-output* "~D: (~S~{ ~S~})~%" + *trace-level* function-name args)) + (multiple-value-call + (lambda (&rest results) + (declare (dynamic-extent results)) + (let ((*trace-escape* t)) + (fresh-line *trace-output*) + (dotimes (i *trace-level*) + (write-string " " *trace-output*)) + (format *trace-output* "~&~D: =>~{ ~W~^,~}.~%" *trace-level* results) + (values-list results))) + (let ((*trace-level* (1+ *trace-level*)) + (*trace-escape* nil)) + (apply real-function args)))))))))) + (push (cons function-name + real-function) + *trace-map*) + (setf (symbol-function function-symbol) + wrapper))) (values)) (defun do-untrace (name) (let ((map (assoc name *trace-map*))) (assert map () "~S is not traced." name) (let ((function-name-symbol (function-name-symbol name)) - (function (cadr map))) - (unless (eq (symbol-function function-name-symbol) - #'trace-wrapper) - (warn "~S was traced, but not fbound to trace-wrapper." name)) + (function (cdr map))) (setf (symbol-function function-name-symbol) function) (setf *trace-map*

1 0

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

25 Mar '04

Update of /project/movitz/cvsroot/movitz/losp/lib In directory common-lisp.net:/tmp/cvs-serv15200 Modified Files: repl.lisp Log Message: Some refactoring of read-eval-print. Now supports *repl-consless* which basically disables the / // /// variables, in order not to cons up lists for them. Date: Wed Mar 24 19:40:37 2004 Author: ffjeld Index: movitz/losp/lib/repl.lisp diff -u movitz/losp/lib/repl.lisp:1.4 movitz/losp/lib/repl.lisp:1.5 --- movitz/losp/lib/repl.lisp:1.4 Wed Feb 18 06:48:20 2004 +++ movitz/losp/lib/repl.lisp Wed Mar 24 19:40:35 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.4 2004/02/18 11:48:20 ffjeld Exp $ +;;;; $Id: repl.lisp,v 1.5 2004/03/25 00:40:35 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -23,8 +23,9 @@ (defparameter *repl-level* -1) (defparameter *repl-prompter* 'default-repl-prompter) (defparameter *repl-prompt-context* nil) -(defparameter *repl-print-format* "~{~&~W~}") +(defparameter *repl-print-format* "~@{~&~W~}") (defvar *repl-readline-context*) +(defvar *repl-consless* nil) (defun default-repl-prompter () (fresh-line) @@ -44,37 +45,41 @@ (terpri) (multiple-value-bind (form buffer-pointer) (handler-bind - ((muerte::missing-delimiter - (lambda (c) - (declare (ignore c)) - (format t "~&> ") - (invoke-restart 'muerte::next-line - (muerte.readline:contextual-readline *repl-readline-context*))))) + (#+ignore (muerte::missing-delimiter + (lambda (c) + (declare (ignore c)) + (format t "~&> ") + (invoke-restart 'muerte::next-line + (muerte.readline:contextual-readline *repl-readline-context*))))) (simple-read-from-string buffer-string t t)) - (let ((results (multiple-value-list - (if (keywordp form) - (apply 'muerte.toplevel:invoke-toplevel-command - form - (loop for arg = (multiple-value-bind (arg x) - (simple-read-from-string - buffer-string nil 'eof - :start buffer-pointer) - (setq buffer-pointer x) - arg) - until (eq arg 'eof) - collect arg)) - (eval form))))) - (unless (boundp '*) - (warn "* was unbound!") - (setf * nil)) - (format t *repl-print-format* results) - (psetq +++ ++ ++ + + form) - (psetq *** ** ** * * (first results)) - (psetq /// // // / / results)) - (unless (packagep *package*) - (warn "Resetting *package*..") - (setf *package* previous-package)))) - (values-list /)) + (multiple-value-call + (lambda (form previous-package &rest results) + (declare (dynamic-extent results)) + (unless (packagep *package*) + (warn "Resetting *package*") + (setf *package* previous-package)) + (unless (boundp '*) + (warn "* was unbound!") + (setf * nil)) + (apply #'format t *repl-print-format* results) + (psetq +++ ++ ++ + + form) + (psetq *** ** ** * * (car results)) + (psetq /// // // / / (if *repl-consless* + nil + (copy-list results))) + (values-list results)) + form previous-package + (if (not (keywordp form)) + (eval form) + (apply 'muerte.toplevel:invoke-toplevel-command + form + (loop for arg = (multiple-value-bind (arg x) + (simple-read-from-string buffer-string nil 'eof + :start buffer-pointer) + (setq buffer-pointer x) + arg) + until (eq arg 'eof) + collect arg))))))) #+ignore (muerte.readline::readline-break (c) (declare (ignore c)) (values))))

1 0

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

24 Mar '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv3521 Modified Files: variables.lisp Log Message: Use declaim rather than defvar for *build-number*. Date: Wed Mar 24 18:42:49 2004 Author: ffjeld Index: movitz/losp/muerte/variables.lisp diff -u movitz/losp/muerte/variables.lisp:1.2 movitz/losp/muerte/variables.lisp:1.3 --- movitz/losp/muerte/variables.lisp:1.2 Wed Mar 24 13:39:53 2004 +++ movitz/losp/muerte/variables.lisp Wed Mar 24 18:42:49 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.2 2004/03/24 18:39:53 ffjeld Exp $ +;;;; $Id: variables.lisp,v 1.3 2004/03/24 23:42:49 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -38,4 +38,4 @@ (defvar internal-time-units-per-second) -(defvar *build-number* :unknown) \ No newline at end of file +(declaim (special *build-number*)) \ No newline at end of file

1 0

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

24 Mar '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv29515 Modified Files: functions.lisp Log Message: Removed small pieces of dead code. Date: Wed Mar 24 15:40:41 2004 Author: ffjeld Index: movitz/losp/muerte/functions.lisp diff -u movitz/losp/muerte/functions.lisp:1.4 movitz/losp/muerte/functions.lisp:1.5 --- movitz/losp/muerte/functions.lisp:1.4 Wed Mar 24 08:33:21 2004 +++ movitz/losp/muerte/functions.lisp Wed Mar 24 15:40:40 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.4 2004/03/24 13:33:21 ffjeld Exp $ +;;;; $Id: functions.lisp,v 1.5 2004/03/24 20:40:40 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -56,8 +56,7 @@ complement-prototype (function ,(movitz:movitz-eval (translate-program function-form :cl :muerte.cl))))) - (t #+ignore (error "Non-constant complement forms not yet supported: ~S" form) - form))) + (t form))) (defun complement (function) (lambda (&rest args) @@ -72,8 +71,7 @@ (compiled-function (funobj-name edx)) (t '(unknown))))) - (error 'undefined-function :name function-name) - #+ignore (error "Unbound function-name ~S called with arguments ~S." function-name args))) + (error 'undefined-function :name function-name))) ;;; funobj object

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/environment.lisp
by Frode Vatvedt Fjeld 24 Mar '04

24 Mar '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv28849 Modified Files: environment.lisp Log Message: Re-wrote trace-wrapper not to cons. Date: Wed Mar 24 14:33:40 2004 Author: ffjeld Index: movitz/losp/muerte/environment.lisp diff -u movitz/losp/muerte/environment.lisp:1.2 movitz/losp/muerte/environment.lisp:1.3 --- movitz/losp/muerte/environment.lisp:1.2 Mon Jan 19 06:23:46 2004 +++ movitz/losp/muerte/environment.lisp Wed Mar 24 14:33:40 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Sat Oct 20 00:41:57 2001 ;;;; -;;;; $Id: environment.lisp,v 1.2 2004/01/19 11:23:46 ffjeld Exp $ +;;;; $Id: environment.lisp,v 1.3 2004/03/24 19:33:40 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -88,14 +88,16 @@ (write-string " " *trace-output*)) (format *trace-output* "~D: (~S~{ ~S~})~%" *trace-level* function-name args)) - (let ((result (let ((*trace-level* (1+ *trace-level*))) - (multiple-value-list (apply function args)))) - (*trace-escape* t)) - (fresh-line *trace-output*) - (dotimes (i *trace-level*) - (write-string " " *trace-output*)) - (format *trace-output* "~D: => ~:S~%" *trace-level* result) - (values-list result))))))) + (multiple-value-call + (lambda (&rest results) + (declare (dynamic-extent results)) + (let ((*trace-escape* t)) + (fresh-line *trace-output*) + (dotimes (i *trace-level*) + (write-string " " *trace-output*)) + (format *trace-output* "~&~D: =>~{ ~W~^,~}.~%" *trace-level* results) + (values-list results))) + (apply function args))))))) (defun do-trace (function-name &key (callers t)) (when (assoc function-name *trace-map* :test #'equal)

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/format.lisp
by Frode Vatvedt Fjeld 24 Mar '04

24 Mar '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv15844 Modified Files: format.lisp Log Message: Fixed ~{ format directive which didn't play quite right with ~^. Date: Wed Mar 24 14:30:15 2004 Author: ffjeld Index: movitz/losp/muerte/format.lisp diff -u movitz/losp/muerte/format.lisp:1.2 movitz/losp/muerte/format.lisp:1.3 --- movitz/losp/muerte/format.lisp:1.2 Mon Jan 19 06:23:46 2004 +++ movitz/losp/muerte/format.lisp Wed Mar 24 14:30:15 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Sat Mar 23 01:18:36 2002 ;;;; -;;;; $Id: format.lisp,v 1.2 2004/01/19 11:23:46 ffjeld Exp $ +;;;; $Id: format.lisp,v 1.3 2004/03/24 19:30:15 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -241,10 +241,10 @@ (multiple-value-setq (i args) (format-by-string control-string (1+ i) (1- loop-limit) args)))) (t (let ((loop-args (pop args))) - (if (or (zerop loop-limit) (null loop-args)) - (setf i (skip-iteration control-string (1+ i))) - (setf i (format-by-string control-string (1+ i) - (1- loop-limit) loop-args))))))))) + (unless (or (zerop loop-limit) (null loop-args)) + (format-by-string control-string (1+ i) + (1- loop-limit) loop-args)) + (setf i (skip-iteration control-string (1+ i))))))))) (#\} (if (and args (or (not loop-limit) (not (zerop loop-limit)))) (setf loop-limit (and loop-limit (1- loop-limit)) i (1- start))

1 0