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

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

19 Apr '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv21868 Modified Files: compiler-types.lisp Log Message: Minor improvements. Date: Sun Apr 18 20:29:35 2004 Author: ffjeld Index: movitz/compiler-types.lisp diff -u movitz/compiler-types.lisp:1.11 movitz/compiler-types.lisp:1.12 --- movitz/compiler-types.lisp:1.11 Sun Apr 18 19:10:30 2004 +++ movitz/compiler-types.lisp Sun Apr 18 20:29:35 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Wed Sep 10 00:40:07 2003 ;;;; -;;;; $Id: compiler-types.lisp,v 1.11 2004/04/18 23:10:30 ffjeld Exp $ +;;;; $Id: compiler-types.lisp,v 1.12 2004/04/19 00:29:35 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -266,14 +266,14 @@ sub-specs))) (cond ((null sub-specs) - (and complement t)) + (if complement t nil)) ((not (cdr sub-specs)) (if (not complement) (car sub-specs) - (cons 'not (car sub-specs)))) + (list 'not (car sub-specs)))) (t (if (not complement) (cons 'or sub-specs) - (cons 'not (cons 'or sub-specs)))))))) + (list 'not (cons 'or sub-specs)))))))) (defun type-values (codes &key integer-range members include complement) ;; Members: A list of objects explicitly included in type. @@ -376,9 +376,20 @@ `(and ,sub1 ,(encoded-type-decode code0 integer-range0 members0 include0 nil))) include1) nil)) - (t (warn "and with two includes..") - (type-values t)))) - (t (error "Not implemented.")))) + (t ;; (warn "and with two includes: ~S ~S" include0 include1) + (type-values () :include `(and ,(encoded-type-decode code0 integer-range0 members0 + include0 complement0) + ,(encoded-type-decode code1 integer-range1 members1 + include1 complement1)))))) + ((and complement0 complement1) + (multiple-value-bind (code integer-range members include complement) + (encoded-types-or code0 integer-range0 members0 include0 (not complement0) + code1 integer-range1 members1 include1 (not complement1)) + (values code integer-range members include (not complement)))) + (t (type-values () :include `(and ,(encoded-type-decode code0 integer-range0 members0 + include0 complement0) + ,(encoded-type-decode code1 integer-range1 members1 + include1 complement1)))))) (defun encoded-types-or (code0 integer-range0 members0 include0 complement0 code1 integer-range1 members1 include1 complement1)

1 0

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

18 Apr '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv23169 Modified Files: functions.lisp Log Message: Use the type function rather than compiled-function. Date: Sun Apr 18 19:18:32 2004 Author: ffjeld Index: movitz/losp/muerte/functions.lisp diff -u movitz/losp/muerte/functions.lisp:1.9 movitz/losp/muerte/functions.lisp:1.10 --- movitz/losp/muerte/functions.lisp:1.9 Thu Apr 15 14:53:15 2004 +++ movitz/losp/muerte/functions.lisp Sun Apr 18 19:18:31 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Mar 12 22:58:54 2002 ;;;; -;;;; $Id: functions.lisp,v 1.9 2004/04/15 18:53:15 ffjeld Exp $ +;;;; $Id: functions.lisp,v 1.10 2004/04/18 23:18:31 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -76,18 +76,18 @@ ;;; funobj object (defun funobj-type (funobj) - (check-type funobj compiled-function) + (check-type funobj function) (with-inline-assembly (:returns :untagged-fixnum-ecx) (:xorl :ecx :ecx) (:compile-form (:result-mode :eax) funobj) (:movb (:eax #.(bt::slot-offset 'movitz:movitz-funobj 'movitz:funobj-type)) :cl))) (defun funobj-code-vector (funobj) - (check-type funobj compiled-function) + (check-type funobj function) (memref funobj #.(bt:slot-offset 'movitz:movitz-funobj 'movitz::code-vector) 0 :code-vector)) (defun (setf funobj-code-vector) (code-vector funobj) - (check-type funobj compiled-function) + (check-type funobj function) (check-type code-vector vector-u8) (setf (memref funobj #.(bt:slot-offset 'movitz:movitz-funobj 'movitz::code-vector) 0 :code-vector) code-vector)) @@ -97,7 +97,7 @@ a pointer into the regular code-vector, or it points (with offset 2) to another vector entirely. The former is represented as a lisp integer that is the index into the code-vector, the latter is represented as that vector." - (check-type funobj compiled-function) + (check-type funobj function) (with-inline-assembly (:returns :eax) (:compile-form (:result-mode :eax) funobj) (:movl (:eax #.(bt::slot-offset 'movitz:movitz-funobj 'movitz:code-vector)) :ebx) ; EBX = code-vector @@ -119,7 +119,7 @@ done)) ; this cell stores word+2 (defun (setf funobj-code-vector%1op) (code-vector funobj) - (check-type funobj compiled-function) + (check-type funobj function) (etypecase code-vector (vector-u8 (with-inline-assembly (:returns :nothing) @@ -142,7 +142,7 @@ a pointer into the regular code-vector, or it points (with offset 2) to another vector entirely. The former is represented as a lisp integer that is the index into the code-vector, the latter is represented as that vector." - (check-type funobj compiled-function) + (check-type funobj function) (with-inline-assembly (:returns :eax) (:compile-form (:result-mode :eax) funobj) (:movl (:eax #.(bt::slot-offset 'movitz:movitz-funobj 'movitz:code-vector)) :ebx) ; EBX = code-vector @@ -164,7 +164,7 @@ done)) (defun (setf funobj-code-vector%2op) (code-vector funobj) - (check-type funobj compiled-function) + (check-type funobj function) (etypecase code-vector (vector-u8 (with-inline-assembly (:returns :nothing) @@ -187,7 +187,7 @@ a pointer into the regular code-vector, or it points (with offset 2) to another vector entirely. The former is represented as a lisp integer that is the index into the code-vector, the latter is represented as that vector." - (check-type funobj compiled-function) + (check-type funobj function) (with-inline-assembly (:returns :eax) (:compile-form (:result-mode :eax) funobj) (:movl (:eax #.(bt::slot-offset 'movitz:movitz-funobj 'movitz:code-vector)) :ebx) ; EBX = code-vector @@ -209,7 +209,7 @@ done)) (defun (setf funobj-code-vector%3op) (code-vector funobj) - (check-type funobj compiled-function) + (check-type funobj function) (etypecase code-vector (vector-u8 (with-inline-assembly (:returns :nothing) @@ -228,47 +228,47 @@ code-vector) (defun funobj-name (funobj) - (check-type funobj compiled-function) + (check-type funobj function) (movitz-accessor funobj movitz-funobj name)) (defun (setf funobj-name) (name funobj) - (check-type funobj compiled-function) + (check-type funobj function) ;; (check-type name (or symbol list) (setf-movitz-accessor (funobj movitz-funobj name) name)) (defun funobj-lambda-list (funobj) - (check-type funobj compiled-function) + (check-type funobj function) (movitz-accessor funobj movitz-funobj lambda-list)) (defun (setf funobj-lambda-list) (lambda-list funobj) - (check-type funobj compiled-function) + (check-type funobj function) (check-type lambda-list list) (setf-movitz-accessor (funobj movitz-funobj lambda-list) lambda-list)) (defun funobj-num-constants (funobj) - (check-type funobj compiled-function) + (check-type funobj function) (movitz-accessor-u16 funobj movitz-funobj num-constants)) (defun (setf funobj-num-constants) (num-constants funobj) - (check-type funobj compiled-function) + (check-type funobj function) (check-type num-constants (unsigned-byte 16)) (set-movitz-accessor-u16 funobj movitz-funobj num-constants num-constants)) (defun funobj-num-jumpers (funobj) - (check-type funobj compiled-function) + (check-type funobj function) (with-inline-assembly (:returns :eax) (:compile-form (:result-mode :eax) funobj) (:movzxw (:eax #.(bt:slot-offset 'movitz:movitz-funobj 'movitz::num-jumpers)) :eax))) (defun (setf funobj-num-jumpers) (num-jumpers funobj) - (check-type funobj compiled-function) + (check-type funobj function) (check-type num-jumpers (unsigned-byte 14)) (with-inline-assembly (:returns :eax) (:compile-two-forms (:eax :ebx) num-jumpers funobj) (:movw :ax (:ebx #.(bt:slot-offset 'movitz:movitz-funobj 'movitz::num-jumpers))))) (defun funobj-constant-ref (funobj index) - (check-type funobj compiled-function) + (check-type funobj function) (assert (below index (funobj-num-constants funobj)) (index) "Index ~D out of range, ~S has ~D constants." index funobj (funobj-num-constants funobj)) (if (>= index (funobj-num-jumpers funobj)) @@ -287,7 +287,7 @@ (:leal ((:ebx #.movitz:+movitz-fixnum-factor+)) :eax)))) (defun (setf funobj-constant-ref) (value funobj index) - (check-type funobj compiled-function) + (check-type funobj function) (assert (below index (funobj-num-constants funobj)) (index) "Index ~D out of range, ~S has ~D constants." index funobj (funobj-num-constants funobj)) (if (>= index (funobj-num-jumpers funobj)) @@ -311,7 +311,7 @@ value))) (defun funobj-debug-info (funobj) - (check-type funobj compiled-function) + (check-type funobj function) (movitz-accessor-u16 funobj movitz-funobj debug-info)) (defun funobj-frame-num-unboxed (funobj)

1 0

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

18 Apr '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv21745 Modified Files: interrupt.lisp Log Message: *** empty log message *** Date: Sun Apr 18 19:17:59 2004 Author: ffjeld Index: movitz/losp/muerte/interrupt.lisp diff -u movitz/losp/muerte/interrupt.lisp:1.6 movitz/losp/muerte/interrupt.lisp:1.7 --- movitz/losp/muerte/interrupt.lisp:1.6 Thu Apr 15 11:23:36 2004 +++ movitz/losp/muerte/interrupt.lisp Sun Apr 18 19:17:58 2004 @@ -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.6 2004/04/15 15:23:36 ffjeld Exp $ +;;;; $Id: interrupt.lisp,v 1.7 2004/04/18 23:17:58 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -166,6 +166,12 @@ $eip (interrupt-frame-ref interrupt-frame :error-code :unsigned-byte32) $eax $ebx $ecx)) + ((61) + ;; 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 (@ $eax) :expected-type (@ $edx))) + (format *query-io* "Enter a new value: ") + (setf (@ $eax) (read *query-io*))) (68 (warn "EIP: ~@Z EAX: ~@Z EBX: ~@Z ECX: ~@Z EDX: ~@Z" $eip $eax $ebx $ecx $edx) (dotimes (i 100000)

1 0

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

18 Apr '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv1525 Modified Files: conditions.lisp Log Message: Added a reporter. Date: Sun Apr 18 19:17:36 2004 Author: ffjeld Index: movitz/losp/muerte/conditions.lisp diff -u movitz/losp/muerte/conditions.lisp:1.5 movitz/losp/muerte/conditions.lisp:1.6 --- movitz/losp/muerte/conditions.lisp:1.5 Thu Apr 15 11:11:44 2004 +++ movitz/losp/muerte/conditions.lisp Sun Apr 18 19:17:36 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Wed Nov 20 15:47:04 2002 ;;;; -;;;; $Id: conditions.lisp,v 1.5 2004/04/15 15:11:44 ffjeld Exp $ +;;;; $Id: conditions.lisp,v 1.6 2004/04/18 23:17:36 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -94,7 +94,11 @@ :reader type-error-expected-type) (datum :initarg :datum - :reader type-error-datum))) + :reader type-error-datum)) + (:report (lambda (c s) + (format s "The object ~S is not of type ~S." + (type-error-datum c) + (type-error-expected-type c))))) (define-condition control-error (error) ())

1 0

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

18 Apr '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv30454 Modified Files: common-lisp.lisp Log Message: Minor re-ordering. Date: Sun Apr 18 19:17:04 2004 Author: ffjeld Index: movitz/losp/muerte/common-lisp.lisp diff -u movitz/losp/muerte/common-lisp.lisp:1.4 movitz/losp/muerte/common-lisp.lisp:1.5 --- movitz/losp/muerte/common-lisp.lisp:1.4 Tue Apr 6 20:13:02 2004 +++ movitz/losp/muerte/common-lisp.lisp Sun Apr 18 19:17:04 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Wed Nov 8 18:41:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: common-lisp.lisp,v 1.4 2004/04/07 00:13:02 ffjeld Exp $ +;;;; $Id: common-lisp.lisp,v 1.5 2004/04/18 23:17:04 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -43,11 +43,11 @@ (require :muerte/eval) (require :muerte/los-closette) (require :muerte/environment) -(require :muerte/interrupt) (require :muerte/streams) (require :muerte/restarts) (require :muerte/conditions) (require :muerte/read) +(require :muerte/interrupt) (require :muerte/scavenge) (require :muerte/simple-streams)

1 0

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

18 Apr '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv13920/losp/muerte Modified Files: defstruct.lisp Log Message: Don't use exception 60. Date: Sun Apr 18 19:16:49 2004 Author: ffjeld Index: movitz/losp/muerte/defstruct.lisp diff -u movitz/losp/muerte/defstruct.lisp:1.5 movitz/losp/muerte/defstruct.lisp:1.6 --- movitz/losp/muerte/defstruct.lisp:1.5 Mon Mar 29 09:53:13 2004 +++ movitz/losp/muerte/defstruct.lisp Sun Apr 18 19:16:49 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Mon Jan 22 13:10:59 2001 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: defstruct.lisp,v 1.5 2004/03/29 14:53:13 ffjeld Exp $ +;;;; $Id: defstruct.lisp,v 1.6 2004/04/18 23:16:49 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -57,9 +57,9 @@ (:compile-form (:result-mode :eax) object) (:leal (:eax ,(- (movitz:tag :other))) :ecx) (:testb 7 :cl) - (:jne '(:sub-program (type-error) (:int 60))) + (:jne '(:sub-program (type-error) (:int 66))) (:cmpb ,(movitz:tag :defstruct) (-2 :eax)) - (:jne '(:sub-program (type-error) (:int 60))) + (:jne '(:sub-program (type-error) (:int 66))) ;; type test passed, read slot ,@(if (= 4 movitz::+movitz-fixnum-factor+) `((:compile-form (:result-mode :ebx) slot-number) @@ -78,9 +78,9 @@ (:compile-two-forms (:eax :ebx) object slot-number) (:leal (:eax ,(- (movitz:tag :other))) :ecx) (:testb 7 :cl) - (:jne '(:sub-program (type-error) (:int 60))) + (:jne '(:sub-program (type-error) (:int 66))) (:cmpb ,(movitz:tag :defstruct) (-2 :eax)) - (:jne '(:sub-program (type-error) (:int 60))) + (:jne '(:sub-program (type-error) (:int 66))) (:movzxw (:eax ,(bt:slot-offset 'movitz::movitz-struct 'movitz::length)) :ecx) (:leal ((:ecx ,movitz::+movitz-fixnum-factor+)) :ecx) (:testb ,movitz::+movitz-fixnum-zmask+ :bl) @@ -99,12 +99,12 @@ (:compile-form (:result-mode :eax) object) (:leal (:eax #.(cl:- (movitz:tag :other))) :ecx) (:testb 7 :cl) - (:jne '(:sub-program (type-error) (:int 60))) + (:jne '(:sub-program (type-error) (:int 66))) (:cmpb #.(movitz:tag :defstruct) (-2 :eax)) - (:jne '(:sub-program (type-error) (:int 60))) + (:jne '(:sub-program (type-error) (:int 66))) (:load-constant struct-name :ebx) (:cmpl :ebx (:eax #.(bt:slot-offset 'movitz::movitz-struct 'movitz::name))) - (:jne '(:sub-program (type-error) (:int 60))) + (:jne '(:sub-program (type-error) (:int 66))) ;; type test passed, read slot (:load-constant slot-number :ecx) (:shrl #.movitz::+movitz-fixnum-shift+ :ecx) @@ -118,12 +118,12 @@ ;; type test (:leal (:ebx #.(cl:- (movitz:tag :other))) :ecx) (:testb 7 :cl) - (:jnz '(:sub-program (type-error) (:int 60))) + (:jnz '(:sub-program (type-error) (:int 66))) (:cmpb #.(movitz:tag :defstruct) (-2 :ebx)) - (:jne '(:sub-program (type-error) (:int 60))) + (:jne '(:sub-program (type-error) (:int 66))) (:load-constant struct-name :ecx) (:cmpl :ecx (:ebx #.(bt:slot-offset 'movitz::movitz-struct 'movitz::name))) - (:jne '(:sub-program (type-error) (:int 60))) + (:jne '(:sub-program (type-error) (:int 66))) ;; type test passed, write slot (:load-constant slot-number :ecx) (:shrl #.movitz::+movitz-fixnum-shift+ :ecx)

1 0

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

18 Apr '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv8777 Modified Files: characters.lisp Log Message: Don't use exception 60. Date: Sun Apr 18 19:16:44 2004 Author: ffjeld Index: movitz/losp/muerte/characters.lisp diff -u movitz/losp/muerte/characters.lisp:1.2 movitz/losp/muerte/characters.lisp:1.3 --- movitz/losp/muerte/characters.lisp:1.2 Mon Jan 19 06:23:46 2004 +++ movitz/losp/muerte/characters.lisp Sun Apr 18 19:16:44 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Mon Feb 5 19:05:01 2001 ;;;; -;;;; $Id: characters.lisp,v 1.2 2004/01/19 11:23:46 ffjeld Exp $ +;;;; $Id: characters.lisp,v 1.3 2004/04/18 23:16:44 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -26,7 +26,7 @@ (with-inline-assembly (:returns :eax) (:compile-form (:result-mode :eax) character) (:cmpb #.(movitz::tag :character) :al) - (:jne '(:sub-program (not-a-character) (:int 60))) + (:jne '(:sub-program (not-a-character) (:int 66))) (:shrl #.(cl:- 8 movitz::+movitz-fixnum-shift+) :eax))) (defun code-char (code)

1 0

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

18 Apr '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv16219 Modified Files: basic-macros.lisp Log Message: minor edit. Date: Sun Apr 18 19:15:53 2004 Author: ffjeld Index: movitz/losp/muerte/basic-macros.lisp diff -u movitz/losp/muerte/basic-macros.lisp:1.15 movitz/losp/muerte/basic-macros.lisp:1.16 --- movitz/losp/muerte/basic-macros.lisp:1.15 Sun Apr 18 17:27:37 2004 +++ movitz/losp/muerte/basic-macros.lisp Sun Apr 18 19:15:53 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.15 2004/04/18 21:27:37 ffjeld Exp $ +;;;; $Id: basic-macros.lisp,v 1.16 2004/04/18 23:15:53 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -534,7 +534,7 @@ ((movitz:movitz-constantp place env) (assert (typep (movitz::eval-form place env) type)) nil) - (t (if (member type '(standard-gf-instance function pointer + (t (if (member type '(standard-gf-instance function pointer atom integer fixnum cons symbol character null list string vector simple-vector vector-u8 vector-u16)) `(unless (typep ,place ',type)

1 0

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

18 Apr '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv16361 Modified Files: compiler.lisp Log Message: Fixed one compiler bug that would show itself compiling e.g. (setf x (setf y ...)). Also removed some improper use of ecx as temporary register. Date: Sun Apr 18 19:12:37 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.53 movitz/compiler.lisp:1.54 --- movitz/compiler.lisp:1.53 Sat Apr 17 11:33:45 2004 +++ movitz/compiler.lisp Sun Apr 18 19:12:37 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.53 2004/04/17 15:33:45 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.54 2004/04/18 23:12:37 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -3064,7 +3064,7 @@ (or tmp-register (unless (member preferred protect-registers) preferred) - (first (set-difference '(:eax :ebx :ecx :edx) + (first (set-difference '(:eax :ebx :edx) protect-registers)) (error "Unable to chose a temporary register."))) (install-for-single-value (lexb lexb-location result-mode indirect-p) @@ -3238,8 +3238,8 @@ dest-location binding destination) - (append (install-for-single-value binding binding-location :ecx nil) - (make-store-lexical result-mode :ecx nil frame-map)))))) + (append (install-for-single-value binding binding-location :eax nil) + (make-store-lexical result-mode :eax nil frame-map)))))) (t (make-result-and-returns-glue result-mode :eax (install-for-single-value binding binding-location :eax nil))) @@ -4413,9 +4413,10 @@ ((:lexical-binding) (case (result-mode-type returns-provided) (:lexical-binding - (assert (eq desired-result returns-provided) () - "Desired-result ~S produced a value in ~S for code ~W." desired-result returns-provided code) - (values code returns-provided)) + (if (eq desired-result returns-provided) + (values code returns-provided) + (values (append code `((:load-lexical ,returns-provided ,desired-result))) + returns-provided))) ((:eax :multiple-values) (values (append code `((:store-lexical ,desired-result :eax

1 0

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

18 Apr '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv7552 Modified Files: compiler-types.lisp Log Message: Changed how to deal with unknown types, slightly. Date: Sun Apr 18 19:10:31 2004 Author: ffjeld Index: movitz/compiler-types.lisp diff -u movitz/compiler-types.lisp:1.10 movitz/compiler-types.lisp:1.11 --- movitz/compiler-types.lisp:1.10 Tue Apr 6 09:35:41 2004 +++ movitz/compiler-types.lisp Sun Apr 18 19:10:30 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Wed Sep 10 00:40:07 2003 ;;;; -;;;; $Id: compiler-types.lisp,v 1.10 2004/04/06 13:35:41 ffjeld Exp $ +;;;; $Id: compiler-types.lisp,v 1.11 2004/04/18 23:10:30 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -363,7 +363,7 @@ (numscope-intersection integer-range0 integer-range1)) (intersection members0 members1) (mapcar (lambda (sub0) - `(and ,sub0 (:encoded ,code1 ,integer-range1 ,members1 ,include1 nil))) + `(and ,sub0 ,(encoded-type-decode code1 integer-range1 members1 include1 nil))) include0) nil)) ((and (null include0) include1) @@ -373,7 +373,7 @@ (numscope-intersection integer-range0 integer-range1)) (intersection members0 members1) (mapcar (lambda (sub1) - `(and ,sub1 (:encoded ,code0 ,integer-range0 ,members0 ,include0 nil))) + `(and ,sub1 ,(encoded-type-decode code0 integer-range0 members0 include0 nil))) include1) nil)) (t (warn "and with two includes..") @@ -436,14 +436,12 @@ (t (let ((deriver (and (boundp 'muerte::*compiler-derived-typespecs*) (gethash type-specifier (symbol-value 'muerte::*compiler-derived-typespecs*))))) - (assert deriver (type-specifier) - "Unknown type ~S." type-specifier) - (type-specifier-encode (funcall deriver)))))) + (if deriver + (type-specifier-encode (funcall deriver)) + (type-values () :include (list type-specifier))))))) ((listp type-specifier) (check-type (car type-specifier) symbol) (case (car type-specifier) - (:encoded - (multiple-value-list (cdr type-specifier))) (satisfies (type-values () :include (list type-specifier))) (member

1 0