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

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

17 Apr '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv27234 Modified Files: typep.lisp Log Message: Tiny edit. Date: Sat Apr 17 10:08:24 2004 Author: ffjeld Index: movitz/losp/muerte/typep.lisp diff -u movitz/losp/muerte/typep.lisp:1.9 movitz/losp/muerte/typep.lisp:1.10 --- movitz/losp/muerte/typep.lisp:1.9 Fri Apr 16 20:24:00 2004 +++ movitz/losp/muerte/typep.lisp Sat Apr 17 10:08:24 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Dec 8 11:07:53 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: typep.lisp,v 1.9 2004/04/17 00:24:00 ffjeld Exp $ +;;;; $Id: typep.lisp,v 1.10 2004/04/17 14:08:24 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -311,7 +311,7 @@ (,(car type) ,@(loop for subtype in (cdr type) collect `(typep ,object ',subtype))))) - (t (warn "typep ~A" type))))))) + (t (warn "compiling typep ~A" type))))))) form))))) #+ignore

1 0

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

17 Apr '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv3360 Modified Files: typep.lisp Log Message: Minor fix. Date: Fri Apr 16 20:24:00 2004 Author: ffjeld Index: movitz/losp/muerte/typep.lisp diff -u movitz/losp/muerte/typep.lisp:1.8 movitz/losp/muerte/typep.lisp:1.9 --- movitz/losp/muerte/typep.lisp:1.8 Fri Apr 16 20:02:53 2004 +++ movitz/losp/muerte/typep.lisp Fri Apr 16 20:24:00 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Dec 8 11:07:53 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: typep.lisp,v 1.8 2004/04/17 00:02:53 ffjeld Exp $ +;;;; $Id: typep.lisp,v 1.9 2004/04/17 00:24:00 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -266,9 +266,8 @@ :eax))) ((= 1 (logcount (1+ (- upper-limit lower-limit)))) `(with-inline-assembly (:returns :boolean-zf=1) - (:compile-form (:result-mode :eax) ,object) - (:leal (:eax ,(* movitz:+movitz-fixnum-factor+ - (- lower-limit))) + (:compile-form (:result-mode :ecx) ,object) + (:subl ,(* movitz:+movitz-fixnum-factor+ lower-limit) :ecx) (:testl ,(logxor #xffffffff (* movitz:+movitz-fixnum-factor+

1 0

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

17 Apr '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv24866 Modified Files: typep.lisp Log Message: Teach typep about the eql and cons types. Date: Fri Apr 16 20:02:53 2004 Author: ffjeld Index: movitz/losp/muerte/typep.lisp diff -u movitz/losp/muerte/typep.lisp:1.7 movitz/losp/muerte/typep.lisp:1.8 --- movitz/losp/muerte/typep.lisp:1.7 Fri Apr 16 19:34:43 2004 +++ movitz/losp/muerte/typep.lisp Fri Apr 16 20:02:53 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Dec 8 11:07:53 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: typep.lisp,v 1.7 2004/04/16 23:34:43 ffjeld Exp $ +;;;; $Id: typep.lisp,v 1.8 2004/04/17 00:02:53 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -293,6 +293,17 @@ movitz:+movitz-fixnum-factor+) :eax) not-fixnum))))))) + ((eql) + `(eql ,object ',(cadr type))) + ((cons) + (destructuring-bind (&optional (car t) (cdr t)) + (cdr type) + (let ((car (if (eq car '*) t car)) + (cdr (if (eq cdr '*) t cdr))) + `(let ((typep-object ,object)) + (and (typep typep-object 'cons) + (typep (car typep-object) ',car) + (typep (cdr typep-object) ',cdr)))))) ((not) (assert (and (cadr type) (not (cddr type)))) `(not (typep ,object ',(cadr type)))) @@ -301,9 +312,12 @@ (,(car type) ,@(loop for subtype in (cdr type) collect `(typep ,object ',subtype))))) - ((not and or) - (warn "typep compilermacro: ~S" type))))))) + (t (warn "typep ~A" type))))))) form))))) + +#+ignore +(defun foo (x) + (typep x '(cons * symbol))) (defmacro define-typep (tname lambda &body body) (let ((fname (format nil "~A-~A" 'typep tname)))

1 0

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

