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

[movitz-cvs] CVS ia-x86
by ffjeld 26 Feb '07

26 Feb '07

Update of /project/movitz/cvsroot/ia-x86 In directory clnet:/tmp/cvs-serv9316 Modified Files: codec.lisp Log Message: Have sign-extend-complex deal correctly with bytes of size 0. --- /project/movitz/cvsroot/ia-x86/codec.lisp 2005/08/13 20:24:04 1.7 +++ /project/movitz/cvsroot/ia-x86/codec.lisp 2007/02/26 22:14:00 1.8 @@ -9,7 +9,7 @@ ;;;; Created at: Thu May 4 15:16:45 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: codec.lisp,v 1.7 2005/08/13 20:24:04 ffjeld Exp $ +;;;; $Id: codec.lisp,v 1.8 2007/02/26 22:14:00 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -672,10 +672,13 @@ that byte (i.e. #c(255 1) => -1)." (let ((old-byte (realpart cdatum)) (numo (imagpart cdatum))) - (if (zerop (ldb (byte 1 (1- (* 8 numo))) old-byte)) - cdatum - (complex (- old-byte (dpb 1 (byte 1 (* 8 numo)) 0)) - numo)))) + (cond + ((= 0 numo) + 0) + ((zerop (ldb (byte 1 (1- (* 8 numo))) old-byte)) + cdatum) + (t (complex (- old-byte (dpb 1 (byte 1 (* 8 numo)) 0)) + numo))))) (defun sign-extend (old-byte numo) "Given a two's complement signed byte (where the most significant

1 0

[movitz-cvs] CVS movitz/ide
by ffjeld 26 Feb '07

26 Feb '07

Update of /project/movitz/cvsroot/movitz/ide In directory clnet:/tmp/cvs-serv32175 Modified Files: ide.lisp Log Message: Take advantage of movitz:movitz-compile-stream. --- /project/movitz/cvsroot/movitz/ide/ide.lisp 2004/08/02 07:45:30 1.2 +++ /project/movitz/cvsroot/movitz/ide/ide.lisp 2007/02/26 21:32:55 1.3 @@ -14,19 +14,14 @@ (in-package #:movitz.ide) -(defconstant temp-source-file "/tmp/movitz-scratch.lisp" - "Temporary file used to implement race conditions.") - (defun compile-movitz-file (filename) "Compile FILENAME as Movitz source." (movitz:movitz-compile-file filename)) (defun compile-defun (source) "Compile the string SOURCE as Movitz source." - (with-open-file (s temp-source-file :direction :output - :if-exists :overwrite :if-does-not-exist :create) - (princ source s)) - (compile-movitz-file temp-source-file)) + (with-input-from-string (stream source) + (movitz:movitz-compile-stream stream :path "movitz-ide-toplevel"))) (defun dump-image (filename) "Dump the current image into FILENAME." @@ -41,7 +36,7 @@ (defun disassemble-fdefinition (symbol) "Return the disassembly SYMBOL's fdefinition as a string." (with-output-to-string (*standard-output*) - (movitz::movitz-disassemble symbol))) + (movitz:movitz-disassemble symbol))) ;;;; Utilities.

1 0

[movitz-cvs] CVS movitz
by ffjeld 26 Feb '07

26 Feb '07

Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv28781 Modified Files: packages.lisp Log Message: Export movitz:movitz-compile-file and movitz:movitz-disassemble. --- /project/movitz/cvsroot/movitz/packages.lisp 2005/08/26 22:50:36 1.54 +++ /project/movitz/cvsroot/movitz/packages.lisp 2007/02/26 21:19:55 1.55 @@ -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.54 2005/08/26 22:50:36 ffjeld Exp $ +;;;; $Id: packages.lisp,v 1.55 2007/02/26 21:19:55 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1299,6 +1299,8 @@ #:movitz-subtypep #:movitz-compile-file + #:movitz-compile-stream + #:movitz-disassemble #:movitz-std-instance #:movitz-struct

1 0

[movitz-cvs] CVS movitz
by ffjeld 26 Feb '07

26 Feb '07

Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv28550 Modified Files: compiler.lisp Log Message: Refactor movitz-compile-file & friends, primarily in order to expose new function movitz-compile-stream. --- /project/movitz/cvsroot/movitz/compiler.lisp 2007/02/22 21:00:21 1.178 +++ /project/movitz/cvsroot/movitz/compiler.lisp 2007/02/26 21:18:37 1.179 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.178 2007/02/22 21:00:21 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.179 2007/02/26 21:18:37 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1223,252 +1223,99 @@ 1)) (t (error "make-2req confused by loc0: ~W, loc1: ~W" location-0 location-1))))) -;;;(defun make-compiled-function-body-1rest (form funobj env top-level-p) -;;; (when (and (null (required-vars env)) -;;; (null (optional-vars env)) -;;; (null (key-vars env)) -;;; (rest-var env)) -;;; (multiple-value-bind (code stack-frame-size use-stack-frame-p frame-map) -;;; (make-compiled-body form funobj env top-level-p) -;;; (let* ((rest-binding (movitz-binding (rest-var env) env nil)) -;;; (edx-location (and (edx-var env) -;;; (new-binding-location (edx-var env) frame-map -;;; :default nil))) -;;; (edx-code (when edx-location -;;; `((:movl :edx (:ebp ,(stack-frame-offset edx-location))))))) -;;; (cond -;;; ((not (new-binding-located-p rest-binding frame-map)) -;;; (append '(entry%1op -;;; entry%2op -;;; entry%3op) -;;; (when use-stack-frame-p -;;; +enter-stack-frame-code+) -;;; '(start-stack-frame-setup) -;;; (make-compiled-stack-frame-init stack-frame-size) -;;; edx-code -;;; code -;;; (make-compiled-function-postlude funobj env use-stack-frame-p))) -;;; (t ;; (new-binding-located-p rest-binding frame-map) -;;; (let ((rest-location (new-binding-location rest-binding frame-map))) -;;; (values (append +enter-stack-frame-code+ -;;; '(start-stack-frame-setup) -;;; (make-compiled-stack-frame-init stack-frame-size) -;;; `((:movl :edi (:ebp ,(stack-frame-offset rest-location)))) -;;; edx-code -;;; `((:testb :cl :cl) -;;; (:jz 'end-stack-frame-setup) -;;; (:js '(:sub-program (normalize-ecx) -;;; (:shrl 8 :ecx) -;;; (:jmp 'ecx-ok))) -;;; (:andl #x7f :ecx) -;;; ecx-ok -;;; (:xorl :edx :edx) -;;; (:call (:edi ,(global-constant-offset 'restify-dynamic-extent))) -;;; (:movl :eax (:ebp ,(stack-frame-offset rest-location))) -;;; (:jmp 'end-stack-frame-setup)) -;;; `(entry%1op -;;; ,@+enter-stack-frame-code+ -;;; ,@(make-compiled-stack-frame-init stack-frame-size) -;;; ,@edx-code -;;; (:andl -8 :esp) -;;; (:pushl :edi) -;;; (:pushl :eax) -;;; (:leal (:esp 1) :ecx) -;;; (:movl :ecx (:ebp ,(stack-frame-offset rest-location))) -;;; (:jmp 'end-stack-frame-setup)) -;;; `(entry%2op -;;; ,@+enter-stack-frame-code+ -;;; ,@(make-compiled-stack-frame-init stack-frame-size) -;;; ,@edx-code -;;; (:andl -8 :esp) -;;; (:pushl :edi) -;;; (:pushl :ebx) -;;; (:leal (:esp 1) :ecx) -;;; (:pushl :ecx) -;;; (:pushl :eax) -;;; (:leal (:esp 1) :ecx) -;;; (:movl :ecx (:ebp ,(stack-frame-offset rest-location))) -;;; (:jmp 'end-stack-frame-setup)) -;;; '(end-stack-frame-setup) -;;; code -;;; (make-compiled-function-postlude funobj env t)) -;;; use-stack-frame-p)))))))) - -;;;(defun make-compiled-function-body-1req-1opt (form funobj env top-level-p) -;;; (when (and (= 1 (length (required-vars env))) -;;; (= 1 (length (optional-vars env))) -;;; (= 0 (length (key-vars env))) -;;; (null (rest-var env))) -;;; (let* ((opt-var (first (optional-vars env))) -;;; (opt-binding (movitz-binding opt-var env nil)) -;;; (req-binding (movitz-binding (first (required-vars env)) env nil)) -;;; (default-form (optional-function-argument-init-form opt-binding))) -;;; (compiler-values-bind (&code opt-default-code &producer opt-default-producer) -;;; (compiler-call #'compile-form -;;; :form default-form -;;; :result-mode :push -;;; :env env -;;; :funobj funobj) -;;; (cond -;;; ((eq 'compile-self-evaluating opt-default-producer) -;;; (multiple-value-bind (code stack-frame-size use-stack-frame-p frame-map) -;;; (make-compiled-body form funobj env top-level-p nil (list opt-default-code)) -;;; (declare (ignore use-stack-frame-p)) -;;; (let ((use-stack-frame-p t)) -;;; (cond -;;; ((and (new-binding-located-p req-binding frame-map) -;;; (new-binding-located-p opt-binding frame-map)) -;;; (multiple-value-bind (eax-ebx-code eax-ebx-stack-offset) -;;; (ecase (new-binding-location req-binding frame-map) -;;; ;; might well be more cases here, but let's wait till they show up.. -;;; (:eax (values nil 0)) -;;; (1 (values '((:pushl :eax)) 1))) -;;; ;; (warn "defc: ~S" opt-default-code) -;;; (let ((stack-init-size (- stack-frame-size eax-ebx-stack-offset)) -;;; (installed-default-code (finalize-code opt-default-code funobj env frame-map))) -;;; (values (append `((:call (:edi ,(global-constant-offset 'decode-args-1or2))) -;;; entry%2op -;;; (:pushl :ebp) -;;; (:movl :esp :ebp) -;;; (:pushl :esi) -;;; start-stack-frame-setup -;;; ,@eax-ebx-code -;;; ,@(if (eql (1+ eax-ebx-stack-offset) -;;; (new-binding-location opt-binding frame-map)) -;;; (append `((:pushl :ebx)) -;;; (make-compiled-stack-frame-init (1- stack-init-size))) -;;; (append (make-compiled-stack-frame-init stack-init-size) -;;; `((:movl :ebx (:ebp ,(stack-frame-offset -;;; (new-binding-location opt-binding -;;; frame-map))))))) -;;; (:jmp 'arg-init-done) -;;; entry%1op -;;; (:pushl :ebp) -;;; (:movl :esp :ebp) -;;; (:pushl :esi) -;;; ,@eax-ebx-code -;;; ,@(if (eql (1+ eax-ebx-stack-offset) -;;; (new-binding-location opt-binding frame-map)) -;;; (append installed-default-code -;;; (make-compiled-stack-frame-init (1- stack-init-size))) -;;; (append (make-compiled-stack-frame-init stack-init-size) -;;; installed-default-code -;;; `((:popl (:ebp ,(stack-frame-offset -;;; (new-binding-location opt-binding -;;; frame-map))))))) -;;; arg-init-done) -;;; code -;;; (make-compiled-function-postlude funobj env t)) -;;; use-stack-frame-p)))) -;;; ((and (new-binding-located-p req-binding frame-map) -;;; (not (new-binding-located-p opt-binding frame-map))) -;;; (multiple-value-bind (eax-code eax-stack-offset) -;;; (ecase (new-binding-location req-binding frame-map) -;;; (:eax (values nil 0)) -;;; (1 (values '((:pushl :eax)) 1))) -;;; (values (append `((:call (:edi ,(global-constant-offset 'decode-args-1or2))) -;;; ;; (:jmp 'decode-numargs) -;;; entry%1op -;;; entry%2op -;;; (:pushl :ebp) -;;; (:movl :esp :ebp) -;;; (:pushl :esi)) -;;; eax-code -;;; (make-compiled-stack-frame-init (- stack-frame-size eax-stack-offset)) -;;; code -;;; (make-compiled-function-postlude funobj env t)) -;;; use-stack-frame-p))) -;;; (t (warn "1-req-1-opt failed")))))) -;;; (t nil)))))) (defun movitz-compile-file (path &key ((:image *image*) *image*) - load-priority - (delete-file-p nil)) + load-priority + (delete-file-p nil)) (handler-bind - (#+sbcl (sb-ext:defconstant-uneql #'continue) - #+lispworks-personal-edition - (conditions:stack-overflow (lambda (&optional c) - (declare (ignore c)) - (warn "Stack overflow. Skipping function ~S.~%" - *compiling-function-name*) - (invoke-restart 'skip-toplevel-form))) - #+ignore ((or error warning) (lambda (c) - (declare (ignore c)) - (format *error-output* "~&;; In file ~S:" path)))) + (#+sbcl (sb-ext:defconstant-uneql #'continue)) (unwind-protect - (let ((*movitz-host-features* *features*) - (*features* (image-movitz-features *image*))) - (multiple-value-prog1 - (movitz-compile-file-internal path load-priority) - (unless (equalp *features* (image-movitz-features *image*)) - (warn "*features* changed from ~S to ~S." (image-movitz-features *image*) *features*) - (setf (image-movitz-features *image*) *features*)))) + (let ((*movitz-host-features* *features*) + (*features* (image-movitz-features *image*))) + (multiple-value-prog1 + (movitz-compile-file-internal path load-priority) + (unless (equalp *features* (image-movitz-features *image*)) + (warn "*features* changed from ~S to ~S." (image-movitz-features *image*) *features*) + (setf (image-movitz-features *image*) *features*)))) (when delete-file-p (assert (equal (pathname-directory "/tmp/") (pathname-directory path)) - (path) - "Refusing to delete file not in /tmp.") + (path) + "Refusing to delete file not in /tmp.") (delete-file path))))) -(defun movitz-compile-file-internal (path - &optional (*default-load-priority* - (and (boundp '*default-load-priority*) - (symbol-value '*default-load-priority*) - (1+ (symbol-value '*default-load-priority*))))) +(defun movitz-compile-file-internal (path &optional (*default-load-priority* + (and (boundp '*default-load-priority*) + (symbol-value '*default-load-priority*) + (1+ (symbol-value '*default-load-priority*))))) (declare (special *default-load-priority*)) (with-simple-restart (continue "Skip Movitz compilation of ~S." path) (with-retries-until-true (retry "Restart Movitz compilation of ~S." path) - ;; (warn "Compiling ~A.." path) - (let* ((muerte.cl::*compile-file-pathname* path) - (*package* (find-package :muerte)) - (funobj (make-instance 'movitz-funobj-pass1 - :name (intern (format nil "~A" path) :muerte) - :lambda-list (movitz-read nil))) - (funobj-env (make-local-movitz-environment nil funobj - :type 'funobj-env - :declaration-context :funobj)) - (function-env (make-local-movitz-environment funobj-env funobj - :type 'function-env - :declaration-context :funobj)) - (file-code - (with-compilation-unit () - (add-bindings-from-lambda-list () function-env) - (with-open-file (stream path :direction :input) - (setf (funobj-env funobj) funobj-env) - (loop for form = (with-movitz-syntax () - (read stream nil '#0=#:eof)) - until (eq form '#0#) - appending - (with-simple-restart (skip-toplevel-form - "Skip the compilation of top-level form~@[ ~A~]." - (cond - ((symbolp form) form) - ((symbolp (car form)) (car form)))) - (when *compiler-verbose-p* - (format *query-io* "~&Movitz Compiling ~S..~%" - (cond - ((symbolp form) form) - ((symbolp (car form)) - (xsubseq form 0 2))))) - (compiler-call #'compile-form - :form form - :funobj funobj - :env function-env - :top-level-p t - :result-mode :ignore))))))) - (cond - ((null file-code) - (setf (image-load-time-funobjs *image*) - (delete funobj (image-load-time-funobjs *image*) :key #'first)) - 'muerte::constantly-true) - (t (setf (extended-code function-env) file-code - (need-normalized-ecx-p function-env) nil - (function-envs funobj) (list (cons 'muerte.cl::t function-env)) - (funobj-env funobj) funobj-env) - (make-compiled-funobj-pass2 funobj) - (let ((name (funobj-name funobj))) - (setf (movitz-env-named-function name) funobj) - name))))))) + (with-open-file (stream path :direction :input) + (movitz-compile-stream-internal stream :path path))))) + +(defun movitz-compile-stream (stream &key (path "unknown-toplevel.lisp")) + (handler-bind + (#+sbcl (sb-ext:defconstant-uneql #'continue)) + (unwind-protect + (let ((*movitz-host-features* *features*) + (*features* (image-movitz-features *image*))) + (multiple-value-prog1 + (movitz-compile-stream-internal stream :path path) + (unless (equalp *features* (image-movitz-features *image*)) + (warn "*features* changed from ~S to ~S." (image-movitz-features *image*) *features*) + (setf (image-movitz-features *image*) *features*))))))) + +(defun movitz-compile-stream-internal (stream &key (path "unknown-toplevel.lisp")) + (let* ((muerte.cl::*compile-file-pathname* path) + (*package* (find-package :muerte)) + (funobj (make-instance 'movitz-funobj-pass1 + :name (intern (format nil "~A" path) :muerte) + :lambda-list (movitz-read nil))) + (funobj-env (make-local-movitz-environment nil funobj + :type 'funobj-env + :declaration-context :funobj)) + (function-env (make-local-movitz-environment funobj-env funobj + :type 'function-env + :declaration-context :funobj)) + (file-code + (with-compilation-unit () + (add-bindings-from-lambda-list () function-env) + (setf (funobj-env funobj) funobj-env) + (loop for form = (with-movitz-syntax () + (read stream nil '#0=#:eof)) + until (eq form '#0#) + appending + (with-simple-restart (skip-toplevel-form + "Skip the compilation of top-level form~@[ ~A~]." + (cond + ((symbolp form) form) + ((symbolp (car form)) (car form)))) + (when *compiler-verbose-p* + (format *query-io* "~&Movitz Compiling ~S..~%" + (cond + ((symbolp form) form) + ((symbolp (car form)) + (xsubseq form 0 2))))) + (compiler-call #'compile-form + :form form + :funobj funobj + :env function-env + :top-level-p t + :result-mode :ignore)))))) + (cond + ((null file-code) + (setf (image-load-time-funobjs *image*) + (delete funobj (image-load-time-funobjs *image*) :key #'first)) + 'muerte::constantly-true) + (t (setf (extended-code function-env) file-code + (need-normalized-ecx-p function-env) nil + (function-envs funobj) (list (cons 'muerte.cl::t function-env)) + (funobj-env funobj) funobj-env) + (make-compiled-funobj-pass2 funobj) + (let ((name (funobj-name funobj))) + (setf (movitz-env-named-function name) funobj) + name))))) ;;;;

1 0

[movitz-cvs] CVS movitz
by ffjeld 26 Feb '07

26 Feb '07

Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv23043 Modified Files: special-operators.lisp Log Message: don't use keyword properties for CL symbols. --- /project/movitz/cvsroot/movitz/special-operators.lisp 2006/04/10 11:47:14 1.55 +++ /project/movitz/cvsroot/movitz/special-operators.lisp 2007/02/26 18:25:21 1.56 @@ -8,7 +8,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Nov 24 16:22:59 2000 ;;;; -;;;; $Id: special-operators.lisp,v 1.55 2006/04/10 11:47:14 ffjeld Exp $ +;;;; $Id: special-operators.lisp,v 1.56 2007/02/26 18:25:21 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -328,7 +328,7 @@ (multiple-value-bind (cl-body declarations doc-string) (parse-docstring-declarations-and-body cl-macro-body 'cl:declare) (declare (ignore doc-string)) - (setf (movitz-env-get access-fn :setf-expander nil) + (setf (movitz-env-get access-fn 'muerte::setf-expander nil) (let* ((form-formal (or wholevar (gensym))) (env-formal (or envvar (gensym))) (expander (if (null cl-lambda-list)

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 26 Feb '07

26 Feb '07

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv22556 Modified Files: eval.lisp Log Message: Added trivial constantp and macro-function. --- /project/movitz/cvsroot/movitz/losp/muerte/eval.lisp 2005/04/20 06:53:23 1.17 +++ /project/movitz/cvsroot/movitz/losp/muerte/eval.lisp 2007/02/26 18:22:27 1.18 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Oct 19 21:15:12 2001 ;;;; -;;;; $Id: eval.lisp,v 1.17 2005/04/20 06:53:23 ffjeld Exp $ +;;;; $Id: eval.lisp,v 1.18 2007/02/26 18:22:27 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -444,3 +444,17 @@ ;; What do do? (warn "Unknown declaration: ~S" declaration) (values)) + + +(defun constantp (form &optional environment) + (typecase form + (boolean t) + (keyword t) + (symbol nil) + (cons (eq 'quote (car form))) + (t t))) + +(defun macro-function (symbol &optional environment) + "=> function" + (declare (ignore symbol environment)) + nil)

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 22 Feb '07

22 Feb '07

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv19944 Modified Files: symbols.lisp Log Message: Added function remprop. --- /project/movitz/cvsroot/movitz/losp/muerte/symbols.lisp 2004/11/25 16:46:01 1.27 +++ /project/movitz/cvsroot/movitz/losp/muerte/symbols.lisp 2007/02/22 22:11:21 1.28 @@ -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.27 2004/11/25 16:46:01 ffjeld Exp $ +;;;; $Id: symbols.lisp,v 1.28 2007/02/22 22:11:21 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -253,3 +253,6 @@ (declare (ignore default)) (setf (getf (symbol-plist symbol) indicator) value)) + +(defun remprop (symbol indicator) + (remf (symbol-plist symbol) indicator))

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 22 Feb '07

22 Feb '07

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv15249 Modified Files: cons.lisp Log Message: Have tree-equal return singular value. --- /project/movitz/cvsroot/movitz/losp/muerte/cons.lisp 2006/05/06 20:30:53 1.16 +++ /project/movitz/cvsroot/movitz/losp/muerte/cons.lisp 2007/02/22 21:23:04 1.17 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Dec 8 15:25:45 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: cons.lisp,v 1.16 2006/05/06 20:30:53 ffjeld Exp $ +;;;; $Id: cons.lisp,v 1.17 2007/02/22 21:23:04 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -265,7 +265,7 @@ (defun tree-equal (tree-1 tree-2 &key test test-not) (labels ((te (tree-1 tree-2 test) (if (not (consp tree-1)) - (funcall test tree-1 tree-2) + (values (funcall test tree-1 tree-2)) (if (not (consp tree-2)) nil (and (te (car tree-1) (car tree-2) test)

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 22 Feb '07

22 Feb '07

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv13103 Modified Files: interrupt.lisp Log Message: Tweaks to exception-to-error mapping. --- /project/movitz/cvsroot/movitz/losp/muerte/interrupt.lisp 2007/02/19 20:24:54 1.53 +++ /project/movitz/cvsroot/movitz/losp/muerte/interrupt.lisp 2007/02/22 21:03:50 1.54 @@ -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.53 2007/02/19 20:24:54 ffjeld Exp $ +;;;; $Id: interrupt.lisp,v 1.54 2007/02/22 21:03:50 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -316,14 +316,22 @@ ((60) ;; EAX failed type in EDX. May be restarted by returning with a new value in EAX. (with-simple-restart (continue "Retry with a different value.") - (error 'type-error :datum (dereference $eax) :expected-type (dereference $edx))) + (error 'type-error + :datum (dereference $eax) + :expected-type (dereference $edx))) (format *query-io* "Enter a new value: ") (setf (dereference $eax) (read *query-io*))) - (61 (error 'type-error :datum (dereference $eax) :expected-type 'list)) + (61 (error 'type-error + :datum (dereference $eax) + :expected-type 'list)) (62 (error "Trying to save too many values: ~@Z." $ecx)) (63 (error "Primitive assertion error. EIP=~@Z, ESI=~@Z." $eip $esi)) - (64 (error 'type-error :datum (dereference $eax) :expected-type 'integer)) - (65 (error 'index-out-of-range :index (dereference $ebx) (dereference $ecx))) + (64 (error 'type-error + :datum (dereference $eax) + :expected-type 'integer)) + (65 (error 'index-out-of-range + :index (dereference $ebx) + :range (dereference $ecx))) (66 (error "Unspecified type error at ~@Z in ~S with EAX=~@Z, ECX=~@Z." $eip (dereference (+ dit-frame (dit-frame-index :esi))) $eax $ecx))

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 22 Feb '07

22 Feb '07

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv13062 Modified Files: basic-macros.lisp Log Message: Tweak check-type compiler-macro to support retry restart. --- /project/movitz/cvsroot/movitz/losp/muerte/basic-macros.lisp 2007/02/20 23:11:22 1.68 +++ /project/movitz/cvsroot/movitz/losp/muerte/basic-macros.lisp 2007/02/22 21:03:10 1.69 @@ -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.68 2007/02/20 23:11:22 ffjeld Exp $ +;;;; $Id: basic-macros.lisp,v 1.69 2007/02/22 21:03:10 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -558,14 +558,16 @@ (t (if (member type '(standard-gf-instance function pointer atom integer fixnum positive-fixnum cons symbol character null list string vector simple-vector vector-u8 vector-u16)) - `(with-inline-assembly (:returns :nothing :labels (fail)) + `(with-inline-assembly (:returns :nothing :labels (check-type-failed retry-check-type)) + retry-check-type (:compile-form (:result-mode (:boolean-branch-on-false . check-type-failed)) (typep ,place ',type)) - (() () '(:sub-program (check-type-failed) (:int 66)))) - #+ignore - `(unless (typep ,place ',type) - (with-inline-assembly (:returns :non-local-exit) - (:int 66))) + (:jnever '(:sub-program (check-type-failed) + (:compile-form (:result-mode :edx) (quote ,type)) + (:compile-form (:result-mode :ignore) + (setf ,place (with-inline-assembly (:returns :eax) + (:int 60)))) + (:jmp 'retry-check-type)))) form)))) (defmacro assert (test-form &optional places datum-form &rest argument-forms)

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 22 Feb '07

22 Feb '07

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv13001 Modified Files: arrays.lisp Log Message: Use :jnever assembly syntax. --- /project/movitz/cvsroot/movitz/losp/muerte/arrays.lisp 2006/05/05 18:14:41 1.59 +++ /project/movitz/cvsroot/movitz/losp/muerte/arrays.lisp 2007/02/22 21:02:09 1.60 @@ -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.59 2006/05/05 18:14:41 ffjeld Exp $ +;;;; $Id: arrays.lisp,v 1.60 2007/02/22 21:02:09 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -348,7 +348,8 @@ (:jmp (:esi (:ecx 4) 'basic-vector-dispatcher ,(bt:slot-offset 'movitz:movitz-funobj 'movitz::constant0))) - (() () '(:sub-program (unknown) (:int 100))) + (:jnever '(:sub-program (unknown) + (:int 100))) :u32 (:movl (:eax :ebx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data)) :ecx)

1 0

[movitz-cvs] CVS movitz
by ffjeld 22 Feb '07

22 Feb '07

Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv12394 Modified Files: compiler.lisp Log Message: Fixed up layout-program and related functions a bit. Removed remnants of old &key parsing strategy. --- /project/movitz/cvsroot/movitz/compiler.lisp 2007/02/20 21:57:13 1.177 +++ /project/movitz/cvsroot/movitz/compiler.lisp 2007/02/22 21:00:21 1.178 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.177 2007/02/20 21:57:13 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.178 2007/02/22 21:00:21 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1484,7 +1484,7 @@ (new-program nil)) ((endp pc) (assert (not pending-subs) () - "pending subs: ~S" pending-subs) + "pending sub-programs: ~S" pending-subs) (nreverse new-program)) (let ((i (pop pc))) (multiple-value-bind (sub-prg sub-opts) @@ -2605,15 +2605,11 @@ (defclass supplied-p-function-argument (function-argument) ()) (defclass rest-function-argument (positional-function-argument) ()) -(defclass hidden-rest-function-argument (rest-function-argument) ()) (defclass keyword-function-argument (non-required-function-argument) ((keyword-name :initarg :keyword-name - :reader keyword-function-argument-keyword-name) - (rest-var-name - :initarg :rest-var-name - :reader keyword-function-argument-rest-var-name))) + :reader keyword-function-argument-keyword-name))) (defclass dynamic-binding (variable-binding) ()) @@ -2745,25 +2741,26 @@ ;;; -(defun instruction-sub-program (instruction) - "When an instruction contains a sub-program, return that program, and -the sub-program options (&optional label) as secondary value." - (and (consp instruction) - (consp (second instruction)) - (symbolp (car (second instruction))) - (string= 'quote (car (second instruction))) - (let ((x (second (second instruction)))) - (and (consp x) - (eq :sub-program (car x)) - (values (cddr x) - (second x)))))) - (defun ignore-instruction-prefixes (instruction) (if (and (consp instruction) (listp (car instruction))) (cdr instruction) instruction)) +(defun instruction-sub-program (instruction) + "When an instruction contains a sub-program, return that program, and +the sub-program options (&optional label) as secondary value." + (let ((instruction (ignore-instruction-prefixes instruction))) + (and (consp instruction) + (consp (second instruction)) + (symbolp (car (second instruction))) + (string= 'quote (car (second instruction))) + (let ((x (second (second instruction)))) + (and (consp x) + (eq :sub-program (car x)) + (values (cddr x) + (second x))))))) + (defun instruction-is (instruction &optional operator) (and (listp instruction) (if (member (car instruction) '(:globally :locally)) @@ -3205,7 +3202,6 @@ (binding-env binding) nil) (movitz-env-get variable 'ignorable nil (binding-env binding) nil) - (typep binding 'hidden-rest-function-argument) (third (gethash binding var-counts))) (warn "Unused variable: ~S" (binding-name binding)))) @@ -4410,11 +4406,6 @@ (movitz-env-add-binding env (make-instance 'rest-function-argument :name formal :argnum (post-incf arg-pos))))) -;;; (when key-vars-p -;;; ;; We need to check at run-time whether keyword checking is supressed or not. -;;; (setf (allow-other-keys-var env) -;;; (movitz-env-add-binding env (make-instance 'located-binding -;;; :name (gensym "allow-other-keys-var-"))))) (when key-vars-p (setf (key-vars-p env) t) (when (>= 1 (rest-args-position env)) @@ -4436,28 +4427,16 @@ (setf (movitz-env-get name 'ignore nil env) t)))) (setf (key-vars env) (loop for spec in key-vars - with rest-var-name = - (or rest-var - (and key-vars - (let ((name (gensym "hidden-rest-var-"))) - (movitz-env-add-binding env (make-instance 'hidden-rest-function-argument - :name name - :argnum (post-incf arg-pos))) - name))) collect (multiple-value-bind (formal keyword-name init-form supplied-p) (decode-keyword-formal spec) - (let ((formal - (shadow-when-special formal env)) - (supplied-p-parameter - (or supplied-p - #+ignore (gensym "supplied-p-")))) + (let ((formal (shadow-when-special formal env)) + (supplied-p-parameter supplied-p)) (movitz-env-add-binding env (make-instance 'keyword-function-argument :name formal 'init-form init-form 'supplied-p-var supplied-p-parameter - :keyword-name keyword-name - :rest-var-name rest-var-name)) + :keyword-name keyword-name)) (when supplied-p-parameter (movitz-env-add-binding env (make-instance 'supplied-p-function-argument :name (shadow-when-special supplied-p-parameter env)))) @@ -4830,12 +4809,6 @@ (optional-vars (optional-vars env)) (rest-var (rest-var env)) (key-vars (key-vars env))) - (when (and (not rest-var) - key-vars - (not (= 1 (length key-vars)))) - (setf rest-var - (keyword-function-argument-rest-var-name - (movitz-binding (decode-keyword-formal (first key-vars)) env)))) (values (append (loop for optional in optional-vars @@ -6753,9 +6726,8 @@ (cond ((typep binding 'rest-function-argument) (assert (eq :edx init-with-register)) - (assert (or (typep binding 'hidden-rest-function-argument) - (movitz-env-get (binding-name binding) - 'dynamic-extent nil (binding-env binding))) + (assert (movitz-env-get (binding-name binding) + 'dynamic-extent nil (binding-env binding)) () "&REST variable ~S must be dynamic-extent." (binding-name binding)) (setf (need-normalized-ecx-p (find-function-env (binding-env binding)

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 22 Feb '07

22 Feb '07

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv8518 Modified Files: lists.lisp Log Message: Removed dead comment. --- /project/movitz/cvsroot/movitz/losp/muerte/lists.lisp 2007/02/22 20:27:31 1.20 +++ /project/movitz/cvsroot/movitz/losp/muerte/lists.lisp 2007/02/22 20:28:37 1.21 @@ -9,7 +9,7 @@ ;;;; Created at: Tue Dec 5 18:40:11 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: lists.lisp,v 1.20 2007/02/22 20:27:31 ffjeld Exp $ +;;;; $Id: lists.lisp,v 1.21 2007/02/22 20:28:37 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -243,9 +243,6 @@ (when (eq indicator (car p)) (return (cadr p))))) -;;;(defun (setf getf) (value plist indicator &optional default) -;;; (error "Must be implemented as a macro..")) - (defsetf getf (plist indicator &optional default) (new-value) `(do ((p ,plist (cddr p))) ((null p)

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 22 Feb '07

22 Feb '07

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv8464 Modified Files: lists.lisp Log Message: Tweaked make-list. --- /project/movitz/cvsroot/movitz/losp/muerte/lists.lisp 2007/02/20 23:11:44 1.19 +++ /project/movitz/cvsroot/movitz/losp/muerte/lists.lisp 2007/02/22 20:27:31 1.20 @@ -9,7 +9,7 @@ ;;;; Created at: Tue Dec 5 18:40:11 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: lists.lisp,v 1.19 2007/02/20 23:11:44 ffjeld Exp $ +;;;; $Id: lists.lisp,v 1.20 2007/02/22 20:27:31 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -232,10 +232,10 @@ (setf (cdr new-tail) (cons (pop more-objects) nil))))))) (defun make-list (size &key initial-element) - (check-type size positive-fixnum) (do ((list nil (cons initial-element list)) - (c size (1- c))) - ((<= c 0) list))) + (c (check-the positive-fixnum size) (1- c))) + ((<= c 0) list) + (declare (positive-fixnum c)))) (defun getf (plist indicator &optional default) (do ((p plist (cddr p)))

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 20 Feb '07

20 Feb '07

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv8445 Modified Files: lists.lisp Log Message: Have make-list check that the list-size is an integer. --- /project/movitz/cvsroot/movitz/losp/muerte/lists.lisp 2006/05/06 20:30:54 1.18 +++ /project/movitz/cvsroot/movitz/losp/muerte/lists.lisp 2007/02/20 23:11:44 1.19 @@ -9,7 +9,7 @@ ;;;; Created at: Tue Dec 5 18:40:11 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: lists.lisp,v 1.18 2006/05/06 20:30:54 ffjeld Exp $ +;;;; $Id: lists.lisp,v 1.19 2007/02/20 23:11:44 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -232,6 +232,7 @@ (setf (cdr new-tail) (cons (pop more-objects) nil))))))) (defun make-list (size &key initial-element) + (check-type size positive-fixnum) (do ((list nil (cons initial-element list)) (c size (1- c))) ((<= c 0) list)))

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 20 Feb '07

20 Feb '07

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv8373 Modified Files: basic-macros.lisp Log Message: Have CAR and CDR have side-effects (i.e. they signal errors if the argumetn isn't a cons). --- /project/movitz/cvsroot/movitz/losp/muerte/basic-macros.lisp 2006/05/06 21:15:44 1.67 +++ /project/movitz/cvsroot/movitz/losp/muerte/basic-macros.lisp 2007/02/20 23:11:22 1.68 @@ -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.67 2006/05/06 21:15:44 ffjeld Exp $ +;;;; $Id: basic-macros.lisp,v 1.68 2007/02/20 23:11:22 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -583,13 +583,13 @@ (define-compiler-macro car (x) `(let ((cell ,x)) - (with-inline-assembly-case (:side-effects nil) + (with-inline-assembly-case (:side-effects t) (do-case (t :register) (:cons-get :car (:lexical-binding cell) (:result-register)))))) (define-compiler-macro cdr (x) `(let ((cell ,x)) - (with-inline-assembly-case (:side-effects nil) + (with-inline-assembly-case (:side-effects t) (do-case (t :register) (:cons-get :cdr (:lexical-binding cell) (:result-register))))))

1 0

[movitz-cvs] CVS movitz
by ffjeld 20 Feb '07

20 Feb '07

Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv27362 Modified Files: compiler.lisp Log Message: Fix compilation of unused &key vars. --- /project/movitz/cvsroot/movitz/compiler.lisp 2007/02/19 21:57:33 1.176 +++ /project/movitz/cvsroot/movitz/compiler.lisp 2007/02/20 21:57:13 1.177 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.176 2007/02/19 21:57:33 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.177 2007/02/20 21:57:13 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1473,7 +1473,7 @@ ;;;; (defun print-code (x code) - (let ((*print-level* 3)) + (let ((*print-level* 4)) (format t "~&~A code:~{~& ~A~}" x code)) code) @@ -2691,9 +2691,12 @@ (find-if (lambda (b-loc) (destructuring-bind (binding . binding-location) b-loc - (or (and (not (bindingp binding)) + (or (and (eq binding nil) ; nil means "back off!" (eql sub-location binding-location)) - (and (eql sub-location (stack-location binding)) + (and (not (bindingp binding)) + (eql sub-location binding-location)) + (and (bindingp binding) + (eql sub-location (stack-location binding)) (labels ((z (b) (when b @@ -2715,7 +2718,8 @@ (append values (list binding)) (list new-value) `(let ((,(car stores) (progn - (assert (not (new-binding-located-p ,binding-var ,getter))) + (assert (or (null binding) + (not (new-binding-located-p ,binding-var ,getter)))) (check-type ,new-value (or keyword binding (integer 0 *) @@ -3145,7 +3149,8 @@ (init-with-register (take-note-of-binding binding t pc) (when (and (typep init-with-register 'binding) - (not (typep binding 'forwarding-binding))) ; XXX + (not (typep binding 'forwarding-binding)) + (not (typep binding 'keyword-function-argument))) ; XXX (take-note-of-binding init-with-register)))))) (t (mapcar #'take-note-of-binding (find-read-bindings instruction)) @@ -3369,19 +3374,22 @@ binding)) 2))) (loop for key-var in (key-vars function-env) - as key-binding = - (or (movitz-binding key-var function-env nil) - (error "No binding for key-var ~S." key-var)) - as supplied-p-binding = + as key-binding = (or (movitz-binding key-var function-env nil) + (error "No binding for key-var ~S." key-var)) + as used-key-binding = + (when (plusp (car (gethash key-binding var-counts '(0)))) + key-binding) + as used-supplied-p-binding = (when (optional-function-argument-supplied-p-var key-binding) - (or (movitz-binding (optional-function-argument-supplied-p-var key-binding) - function-env nil) - (error "No binding for supplied-p-var ~S." - (optional-function-argument-supplied-p-var key-binding)))) + (let ((b (or (movitz-binding (optional-function-argument-supplied-p-var key-binding) + function-env nil) + (error "No binding for supplied-p-var ~S." + (optional-function-argument-supplied-p-var key-binding))))) + (when (plusp (car (gethash key-binding var-counts '(0)))) + b))) as location upfrom 3 by 2 - do (set-exclusive-location key-binding location) - (assert supplied-p-binding) - (set-exclusive-location supplied-p-binding (1+ location)))) + do (set-exclusive-location used-key-binding location) + (set-exclusive-location used-supplied-p-binding (1+ location)))) ;; Now, use assing-env-bindings on the remaining bindings. (loop for env in (loop with z = nil @@ -3595,7 +3603,7 @@ 'integer)) (warn "ecx from ~S" binding))) (when (movitz-env-get (binding-name binding) 'ignore nil (binding-env binding)) - (warn "The variable ~S is used even if it was declared ignored." + (break "The variable ~S is used even if it was declared ignored." (binding-name binding))) (let ((binding (ensure-local-binding binding funobj)) (protect-registers (cons :edx protect-registers))) @@ -4443,15 +4451,16 @@ (shadow-when-special formal env)) (supplied-p-parameter (or supplied-p - (gensym "supplied-p-")))) + #+ignore (gensym "supplied-p-")))) (movitz-env-add-binding env (make-instance 'keyword-function-argument :name formal 'init-form init-form 'supplied-p-var supplied-p-parameter :keyword-name keyword-name :rest-var-name rest-var-name)) - (movitz-env-add-binding env (make-instance 'supplied-p-function-argument - :name (shadow-when-special supplied-p-parameter env))) + (when supplied-p-parameter + (movitz-env-add-binding env (make-instance 'supplied-p-function-argument + :name (shadow-when-special supplied-p-parameter env)))) formal)))) #+ignore (multiple-value-bind (key-decode-map key-decode-shift) @@ -4980,30 +4989,31 @@ as binding = (movitz-binding key-var-name env) as supplied-p-binding = - (movitz-binding (optional-function-argument-supplied-p-var binding) - env) + (when (optional-function-argument-supplied-p-var binding) + (movitz-binding (optional-function-argument-supplied-p-var binding) + env)) as keyword-ok-label = (make-symbol (format nil "keyword-~A-ok" key-var-name)) do (assert binding) ;; (not (movitz-constantp (optional-function-argument-init-form binding))) append - `((:init-lexvar ,binding - :init-with-register ,binding - :init-with-type t - :shared-reference-p t) - (:init-lexvar ,supplied-p-binding - :init-with-register ,supplied-p-binding - :init-with-type t - :shared-reference-p t)) - append - (when (optional-function-argument-init-form binding) - `((:cmpl :edi (:ebp ,(stack-frame-offset (1+ key-location)))) - (:jne ',keyword-ok-label) - ,@(compiler-call #'compile-form - :form (optional-function-argument-init-form binding) - :env env - :funobj funobj - :result-mode binding) - ,keyword-ok-label)) + (append `((:init-lexvar ,binding + :init-with-register ,binding + :init-with-type t + :shared-reference-p t)) + (when supplied-p-binding + `((:init-lexvar ,supplied-p-binding + :init-with-register ,supplied-p-binding + :init-with-type t + :shared-reference-p t))) + (when (optional-function-argument-init-form binding) + `((:cmpl :edi (:ebp ,(stack-frame-offset (1+ key-location)))) + (:jne ',keyword-ok-label) + ,@(compiler-call #'compile-form + :form (optional-function-argument-init-form binding) + :env env + :funobj funobj + :result-mode binding) + ,keyword-ok-label))) ;;; else append ;;; nil #+ignore

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 20 Feb '07

20 Feb '07

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv27165 Modified Files: sequences.lisp Log Message: Remove unused args. --- /project/movitz/cvsroot/movitz/losp/muerte/sequences.lisp 2006/04/10 11:56:28 1.33 +++ /project/movitz/cvsroot/movitz/losp/muerte/sequences.lisp 2007/02/20 21:55:29 1.34 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Sep 11 14:19:23 2001 ;;;; -;;;; $Id: sequences.lisp,v 1.33 2006/04/10 11:56:28 ffjeld Exp $ +;;;; $Id: sequences.lisp,v 1.34 2007/02/20 21:55:29 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1755,10 +1755,9 @@ (t (error "Can't concatenate ~S yet: ~:S" result-type sequences)))) -(defun substitute (newitem olditem sequence &rest args +(defun substitute (newitem olditem sequence &key (test 'eql) test-not (start 0) end count (key 'identity) from-end) "=> result-sequence" - (declare (dynamic-extent args)) (when test-not (setf test (complement test-not))) (with-funcallable (test (if test-not (complement test-not) test)) @@ -1767,10 +1766,9 @@ :count count :key key :from-end from-end))) -(defun nsubstitute (newitem olditem sequence &rest args +(defun nsubstitute (newitem olditem sequence &key (test 'eql) test-not (start 0) end count (key 'identity) from-end) "=> result-sequence" - (declare (dynamic-extent args)) (when test-not (setf test (complement test-not))) (with-funcallable (test (if test-not (complement test-not) test))

1 0

[movitz-cvs] CVS movitz
by ffjeld 20 Feb '07

20 Feb '07

Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv32109 Modified Files: special-operators-cl.lisp Log Message: Fixed nasty in special-operator-let that would erroneously remove init-forms with side-effects. --- /project/movitz/cvsroot/movitz/special-operators-cl.lisp 2005/09/16 22:50:08 1.49 +++ /project/movitz/cvsroot/movitz/special-operators-cl.lisp 2007/02/20 20:33:30 1.50 @@ -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.49 2005/09/16 22:50:08 ffjeld Exp $ +;;;; $Id: special-operators-cl.lisp,v 1.50 2007/02/20 20:33:30 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -155,7 +155,8 @@ :env local-env)))) (compiler-values-bind (&all body-values &code body-code &returns body-returns) (compile-body) -;;; (print-code 'body body-code) + ;; (print-code 'body body) + ;; (print-code 'body-code body-code) (let ((first-binding (movitz-binding (caar binding-var-codes) local-env nil))) (cond ;; Is this (let ((#:foo <form>)) (setq bar #:foo)) ? @@ -368,6 +369,8 @@ (compiler-values (body-values) :returns body-returns :producer (default-compiler-values-producer) + :functional-p (and (body-values :functional-p) + (every #'fourth binding-var-codes)) :modifies let-modifies :code code))))))))))))

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 19 Feb '07

19 Feb '07

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv8169 Modified Files: primitive-functions.lisp Log Message: In decode-keyargs-default, provide error in eax rathern than scratch2. --- /project/movitz/cvsroot/movitz/losp/muerte/primitive-functions.lisp 2007/02/19 20:24:59 1.68 +++ /project/movitz/cvsroot/movitz/losp/muerte/primitive-functions.lisp 2007/02/19 21:58:27 1.69 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Oct 2 21:02:18 2001 ;;;; -;;;; $Id: primitive-functions.lisp,v 1.68 2007/02/19 20:24:59 ffjeld Exp $ +;;;; $Id: primitive-functions.lisp,v 1.69 2007/02/19 21:58:27 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -765,7 +765,8 @@ continue-save-eax-ebx (:testl 4 :ecx) (:jnz '(:sub-program (odd-keywords) - (:locally (:orl #x10 (:edi (:edi-offset scratch2)))) + ;; (:locally (:orl #x10 (:edi (:edi-offset scratch2)))) + (:movl #x10 :eax) (:int 72))) continue-from-odd-keywords (:locally (:movl :ecx (:edi (:edi-offset raw-scratch0)))) ; save stop-pos @@ -791,7 +792,8 @@ (:leal (:eax -5) :ecx) (:testb 5 :cl) (:jnz '(:sub-program (keyword-not-symbol) - (:locally (:orl #x8 (:edi (:edi-offset scratch2)))) ; Signal keyword-not-symbol + ;; (:locally (:orl #x8 (:edi (:edi-offset scratch2)))) ; Signal keyword-not-symbol + (:movl #x8 :eax) (:int 72))) start-keyword-search-symbol (:movl (:esi (:offset movitz-funobj num-jumpers))

1 0

[movitz-cvs] CVS movitz
by ffjeld 19 Feb '07

19 Feb '07

Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv8123 Modified Files: image.lisp Log Message: Minor tweak. --- /project/movitz/cvsroot/movitz/image.lisp 2007/02/18 14:53:07 1.108 +++ /project/movitz/cvsroot/movitz/image.lisp 2007/02/19 21:57:49 1.109 @@ -9,7 +9,7 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: image.lisp,v 1.108 2007/02/18 14:53:07 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.109 2007/02/19 21:57:49 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -779,7 +779,7 @@ :start-address start-address :movitz-features '(:movitz) :function-code-sizes - (if (boundp '*image*) + (if (and (boundp '*image*) *image*) (copy-hash-table (function-code-sizes *image*)) (make-hash-table :test #'equal)) init-args)))

1 0

[movitz-cvs] CVS movitz
by ffjeld 19 Feb '07

19 Feb '07

Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv8062 Modified Files: compiler.lisp Log Message: Remove old check for odd keyargs, since the new &key-parser does it for us. --- /project/movitz/cvsroot/movitz/compiler.lisp 2007/02/19 20:24:38 1.175 +++ /project/movitz/cvsroot/movitz/compiler.lisp 2007/02/19 21:57:33 1.176 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.175 2007/02/19 20:24:38 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.176 2007/02/19 21:57:33 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -4704,37 +4704,22 @@ eax-ebx-code (make-stack-setup-code stack-setup-size) (when need-normalized-ecx-p - (let ((oddeven-ok (gensym "oddeven-ok-"))) - (append (cond - ;; normalize arg-count in ecx.. - ((and max-args (= min-args max-args)) - (error "huh?")) - ((and max-args (<= 0 min-args max-args #x7f)) - `((:andl #x7f :ecx))) - ((>= min-args #x80) - `((:shrl 8 :ecx))) - (t (let ((normalize (make-symbol "normalize-ecx")) - (normalize-done (make-symbol "normalize-ecx-done"))) - `((:testb :cl :cl) - (:js '(:sub-program (,normalize) - (:shrl 8 :ecx) - (:jmp ',normalize-done))) - (:andl #x7f :ecx) - ,normalize-done)))) - (when (and (oddeven-args env) - (optional-vars env)) - `((:cmpl ,(length (optional-vars env)) :ecx) - (:jbe ',oddeven-ok))) - (case (oddeven-args env) - (:even - `((:testb 1 :cl) - (:jnz '(:sub-program () (:int 102))))) - (:odd - `((:testb 1 :cl) - (:jz '(:sub-program () (:int 102)))))) - (when (and (oddeven-args env) - (optional-vars env)) - (list oddeven-ok))))) + (append (cond + ;; normalize arg-count in ecx.. + ((and max-args (= min-args max-args)) + (error "huh?")) + ((and max-args (<= 0 min-args max-args #x7f)) + `((:andl #x7f :ecx))) + ((>= min-args #x80) + `((:shrl 8 :ecx))) + (t (let ((normalize (make-symbol "normalize-ecx")) + (normalize-done (make-symbol "normalize-ecx-done"))) + `((:testb :cl :cl) + (:js '(:sub-program (,normalize) + (:shrl 8 :ecx) + (:jmp ',normalize-done))) + (:andl #x7f :ecx) + ,normalize-done)))))) (when edx-needs-saving-p `((:movl :edx (:ebp ,(stack-frame-offset (new-binding-location (edx-var env) frame-map)))))) eax-ebx-code-post-stackframe

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 19 Feb '07

19 Feb '07

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv30688 Modified Files: primitive-functions.lisp Log Message: First implementation of new &key-parsing strategy. --- /project/movitz/cvsroot/movitz/losp/muerte/primitive-functions.lisp 2007/02/18 16:31:42 1.67 +++ /project/movitz/cvsroot/movitz/losp/muerte/primitive-functions.lisp 2007/02/19 20:24:59 1.68 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Oct 2 21:02:18 2001 ;;;; -;;;; $Id: primitive-functions.lisp,v 1.67 2007/02/18 16:31:42 ffjeld Exp $ +;;;; $Id: primitive-functions.lisp,v 1.68 2007/02/19 20:24:59 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -740,13 +740,15 @@ "Decode keyword arguments. Results are placed in stack-frame, starting at (:ebp -16)." (with-inline-assembly (:returns :multiple-values) - ;; ECX: numargs (fixnum) + ;; ECX: numargs (u32) ;; EDX: arg-position of first keyword (fixnum) ;; (:ebp -8) arg0 (if needed) ;; (:ebp -12) arg1 (if needed) + (:shll 2 :ecx) (:subl :edx :ecx) ; find stop-pos (:jbe '(:sub-program (no-key-args) + (:xorl :eax :eax) ; No errors (:ret))) (:locally (:movl :edx (:edi (:edi-offset scratch1)))) ; first-key-position @@ -764,7 +766,7 @@ (:testl 4 :ecx) (:jnz '(:sub-program (odd-keywords) (:locally (:orl #x10 (:edi (:edi-offset scratch2)))) - (:ret))) + (:int 72))) continue-from-odd-keywords (:locally (:movl :ecx (:edi (:edi-offset raw-scratch0)))) ; save stop-pos (:xorl :edx :edx) ; EDX scans the args, last-to-first. @@ -785,12 +787,13 @@ (:cmpl :edi :ebx) (:je 'finished-keyword-search) (:locally (:orl #x20 (:edi (:edi-offset scratch2)))) ; Signal :allow-other-keys t - (:jmp 'finished-keyword-search))) + (:jmp 'start-keyword-search-symbol))) (:leal (:eax -5) :ecx) (:testb 5 :cl) (:jnz '(:sub-program (keyword-not-symbol) (:locally (:orl #x8 (:edi (:edi-offset scratch2)))) ; Signal keyword-not-symbol - (:jmp 'finished-keyword-search))) + (:int 72))) + start-keyword-search-symbol (:movl (:esi (:offset movitz-funobj num-jumpers)) :ecx) (:andl #xfffc :ecx) @@ -830,6 +833,13 @@ (:movl (:ebp -12) :eax) (:movl (:ebp :edx 8) :ebx) (:jmp 'start-keyword-search))) + ;; if there was :allow-other-keys t, clear the unknown-keyword error flag. + (:locally (:movl (:edi (:edi-offset scratch2)) :eax)) + (:movl :eax :ecx) + (:andl #x20 :ecx) + (:shrl 3 :ecx) + (:xorl 4 :ecx) + (:andl :ecx :eax) (:ret))) (define-primitive-function decode-keyargs-foo ()

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 19 Feb '07

19 Feb '07

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv30647 Modified Files: interrupt.lisp Log Message: First implementation of new &key-parsing strategy. --- /project/movitz/cvsroot/movitz/losp/muerte/interrupt.lisp 2006/05/06 21:15:46 1.52 +++ /project/movitz/cvsroot/movitz/losp/muerte/interrupt.lisp 2007/02/19 20:24:54 1.53 @@ -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.52 2006/05/06 21:15:46 ffjeld Exp $ +;;;; $Id: interrupt.lisp,v 1.53 2007/02/19 20:24:54 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -382,6 +382,14 @@ (error "Not a function: ~S" (dereference $edx))) (70 (error "[EIP=~@Z] Index ~@Z out of bounds ~@Z for ~S." $eip $ecx $ebx (dereference $eax))) + (72 + (ecase (dereference $eax) + (1 (error 'program-error + :format-control "Illegal keyword argument.")) + (2 (error 'program-error + :format-control "Keyword not a symbol.")) + (4 (error 'program-error + :format-control "Odd number of keyword arguments.")))) (98 (let ((name (dereference $edx))) (when (symbolp name)

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 19 Feb '07

19 Feb '07

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv30606 Modified Files: basic-functions.lisp Log Message: First implementation of new &key-parsing strategy. --- /project/movitz/cvsroot/movitz/losp/muerte/basic-functions.lisp 2006/03/21 20:20:20 1.21 +++ /project/movitz/cvsroot/movitz/losp/muerte/basic-functions.lisp 2007/02/19 20:24:51 1.22 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Sep 4 18:41:57 2001 ;;;; -;;;; $Id: basic-functions.lisp,v 1.21 2006/03/21 20:20:20 ffjeld Exp $ +;;;; $Id: basic-functions.lisp,v 1.22 2007/02/19 20:24:51 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -432,4 +432,36 @@ (setf (memref object offset :index i :type :character) (char value j)))))))) value) - + + + +(define-primitive-function blah () + "foo" + (with-inline-assembly (:returns :multiple-values) + ;; EAX: (presumed) keyword + (:globally (:cmpl :eax (:edi (:edi-offset allow-other-keys-symbol)))) + (:je '(:sub-program (found-allow-other-keys) + ; XXX + (:ret))) + (:leal (:ebx -7) :ecx) + (:testb 7 :cl) + (:jnz '(:sub-program () + (:xorl :ecx :ecx) ; hash of nil is 0 + (:cmpl :edi :ebx) + (:je 'proceed-with-nil-key) + (:movl :ebx :eax) + (:movb 0 :cl) + (:int 72))) + (:xorl :ecx :ecx) + (:movw (:eax (:offset movitz-symbol hash-key)) :cx) + proceed-with-nil-key + ;; We now have symbol's basic sxhash in CX. + (:xorl :edx :edx) + (:leal ((:ecx 4) :edx) :edx) + (:andl (:esi (:offset movitz-funobj constant0)) + :edx) + + (:ret) + + )) +

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

movitz-cvs February 2007