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

[movitz-cvs] CVS update: movitz/special-operators.lisp
by Frode Vatvedt Fjeld 31 Mar '04

31 Mar '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv2537 Modified Files: special-operators.lisp Log Message: Minor edits. Date: Wed Mar 31 11:33:25 2004 Author: ffjeld Index: movitz/special-operators.lisp diff -u movitz/special-operators.lisp:1.16 movitz/special-operators.lisp:1.17 --- movitz/special-operators.lisp:1.16 Sun Mar 28 11:20:05 2004 +++ movitz/special-operators.lisp Wed Mar 31 11:33:25 2004 @@ -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.16 2004/03/28 16:20:05 ffjeld Exp $ +;;;; $Id: special-operators.lisp,v 1.17 2004/03/31 16:33:25 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -377,7 +377,7 @@ :muerte.cl :cl)) (cl-macro-body (translate-program macro-body :muerte.cl :cl))) (when (member name (image-called-functions *image*) :key #'first) - #+ignore (warn "Macro ~S defined after being called as function (in ~S)." + #+ignore (warn "Macro ~S defined after being called as function (first in ~S)." name (cdr (find name (image-called-functions *image*) :key #'first)))) (multiple-value-bind (cl-body declarations doc-string) @@ -427,7 +427,7 @@ (env-formal (or envvar (gensym))) (expansion-var (gensym))) (when (member operator-name (image-called-functions *image*) :key #'first) - (warn "Compiler-macro ~S defined after being called as function (in ~S)" + (warn "Compiler-macro ~S defined after being called as function (first in ~S)" operator-name (cdr (find operator-name (image-called-functions *image*) :key #'first)))) (let ((expander @@ -572,7 +572,7 @@ (destructuring-bind (var) (cdr expr) (let ((binding (movitz-binding var env))) - (check-type binding lexical-binding) + (check-type binding binding) (list binding))))) (let ((code (assembly-macroexpand inline-asm amenv))) #+ignore @@ -686,7 +686,7 @@ `((:cmpl :edi ,(single-value-register not-returns)))) :returns :boolean-zf=1)) ; TRUE iff result equal to :edi/NIL. (otherwise - (warn "unable to deal inteligently with inlined-NOT not-returns: ~S for ~S from ~S" + (warn "unable to deal intelligently with inlined-NOT not-returns: ~S for ~S from ~S" not-returns not-result-mode (not-values :producer)) (let ((label (make-symbol "not-label"))) (compiler-values (not-values) @@ -711,9 +711,9 @@ as sub-form-result-mode = buried-result-modes then (or (cdr sub-form-result-mode) sub-form-result-mode) - as current-result-mode = (if (endp (cdr sub-form)) - ;; all but the last form have - ;; result-mode as declared + as current-result-mode = (if (endp (cdr sub-form)) all but the + ;; last form have result-mode as + ;; declared result-mode (car sub-form-result-mode)) as last-form-p = (endp (cdr sub-form))

1 0

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

31 Mar '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv29110 Modified Files: packages.lisp Log Message: Added symbol. Date: Wed Mar 31 11:32:22 2004 Author: ffjeld Index: movitz/packages.lisp diff -u movitz/packages.lisp:1.11 movitz/packages.lisp:1.12 --- movitz/packages.lisp:1.11 Mon Mar 29 09:36:43 2004 +++ movitz/packages.lisp Wed Mar 31 11:32:22 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Sat Nov 15 21:39:55 2003 ;;;; -;;;; $Id: packages.lisp,v 1.11 2004/03/29 14:36:43 ffjeld Exp $ +;;;; $Id: packages.lisp,v 1.12 2004/03/31 16:32:22 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1322,6 +1322,7 @@ #:*compiler-global-segment-prefix* #:*compiler-compile-eval-whens* #:*compiler-compile-macro-expanders* + #:*compiler-allow-untagged-word-bits* ) (:import-from muerte #:translate-program

1 0

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