16 Apr '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv25822 Modified Files: compiler.lisp Log Message: Removed some dead code. Date: Fri Apr 16 19:38:41 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.49 movitz/compiler.lisp:1.50 --- movitz/compiler.lisp:1.49 Fri Apr 16 15:20:46 2004 +++ movitz/compiler.lisp Fri Apr 16 19:38:41 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.49 2004/04/16 19:20:46 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.50 2004/04/16 23:38:41 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -5222,25 +5222,9 @@ ((typep binding 'symbol-macro-binding) (compiler-call #'compile-form-unprotected :forward all - :form (funcall *movitz-macroexpand-hook* (macro-binding-expander (movitz-binding form env)) form env))) + :form (funcall *movitz-macroexpand-hook* + (macro-binding-expander (movitz-binding form env)) form env))) (t (compiler-call #'compile-dynamic-variable :forward all)))))) - -#+old-compiler -(defun ensure-local-binding (binding funobj env) - "Make sure that we have a binding that is local to funobj." - (if (eq funobj (binding-funobj binding)) - binding - (let* ((function-env (find-function-env env funobj)) - (local-binding (make-instance - (ecase (function-env-extent function-env) - (:indefinite-extent 'indefinite-borrowed-binding) - ;; XXXX - (:dynamic-extent 'indefinite-borrowed-binding) - (:lexical-extent 'lexical-borrowed-binding)) - :name (binding-name binding) - :target-binding binding))) - (movitz-environment-add-binding function-env (binding-name binding) local-binding) - local-binding))) (define-compiler compile-lexical-variable (&form variable &result-mode result-mode &env env) (let ((binding (movitz-binding variable env)))

1 0

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

16 Apr '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv9968 Modified Files: symbols.lisp Log Message: Added (setf %symbol-global-value). Date: Fri Apr 16 19:36:40 2004 Author: ffjeld Index: movitz/losp/muerte/symbols.lisp diff -u movitz/losp/muerte/symbols.lisp:1.10 movitz/losp/muerte/symbols.lisp:1.11 --- movitz/losp/muerte/symbols.lisp:1.10 Fri Apr 16 15:24:20 2004 +++ movitz/losp/muerte/symbols.lisp Fri Apr 16 19:36:40 2004 @@ -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.10 2004/04/16 19:24:20 ffjeld Exp $ +;;;; $Id: symbols.lisp,v 1.11 2004/04/16 23:36:40 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -61,6 +61,13 @@ (defun %symbol-global-value (symbol) (%symbol-global-value symbol)) + +(define-compiler-macro (setf %symbol-global-value) (value symbol) + `(setf (memref ,symbol ,(bt:slot-offset 'movitz:movitz-symbol 'movitz::value) 0 :lisp) + ,value)) + +(defun (setf %symbol-global-value) (value symbol) + (setf (%symbol-global-value symbol) value)) (defun symbol-function (symbol) (let ((function-value

1 0

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

16 Apr '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv24308 Modified Files: primitive-functions.lisp Log Message: Minor edits. Date: Fri Apr 16 19:35:29 2004 Author: ffjeld Index: movitz/losp/muerte/primitive-functions.lisp diff -u movitz/losp/muerte/primitive-functions.lisp:1.12 movitz/losp/muerte/primitive-functions.lisp:1.13 --- movitz/losp/muerte/primitive-functions.lisp:1.12 Thu Apr 15 09:07:24 2004 +++ movitz/losp/muerte/primitive-functions.lisp Fri Apr 16 19:35:29 2004 @@ -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.12 2004/04/15 13:07:24 ffjeld Exp $ +;;;; $Id: primitive-functions.lisp,v 1.13 2004/04/16 23:35:29 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -601,8 +601,6 @@ (find-class (structure-object-name object))) (character (find-class 'character)) - (basic-restart - (find-class 'basic-restart)) (run-time-context (find-class 'run-time-context)) (null @@ -613,6 +611,8 @@ (find-class 'symbol)) (fixnum (find-class 'fixnum)) + (basic-restart + (find-class 'basic-restart)) (tag6 (error "Don't know the class of ~Z with other-type #x~X." object (with-inline-assembly (:returns :untagged-fixnum-ecx)

1 0

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

16 Apr '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv20384 Modified Files: typep.lisp Log Message: Made typep considerably smarter about the integer type. Date: Fri Apr 16 19:34:43 2004 Author: ffjeld Index: movitz/losp/muerte/typep.lisp diff -u movitz/losp/muerte/typep.lisp:1.6 movitz/losp/muerte/typep.lisp:1.7 --- movitz/losp/muerte/typep.lisp:1.6 Tue Apr 6 20:17:19 2004 +++ movitz/losp/muerte/typep.lisp Fri Apr 16 19:34:43 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Dec 8 11:07:53 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: typep.lisp,v 1.6 2004/04/07 00:17:19 ffjeld Exp $ +;;;; $Id: typep.lisp,v 1.7 2004/04/16 23:34:43 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -239,17 +239,70 @@ (when deriver-function `(typep ,object ',(funcall deriver-function))))))) ((consp type) - (case (car type) - ((not) - (assert (and (cadr type) (not (cddr type)))) - `(not (typep ,object ',(cadr type)))) - ((or and) - `(let ((typep-object ,object)) - (,(car type) - ,@(loop for subtype in (cdr type) - collect `(typep ,object ',subtype))))) - ((not and or) - (warn "typep compilermacro: ~S" type))))) + (let ((deriver-function (gethash (car type) *compiler-derived-typespecs*))) + (if deriver-function + `(typep ,object ',(apply deriver-function (cdr type))) + (case (car type) + ((integer) + (destructuring-bind (&optional (lower-limit '*) (upper-limit '*)) + (cdr type) + (let* ((min movitz:+movitz-most-negative-fixnum+) + (max movitz:+movitz-most-positive-fixnum+) + (lower-limit (if (eq lower-limit '*) min lower-limit)) + (upper-limit (if (eq upper-limit '*) max upper-limit))) + (assert (<= lower-limit upper-limit) () + "The lower limit of an integer type must be smaller than the upper limit.") + (cond + ((and (= lower-limit min) (= upper-limit max)) + `(typep ,object 'integer)) + ((= lower-limit upper-limit) + `(eql ,object ,lower-limit)) + ((and (= lower-limit 0) + (= 1 (logcount (1+ upper-limit)))) + `(with-inline-assembly (:returns :boolean-zf=1) + (:compile-form (:result-mode :eax) ,object) + (:testl ,(logxor #xffffffff + (* movitz:+movitz-fixnum-factor+ upper-limit)) + :eax))) + ((= 1 (logcount (1+ (- upper-limit lower-limit)))) + `(with-inline-assembly (:returns :boolean-zf=1) + (:compile-form (:result-mode :eax) ,object) + (:leal (:eax ,(* movitz:+movitz-fixnum-factor+ + (- lower-limit))) + :ecx) + (:testl ,(logxor #xffffffff + (* movitz:+movitz-fixnum-factor+ + (- upper-limit lower-limit))) + :ecx))) + ((= lower-limit 0) + `(with-inline-assembly-case () + (do-case (t :boolean-cf=1 :labels (not-fixnum)) + (:compile-form (:result-mode :eax) ,object) + (:testb ,movitz:+movitz-fixnum-zmask+ :al) ; CF<=0 + (:jnz 'not-fixnum) + (:cmpl ,(* (1+ upper-limit) movitz:+movitz-fixnum-factor+) + :eax) + not-fixnum))) + (t `(with-inline-assembly-case () + (do-case (t :boolean-cf=1 :labels (not-fixnum)) + (:compile-form (:result-mode :eax) ,object) + (:testb ,movitz:+movitz-fixnum-zmask+ :al) ; CF<=0 + (:jnz 'not-fixnum) + (:subl ,(* lower-limit movitz:+movitz-fixnum-factor+) :eax) + (:cmpl ,(* (- upper-limit lower-limit -1) + movitz:+movitz-fixnum-factor+) + :eax) + not-fixnum))))))) + ((not) + (assert (and (cadr type) (not (cddr type)))) + `(not (typep ,object ',(cadr type)))) + ((or and) + `(let ((typep-object ,object)) + (,(car type) + ,@(loop for subtype in (cdr type) + collect `(typep ,object ',subtype))))) + ((not and or) + (warn "typep compilermacro: ~S" type))))))) form))))) (defmacro define-typep (tname lambda &body body)

1 0

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

16 Apr '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv29476 Modified Files: basic-macros.lisp Log Message: Make define-compile-time-variable behave more like defvar than defparameter. Date: Fri Apr 16 19:33:36 2004 Author: ffjeld Index: movitz/losp/muerte/basic-macros.lisp diff -u movitz/losp/muerte/basic-macros.lisp:1.12 movitz/losp/muerte/basic-macros.lisp:1.13 --- movitz/losp/muerte/basic-macros.lisp:1.12 Fri Apr 16 15:25:11 2004 +++ movitz/losp/muerte/basic-macros.lisp Fri Apr 16 19:33:36 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.12 2004/04/16 19:25:11 ffjeld Exp $ +;;;; $Id: basic-macros.lisp,v 1.13 2004/04/16 23:33:36 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -138,9 +138,11 @@ (let ((the-value (eval value))) `(progn (eval-when (:compile-toplevel) - (defparameter ,name ',the-value) - (pushnew ',name (movitz::image-compile-time-variables movitz::*image*))) - (defparameter ,name ',the-value)))) + (defvar ,name) + (unless (member ',name (movitz::image-compile-time-variables movitz::*image*)) + (setf ,name ',the-value) + (push ',name (movitz::image-compile-time-variables movitz::*image*)))) + (defvar ,name 'uninitialized-compile-time-variable)))) (defmacro let* (var-list &body body) (labels ((expand (rest-vars body)

1 0

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

16 Apr '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv12854 Modified Files: basic-macros.lisp Log Message: Re-wrote the check-type macro somewhat. It should require less code-size now. Date: Fri Apr 16 15:25:12 2004 Author: ffjeld Index: movitz/losp/muerte/basic-macros.lisp diff -u movitz/losp/muerte/basic-macros.lisp:1.11 movitz/losp/muerte/basic-macros.lisp:1.12 --- movitz/losp/muerte/basic-macros.lisp:1.11 Fri Apr 16 14:55:07 2004 +++ movitz/losp/muerte/basic-macros.lisp Fri Apr 16 15:25:11 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.11 2004/04/16 18:55:07 ffjeld Exp $ +;;;; $Id: basic-macros.lisp,v 1.12 2004/04/16 19:25:11 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -520,13 +520,15 @@ `((:movw ,(dpb wide-other-tag (byte 8 8) (movitz::tag other-tag)) (:eax -2)))))) (defmacro check-type (place type &optional type-string) - (declare (ignore type-string)) - `(let ((place-value ,place)) - (unless (typep place-value ',type) - (error "Place ~A is not of type ~A, its value is {~Z}." - ',place ',type place-value)))) + (if (not (stringp type-string)) + `(let ((place-value ,place)) + (unless (typep place-value ',type) + (check-type-failed place-value ',type ',place))) + `(let ((place-value ,place)) + (unless (typep place-value ',type) + (check-type-failed place-value ',type ',place ,type-string))))) -(define-compiler-macro check-type (place type &optional type-string &environment env) +(define-compiler-macro check-type (&whole form place type &optional type-string &environment env) (declare (ignore type-string)) (cond ((movitz:movitz-constantp place env) @@ -538,10 +540,7 @@ `(unless (typep ,place ',type) (with-inline-assembly (:returns :non-local-exit) (:int 66))) - `(let ((place-value ,place)) - (unless (typep place-value ',type) - (error "Place ~A is not of type ~A, its value is ~Z." - ',place ',type place-value))))))) + form)))) (defmacro assert (test-form &optional places datum-form &rest argument-forms) (declare (ignore places))

1 0

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

16 Apr '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv9750 Modified Files: basic-functions.lisp Log Message: Re-wrote the check-type macro somewhat. It should require less code-size now. Date: Fri Apr 16 15:25:06 2004 Author: ffjeld Index: movitz/losp/muerte/basic-functions.lisp diff -u movitz/losp/muerte/basic-functions.lisp:1.10 movitz/losp/muerte/basic-functions.lisp:1.11 --- movitz/losp/muerte/basic-functions.lisp:1.10 Tue Apr 6 20:20:12 2004 +++ movitz/losp/muerte/basic-functions.lisp Fri Apr 16 15:25:06 2004 @@ -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.10 2004/04/07 00:20:12 ffjeld Exp $ +;;;; $Id: basic-functions.lisp,v 1.11 2004/04/16 19:25:06 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -369,5 +369,12 @@ (defun %word-offset (word offset) (%word-offset word offset)) - - +(defun check-type-failed (value type &optional place-name type-description) + (cond + ((and place-name type-description) + (error "The value of ~S, ~S, is not ~A." + place-name value type-description)) + (place-name + (error "The value of ~S, ~S, is not of type ~S." + place-name value type)) + (t (error "~S is not of type ~S." value type)))) \ No newline at end of file

1 0