31 Mar '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv28070 Modified Files: eval.lisp Log Message: Have movitz-constantp and movitz-eval understand +, -, and *. Date: Wed Mar 31 11:31:44 2004 Author: ffjeld Index: movitz/eval.lisp diff -u movitz/eval.lisp:1.3 movitz/eval.lisp:1.4 --- movitz/eval.lisp:1.3 Thu Mar 25 20:43:46 2004 +++ movitz/eval.lisp Wed Mar 31 11:31:44 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Thu Nov 2 17:45:05 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: eval.lisp,v 1.3 2004/03/26 01:43:46 ffjeld Exp $ +;;;; $Id: eval.lisp,v 1.4 2004/03/31 16:31:44 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -66,8 +66,13 @@ (symbol (or (movitz-env-get form 'constantp nil environment) (typep (movitz-binding form environment) 'constant-object-binding))) (cons (case (car form) - ((muerte.cl::quote) t) - (muerte.cl::not (movitz-constantp (second form)))))))) + ((muerte.cl:quote) t) + ((muerte.cl:not) + (movitz-constantp (second form))) + ((muerte.cl:+ muerte.cl:- muerte.cl:*) + (every (lambda (sub-form) + (movitz-constantp sub-form environment)) + (cdr form)))))))) (defun isconst (x) @@ -139,4 +144,9 @@ (eval-self-evaluating (second form) env top-level-p)) (muerte.cl::not (not (eval-form (second form) env nil))) + ((muerte.cl:+ muerte.cl:- muerte.cl:*) + (apply (translate-program (car form) :muerte.cl :cl) + (mapcar (lambda (sub-form) + (movitz-eval sub-form env nil)) + (cdr form)))) (t (error "Don't know how to compile constant compound form ~A" form))))

1 0

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

31 Mar '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv15542 Modified Files: compiler.lisp Log Message: Added variable *compiler-allow-untagged-word-bits* (see docstring). Date: Wed Mar 31 10:55:31 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.38 movitz/compiler.lisp:1.39 --- movitz/compiler.lisp:1.38 Tue Mar 30 14:23:40 2004 +++ movitz/compiler.lisp Wed Mar 31 10:55:31 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.38 2004/03/30 19:23:40 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.39 2004/03/31 15:55:31 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -43,6 +43,12 @@ (defvar *compiler-global-segment-prefix* nil "Use these assembly-instruction prefixes when accessing the global run-time context.") + +(defvar *compiler-allow-untagged-word-bits* 0 + "Allow (temporary) untagged values of this bit-size to exist, because +the system ensures one way or another that there can be no pointers below +this size.") + (defvar *compiler-compile-eval-whens* t "When encountering (eval-when (:compile-toplevel) <code>),

1 0

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

31 Mar '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv17089 Modified Files: sequences.lisp Log Message: Added two-arguments implementations for find and count-if. Date: Wed Mar 31 07:17:19 2004 Author: ffjeld Index: movitz/losp/muerte/sequences.lisp diff -u movitz/losp/muerte/sequences.lisp:1.5 movitz/losp/muerte/sequences.lisp:1.6 --- movitz/losp/muerte/sequences.lisp:1.5 Sun Feb 29 14:14:59 2004 +++ movitz/losp/muerte/sequences.lisp Wed Mar 31 07:17:14 2004 @@ -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.5 2004/02/29 19:14:59 ffjeld Exp $ +;;;; $Id: sequences.lisp,v 1.6 2004/03/31 12:17:14 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -775,35 +775,50 @@ sequence-1))) (defun find (item sequence &key from-end (test 'eql) (start 0) end (key 'identity)) - (with-funcallable (test) - (with-funcallable (key) + (numargs-case + (2 (item sequence) (sequence-dispatch sequence (vector - (setf end (or end (length sequence))) - (with-subvector-accessor (sequence-ref sequence start end) - (if (not from-end) - (do ((i start (1+ i))) - ((>= i end) nil) - (when (test item (key (aref sequence i))) - (return (sequence-ref i)))) - (do ((i (1- end) (1- i))) - ((< i start) nil) - (when (test item (key (sequence-ref i))) - (return (sequence-ref i))))))) + (with-subvector-accessor (sequence-ref sequence) + (dotimes (i (length sequence)) + (when (eql item (sequence-ref i)) + (return item))))) (list - (if end - (do ((p (nthcdr start sequence) (cdr p)) - (i start (1+ i))) - ((or (>= i end) (endp p)) nil) - (when (test item (key (car p))) - (return (or (and from-end - (find item (cdr p) :from-end t :test test :key key :end (- end i 1))) - (car p))))) - (do ((p (nthcdr start sequence) (cdr p))) - ((endp p) nil) - (when (test item (key (car p))) - (return (or (and from-end (find item (cdr p) :from-end t :test test :key key)) - (car p))))))))))) + (dolist (x sequence) + (when (eql item x) + (return x)))))) + (t (item sequence &key from-end (test 'eql) (start 0) end (key 'identity)) + (with-funcallable (test) + (with-funcallable (key) + (sequence-dispatch sequence + (vector + (setf end (or end (length sequence))) + (with-subvector-accessor (sequence-ref sequence start end) + (if (not from-end) + (do ((i start (1+ i))) + ((>= i end) nil) + (when (test item (key (aref sequence i))) + (return (sequence-ref i)))) + (do ((i (1- end) (1- i))) + ((< i start) nil) + (when (test item (key (sequence-ref i))) + (return (sequence-ref i))))))) + (list + (if end + (do ((p (nthcdr start sequence) (cdr p)) + (i start (1+ i))) + ((or (>= i end) (endp p)) nil) + (when (test item (key (car p))) + (return (or (and from-end + (find item (cdr p) + :from-end t :test test + :key key :end (- end i 1))) + (car p))))) + (do ((p (nthcdr start sequence) (cdr p))) + ((endp p) nil) + (when (test item (key (car p))) + (return (or (and from-end (find item (cdr p) :from-end t :test test :key key)) + (car p))))))))))))) (defun find-if (predicate sequence &key from-end (start 0) end (key 'identity)) @@ -897,24 +912,42 @@ (incf n)))))))))) (defun count-if (predicate sequence &key (start 0) end (key 'identity) #+ignore from-end) - (with-funcallable (predicate) - (with-funcallable (key) - (sequence-dispatch sequence - (list - (if (not end) - (do ((n 0) - (p (nthcdr start sequence) (cdr p))) - ((endp p) n) - (when (predicate (key (car p))) - (incf n))) - (do ((n 0) - (i start (1+ i)) - (p (nthcdr start sequence) (cdr p))) - ((or (endp p) (>= i end)) n) - (when (predicate (key (car p))) - (incf n))))) - (vector - (error "vector count-if not implemented.")))))) + (numargs-case + (2 (predicate sequence) + (with-funcallable (predicate) + (sequence-dispatch sequence + (list + (let ((count 0)) + (dolist (x sequence) + (when (predicate x) + (incf count))) + count)) + (vector + (with-subvector-accessor (sequence-ref sequence) + (let ((count 0)) + (dotimes (i (length sequence)) + (when (predicate (sequence-ref i)) + (incf count))) + count)))))) + (t (predicate sequence &key (start 0) end (key 'identity) #+ignore from-end) + (with-funcallable (predicate) + (with-funcallable (key) + (sequence-dispatch sequence + (list + (if (not end) + (do ((n 0) + (p (nthcdr start sequence) (cdr p))) + ((endp p) n) + (when (predicate (key (car p))) + (incf n))) + (do ((n 0) + (i start (1+ i)) + (p (nthcdr start sequence) (cdr p))) + ((or (endp p) (>= i end)) n) + (when (predicate (key (car p))) + (incf n))))) + (vector + (error "vector count-if not implemented.")))))))) (macrolet ((every-some-body ()

1 0

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

30 Mar '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv11520 Modified Files: special-operators-cl.lisp Log Message: For non-lexical go, add a bounds check for the calcuclated stack-pointer before assuming it. Date: Tue Mar 30 16:33:54 2004 Author: ffjeld Index: movitz/special-operators-cl.lisp diff -u movitz/special-operators-cl.lisp:1.13 movitz/special-operators-cl.lisp:1.14 --- movitz/special-operators-cl.lisp:1.13 Tue Mar 30 14:36:15 2004 +++ movitz/special-operators-cl.lisp Tue Mar 30 16:33:54 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Nov 24 16:31:11 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: special-operators-cl.lisp,v 1.13 2004/03/30 19:36:15 ffjeld Exp $ +;;;; $Id: special-operators-cl.lisp,v 1.14 2004/03/30 21:33:54 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -704,6 +704,7 @@ `((:xorl :ebx :ebx) (:globally (:call (:edi (:edi-offset dynamic-locate-catch-tag)))) (:jnc '(:sub-program () (:int 108))) + (:locally (:bound (:edi (:edi-offset stack-bottom)) :eax)) (:movl :eax :esp) (:movl (:esp) :ebp) (:movl (:ebp -4) :esi)

1 0

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

30 Mar '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv6785 Modified Files: print.lisp Log Message: Add a declaration of the *print-circle* variable. Not that write implements it. Date: Tue Mar 30 16:32:12 2004 Author: ffjeld Index: movitz/losp/muerte/print.lisp diff -u movitz/losp/muerte/print.lisp:1.3 movitz/losp/muerte/print.lisp:1.4 --- movitz/losp/muerte/print.lisp:1.3 Mon Mar 22 09:38:13 2004 +++ movitz/losp/muerte/print.lisp Tue Mar 30 16:32:12 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Mon Sep 3 11:48:19 2001 ;;;; -;;;; $Id: print.lisp,v 1.3 2004/03/22 14:38:13 ffjeld Exp $ +;;;; $Id: print.lisp,v 1.4 2004/03/30 21:32:12 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -31,6 +31,7 @@ (defvar *print-length* 8) (defvar *print-level* 3) (defvar *print-pretty* t) +(defvar *print-circle* nil) (defvar *standard-output* #'muerte.x86-pc::textmode-console) (defvar *standard-input* #'muerte.x86-pc::textmode-console)

1 0

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

30 Mar '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv6657 Modified Files: special-operators-cl.lisp Log Message: Fix the block operator's compiler not to return mode :ignore, rather :nothing. Date: Tue Mar 30 14:36:15 2004 Author: ffjeld Index: movitz/special-operators-cl.lisp diff -u movitz/special-operators-cl.lisp:1.12 movitz/special-operators-cl.lisp:1.13 --- movitz/special-operators-cl.lisp:1.12 Wed Mar 24 13:36:41 2004 +++ movitz/special-operators-cl.lisp Tue Mar 30 14:36:15 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Nov 24 16:31:11 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: special-operators-cl.lisp,v 1.12 2004/03/24 18:36:41 ffjeld Exp $ +;;;; $Id: special-operators-cl.lisp,v 1.13 2004/03/30 19:36:15 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -724,6 +724,7 @@ (t :eax))) (block-returns-mode (case block-result-mode (:function :multiple-values) + (:ignore :nothing) (t block-result-mode))) (block-env (make-instance 'lexical-exit-point-env :uplink env

1 0

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

30 Mar '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv27744 Modified Files: compiler.lisp Log Message: Have the :untagged-fixnum-ecx mode accept (signed-byte 30) values. Date: Tue Mar 30 14:23:40 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.37 movitz/compiler.lisp:1.38 --- movitz/compiler.lisp:1.37 Sun Mar 28 10:09:27 2004 +++ movitz/compiler.lisp Tue Mar 30 14:23:40 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.37 2004/03/28 15:09:27 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.38 2004/03/30 19:23:40 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -3432,7 +3432,7 @@ (make-immediate-move value :eax))) (:untagged-fixnum-ecx (let ((value (movitz-fixnum-value object))) - (check-type value (unsigned-byte 16)) + (check-type value (signed-byte 30)) (make-immediate-move value :ecx))) (:push `((:pushl ,x)))

1 0

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

30 Mar '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv25089 Modified Files: memref.lisp Log Message: Remove the rather bogus :lisp-code-vector type. Date: Tue Mar 30 04:36:50 2004 Author: ffjeld Index: movitz/losp/muerte/memref.lisp diff -u movitz/losp/muerte/memref.lisp:1.4 movitz/losp/muerte/memref.lisp:1.5 --- movitz/losp/muerte/memref.lisp:1.4 Sun Mar 28 11:19:20 2004 +++ movitz/losp/muerte/memref.lisp Tue Mar 30 04:36:50 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Mar 6 21:25:49 2001 ;;;; -;;;; $Id: memref.lisp,v 1.4 2004/03/28 16:19:20 ffjeld Exp $ +;;;; $Id: memref.lisp,v 1.5 2004/03/30 09:36:50 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -151,32 +151,26 @@ (:popl :ecx) ; pop object (:sarl #.movitz::+movitz-fixnum-shift+ :ebx) ; scale offset+index (:movb (:ebx :ecx ,(offset-by 1)) :ah))))) - ((:lisp :lisp-code-vector) - (let ((fix-when-code-vector - (when (eq type :lisp-code-vector) - `((:subl ,movitz::+code-vector-word-offset+ :eax))))) - (cond - ((and (eq 0 index) (eq 0 offset)) - `(with-inline-assembly (:returns :eax) - (:compile-form (:result-mode :eax) ,object) - (:movl (:eax ,(offset-by 4)) :eax) - ,@fix-when-code-vector)) - ((eq 0 offset) - `(with-inline-assembly (:returns :eax) - (:compile-two-forms (:eax :ecx) ,object ,index) + (:lisp + (cond + ((and (eq 0 index) (eq 0 offset)) + `(with-inline-assembly (:returns :register) + (:compile-form (:result-mode :register) ,object) + (:movl ((:result-register) ,(offset-by 4)) (:result-register)))) + ((eq 0 offset) + `(with-inline-assembly (:returns :eax) + (:compile-two-forms (:eax :ecx) ,object ,index) + ,@(when (cl:plusp (cl:- movitz::+movitz-fixnum-shift+ 2)) + `((:sarl ,(cl:- movitz::+movitz-fixnum-shift+ 2)) :ecx)) + (:movl (:eax :ecx ,(offset-by 4)) :eax))) + (t `(with-inline-assembly (:returns :eax) + (:compile-form (:result-mode :push) ,object) + (:compile-two-forms (:untagged-fixnum-eax :ecx) ,offset ,index) ,@(when (cl:plusp (cl:- movitz::+movitz-fixnum-shift+ 2)) `((:sarl ,(cl:- movitz::+movitz-fixnum-shift+ 2)) :ecx)) - (:movl (:eax :ecx ,(offset-by 4)) :eax) - ,@fix-when-code-vector)) - (t `(with-inline-assembly (:returns :eax) - (:compile-form (:result-mode :push) ,object) - (:compile-two-forms (:untagged-fixnum-eax :ecx) ,offset ,index) - ,@(when (cl:plusp (cl:- movitz::+movitz-fixnum-shift+ 2)) - `((:sarl ,(cl:- movitz::+movitz-fixnum-shift+ 2)) :ecx)) - (:addl :ecx :eax) - (:popl :ebx) ; pop object - (:movl (:eax :ebx ,(offset-by 4)) :eax) - ,@fix-when-code-vector))))) + (:addl :ecx :eax) + (:popl :ebx) ; pop object + (:movl (:eax :ebx ,(offset-by 4)) :eax))))) (t (error "Unknown memref type: ~S" (movitz::eval-form type nil nil)) form))))))))) @@ -187,7 +181,6 @@ (:unsigned-byte32 (memref object offset index :unsigned-byte32)) (:character (memref object offset index :character)) (:lisp (memref object offset index :lisp)) - (:lisp-code-vector (memref object offset index :lisp-code-vector)) (:signed-byte30+2 (memref object offset index :signed-byte30+2)) (:unsigned-byte29+3 (memref object offset index :unsigned-byte29+3))))

1 0