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

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

04 Jun '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv12267 Modified Files: more-macros.lisp Log Message: Added a newline at end of file. Date: Fri Jun 4 06:32:17 2004 Author: ffjeld Index: movitz/losp/muerte/more-macros.lisp diff -u movitz/losp/muerte/more-macros.lisp:1.7 movitz/losp/muerte/more-macros.lisp:1.8 --- movitz/losp/muerte/more-macros.lisp:1.7 Mon Apr 19 15:38:33 2004 +++ movitz/losp/muerte/more-macros.lisp Fri Jun 4 06:32:16 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Jun 7 15:05:57 2002 ;;;; -;;;; $Id: more-macros.lisp,v 1.7 2004/04/19 22:38:33 ffjeld Exp $ +;;;; $Id: more-macros.lisp,v 1.8 2004/06/04 13:32:16 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -309,4 +309,5 @@ `(,var (slot-value ,object-var ',slot)))) slot-entries) (let ((,object-var ,instance-form)) - ,@declarations-and-forms)))) \ No newline at end of file + ,@declarations-and-forms)))) +

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp
by Frode Vatvedt Fjeld 03 Jun '04

03 Jun '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv15942 Modified Files: integers.lisp Log Message: Removed some dead code. Date: Thu Jun 3 02:14:26 2004 Author: ffjeld Index: movitz/losp/muerte/integers.lisp diff -u movitz/losp/muerte/integers.lisp:1.16 movitz/losp/muerte/integers.lisp:1.17 --- movitz/losp/muerte/integers.lisp:1.16 Wed Jun 2 16:48:15 2004 +++ movitz/losp/muerte/integers.lisp Thu Jun 3 02:14:25 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Wed Nov 8 18:44:57 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: integers.lisp,v 1.16 2004/06/02 23:48:15 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.17 2004/06/03 09:14:25 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -84,59 +84,6 @@ (cons constant-term non-constant-operands)))))) `(+ (+%2op ,(first operands) ,(second operands)) ,@(cddr operands)))))) -#+ignore -(defun +%2op (term1 term2) - (check-type term1 fixnum) - (check-type term2 fixnum) - (with-inline-assembly (:returns :eax) - (:compile-form (:result-mode :eax) term1) - (:compile-form (:result-mode :ebx) term2) - (:addl :ebx :eax) - (:into))) - -;;;(define-compiler-macro +%2op (&whole form term1 term2) -;;; (cond -;;; ((and (movitz:movitz-constantp term1) ; first operand zero? -;;; (zerop (movitz:movitz-eval term1))) -;;; term2) ; (+ 0 x) => x -;;; ((and (movitz:movitz-constantp term2) ; second operand zero? -;;; (zerop (movitz:movitz-eval term2))) -;;; term1) ; (+ x 0) => x -;;; ((and (movitz:movitz-constantp term1) -;;; (movitz:movitz-constantp term2)) -;;; (+ (movitz:movitz-eval term1) -;;; (movitz:movitz-eval term2))) ; compile-time constant folding. -;;; ((movitz:movitz-constantp term1) -;;; (let ((constant-term1 (movitz:movitz-eval term1))) -;;; (check-type constant-term1 (signed-byte 30)) -;;; `(with-inline-assembly (:returns :register :side-effects nil) ; inline -;;; (:compile-form (:result-mode :register) ,term2) -;;; (:addl ,(* movitz::+movitz-fixnum-factor+ constant-term1) (:result-register)) -;;; (:into)))) -;;; ((movitz:movitz-constantp term2) -;;; (let ((constant-term2 (movitz:movitz-eval term2))) -;;; (check-type constant-term2 (signed-byte 30)) -;;; `(with-inline-assembly (:returns :register :side-effects nil) ; inline -;;; (:compile-form (:result-mode :register) ,term1) -;;; (:addl ,(* movitz::+movitz-fixnum-factor+ constant-term2) (:result-register)) -;;; (:into)))) -;;; (t `(with-inline-assembly (:returns :eax :side-effects nil) -;;; (:compile-two-forms (:ebx :eax) ,term1 ,term2) -;;; (:addl :ebx :eax) -;;; (:into))))) - -(defun 1+ (number) - (+ 1 number)) - -(define-compiler-macro 1+ (number) - `(+ ,number 1)) - -(defun 1- (number) - (- number 1)) - -(define-compiler-macro 1- (number) - `(- ,number 1)) - (defun + (&rest terms) (numargs-case (1 (x) x) @@ -177,8 +124,17 @@ 0 (reduce #'+ terms))))) -;;;(defmacro incf (place &optional (delta-form 1)) -;;; `(setf ,place (+ ,place ,delta-form))) +(defun 1+ (number) + (+ 1 number)) + +(define-compiler-macro 1+ (number) + `(+ ,number 1)) + +(defun 1- (number) + (- number 1)) + +(define-compiler-macro 1- (number) + `(- ,number 1)) (define-modify-macro incf (&optional (delta-form 1)) +)

1 0

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

02 Jun '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv9181 Modified Files: packages.lisp Log Message: Added symbol. Date: Wed Jun 2 16:52:26 2004 Author: ffjeld Index: movitz/packages.lisp diff -u movitz/packages.lisp:1.23 movitz/packages.lisp:1.24 --- movitz/packages.lisp:1.23 Mon May 24 07:58:27 2004 +++ movitz/packages.lisp Wed Jun 2 16:52:26 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.23 2004/05/24 14:58:27 ffjeld Exp $ +;;;; $Id: packages.lisp,v 1.24 2004/06/02 23:52:26 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1271,6 +1271,7 @@ #:read-time-stamp-counter #:clear-time-stamp-counter #:eflags + #:decode-eflags #:load-idt #:segment-register #:control-register-lo12

1 0

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

02 Jun '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv7848 Modified Files: print.lisp Log Message: Removed hack from write-integer because there are bignums now. Date: Wed Jun 2 16:50:34 2004 Author: ffjeld Index: movitz/losp/muerte/print.lisp diff -u movitz/losp/muerte/print.lisp:1.9 movitz/losp/muerte/print.lisp:1.10 --- movitz/losp/muerte/print.lisp:1.9 Mon May 24 07:58:44 2004 +++ movitz/losp/muerte/print.lisp Wed Jun 2 16:50:34 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.9 2004/05/24 14:58:44 ffjeld Exp $ +;;;; $Id: print.lisp,v 1.10 2004/06/02 23:50:34 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -113,25 +113,15 @@ (t (write-char #\# stream) (write-simple-integer base 10 stream) (write-char #\r stream)))) - (block minus-hack ; don't barf on most-negative-fixnum - (multiple-value-bind (sign-char print-value) - (cond - ((minusp x) - (if (not (eq x most-negative-fixnum)) - (values #\- (- x)) - (return-from minus-hack - (write-string (case base - (2 #.(cl:format cl:nil "~B" movitz::+movitz-most-negative-fixnum+)) - (8 #.(cl:format cl:nil "~O" movitz::+movitz-most-negative-fixnum+)) - (10 #.(cl:format cl:nil "~D" movitz::+movitz-most-negative-fixnum+)) - (16 #.(cl:format cl:nil "~X" movitz::+movitz-most-negative-fixnum+)) - (t (break "minus-hack!?"))) - stream)))) - (sign-always - (values #\+ x)) - (t (values nil x))) - (write-lowlevel-integer print-value stream base comma-char comma-interval - mincol padchar sign-char 0))) + (multiple-value-bind (sign-char print-value) + (cond + ((minusp x) + (values #\- (- x))) + (sign-always + (values #\+ x)) + (t (values nil x))) + (write-lowlevel-integer print-value stream base comma-char comma-interval + mincol padchar sign-char 0)) (when (and radix (= 10 base)) (write-char #\. stream)) nil)

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/cpu-id.lisp
by Frode Vatvedt Fjeld 02 Jun '04

02 Jun '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv5396 Modified Files: cpu-id.lisp Log Message: Added decode-eflags. Date: Wed Jun 2 16:49:27 2004 Author: ffjeld Index: movitz/losp/muerte/cpu-id.lisp diff -u movitz/losp/muerte/cpu-id.lisp:1.4 movitz/losp/muerte/cpu-id.lisp:1.5 --- movitz/losp/muerte/cpu-id.lisp:1.4 Fri Apr 23 06:00:17 2004 +++ movitz/losp/muerte/cpu-id.lisp Wed Jun 2 16:49:27 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Mon Apr 15 22:47:13 2002 ;;;; -;;;; $Id: cpu-id.lisp,v 1.4 2004/04/23 13:00:17 ffjeld Exp $ +;;;; $Id: cpu-id.lisp,v 1.5 2004/06/02 23:49:27 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -262,6 +262,16 @@ (defun eflags () (eflags)) + +(defconstant +eflags-map+ + '(:cf nil :pf nil :af nil :zf :sf + :tf :if :df :of :iopl0 :iopl1 :nt nil + :rf :vm :ac :vif :vip :id)) + +(defun decode-eflags (&optional (eflags (eflags))) + (loop for flag in +eflags-map+ as bit upfrom 0 + when (and flag (logbitp bit eflags)) + collect flag)) (define-compiler-macro (setf eflags) (value) `(with-inline-assembly (:returns :register)

1 0

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

02 Jun '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv2756 Modified Files: typep.lisp Log Message: Added bignum for typep. Date: Wed Jun 2 16:48:46 2004 Author: ffjeld Index: movitz/losp/muerte/typep.lisp diff -u movitz/losp/muerte/typep.lisp:1.12 movitz/losp/muerte/typep.lisp:1.13 --- movitz/losp/muerte/typep.lisp:1.12 Mon May 24 07:59:01 2004 +++ movitz/losp/muerte/typep.lisp Wed Jun 2 16:48:45 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.12 2004/05/24 14:59:01 ffjeld Exp $ +;;;; $Id: typep.lisp,v 1.13 2004/06/02 23:48:45 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -174,6 +174,8 @@ `(with-inline-assembly (:returns :boolean-zf=1) (:compile-form (:result-mode :eax) ,object) (:testb ,movitz::+movitz-fixnum-zmask+ :al))) + ((bignum) + (make-other-typep :bignum)) ((integer number rational) `(with-inline-assembly-case () (do-case (t :boolean-zf=1 :labels (done)) @@ -510,8 +512,7 @@ (typep x 'fixnum)) (define-simple-typep (bignum bignump) (x) - (declare (ignore x)) - nil) + (typep x 'bignum)) (define-simple-typep (number numberp) (x) "Currently, only integer numbers are supported."

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp
by Frode Vatvedt Fjeld 02 Jun '04

02 Jun '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv2613 Modified Files: integers.lisp Log Message: Minor edit in *. Date: Wed Jun 2 16:48:15 2004 Author: ffjeld Index: movitz/losp/muerte/integers.lisp diff -u movitz/losp/muerte/integers.lisp:1.15 movitz/losp/muerte/integers.lisp:1.16 --- movitz/losp/muerte/integers.lisp:1.15 Wed Jun 2 16:20:46 2004 +++ movitz/losp/muerte/integers.lisp Wed Jun 2 16:48:15 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Wed Nov 8 18:44:57 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: integers.lisp,v 1.15 2004/06/02 23:20:46 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.16 2004/06/02 23:48:15 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -756,8 +756,8 @@ (:jne '(:sub-program (not-fixnum) (:int 107))) (:movl :ebx :ecx) - (:sarl #.movitz::+movitz-fixnum-shift+ :ebx) - (:imull :ebx :eax :edx) + (:sarl #.movitz::+movitz-fixnum-shift+ :ecx) + (:imull :ecx :eax :edx) (:into))) (t (&rest factors) (declare (dynamic-extent factors))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/inspect.lisp
by Frode Vatvedt Fjeld 02 Jun '04

02 Jun '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv25731 Modified Files: inspect.lisp Log Message: Added case for bignums in shallow-copy. Date: Wed Jun 2 16:21:13 2004 Author: ffjeld Index: movitz/losp/muerte/inspect.lisp diff -u movitz/losp/muerte/inspect.lisp:1.9 movitz/losp/muerte/inspect.lisp:1.10 --- movitz/losp/muerte/inspect.lisp:1.9 Sat Apr 17 07:09:07 2004 +++ movitz/losp/muerte/inspect.lisp Wed Jun 2 16:21:13 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Oct 24 09:50:41 2003 ;;;; -;;;; $Id: inspect.lisp,v 1.9 2004/04/17 14:09:07 ffjeld Exp $ +;;;; $Id: inspect.lisp,v 1.10 2004/06/02 23:21:13 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -175,6 +175,8 @@ (etypecase old (cons (cons (car old) (cdr old))) + (bignum + (copy-bignum old)) (std-instance (allocate-std-instance (std-instance-class old) (std-instance-slots old)))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp
by Frode Vatvedt Fjeld 02 Jun '04

02 Jun '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv25469 Modified Files: integers.lisp Log Message: Improved bignum support in + and -. Added function copy-bignum. Date: Wed Jun 2 16:20:46 2004 Author: ffjeld Index: movitz/losp/muerte/integers.lisp diff -u movitz/losp/muerte/integers.lisp:1.14 movitz/losp/muerte/integers.lisp:1.15 --- movitz/losp/muerte/integers.lisp:1.14 Wed Jun 2 13:34:04 2004 +++ movitz/losp/muerte/integers.lisp Wed Jun 2 16:20:46 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Wed Nov 8 18:44:57 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: integers.lisp,v 1.14 2004/06/02 20:34:04 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.15 2004/06/02 23:20:46 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -132,7 +132,7 @@ `(+ ,number 1)) (defun 1- (number) - (+ -1 number)) + (- number 1)) (define-compiler-macro 1- (number) `(- ,number 1)) @@ -156,6 +156,7 @@ (:call-global-constant box-u32-ecx) (:jmp 'fix-fix-ok) fix-fix-negative + (:jz 'fix-double-negative) (:negl :ecx) (:shrl ,movitz:+movitz-fixnum-shift+ :ecx) (:call-global-constant box-u32-ecx) @@ -163,25 +164,13 @@ (movitz:tag :bignum #xff)) (:eax ,movitz:+other-type-offset+)) (:jmp 'fix-fix-ok) - )) + fix-double-negative + (:compile-form (:result-mode :eax) + ,(* 2 movitz:+movitz-most-negative-fixnum+)) + (:jmp 'fix-fix-ok))) fix-fix-ok ))))) (do-it))) - (3 (x y z) - (with-inline-assembly (:returns :eax) - (:compile-form (:result-mode :eax) x) - (:compile-form (:result-mode :ebx) y) - (:movl :eax :ecx) - (:compile-form (:result-mode :edx) z) - (:orl :ebx :ecx) - (:orl :edx :ecx) - (:testb #.movitz::+movitz-fixnum-zmask+ :cl) - (:jnz '(:sub-program (not-integer) - (:int 107))) - (:addl :ebx :eax) - (:into) - (:addl :edx :eax) - (:into))) (t (&rest terms) (declare (dynamic-extent terms)) (if (null terms) @@ -198,7 +187,10 @@ (define-compiler-macro - (&whole form &rest operands &environment env) (case (length operands) (0 0) - (1 `(- 0 ,(first operands))) + (1 (let ((x (first operands))) + (if (movitz:movitz-constantp x env) + (- (movitz:movitz-eval x env)) + form))) (2 (let ((minuend (first operands)) (subtrahend (second operands))) (cond @@ -210,13 +202,53 @@ (defun - (minuend &rest subtrahends) (declare (dynamic-extent subtrahends)) (numargs-case + (1 (x) + (macrolet + ((do-it () + `(with-inline-assembly (:returns :eax) + (:compile-form (:result-mode :eax) x) + (:testb ,movitz:+movitz-fixnum-zmask+ :al) + (:jnz '(:sub-program (not-fixnum) + (:leal (:eax ,(- (movitz:tag :other))) :ecx) + (:testb 7 :cl) + (:jnz '(:sub-program (not-a-number) + (:compile-form (:result-mode :ignore) + (error 'type-error :expected-type 'number :datum x)))) + (:movl (:eax ,movitz:+other-type-offset+) :ecx) + (:cmpb ,(movitz:tag :bignum) :cl) + (:jne 'not-a-number) + (:cmpl ,(dpb 1 (byte 16 16) (movitz:tag :bignum 0)) :ecx) + (:jne 'not-most-negative-fixnum) + (:cmpl ,(- most-negative-fixnum) + (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))) + (:jne 'not-most-negative-fixnum) + (:movl ,(ldb (byte 32 0) + (* most-negative-fixnum movitz::+movitz-fixnum-factor+)) + :eax) + (:jmp 'fix-ok) + not-most-negative-fixnum + (:compile-form (:result-mode :eax) + (copy-bignum x)) + (:notb (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::sign))) + (:jmp 'fix-ok))) + (:negl :eax) + (:jo '(:sub-program (fix-overflow) + (:compile-form (:result-mode :eax) + ,(1+ movitz:+movitz-most-positive-fixnum+)) + (:jmp 'fix-ok))) + fix-ok + ))) + (do-it))) (2 (minuend subtrahend) - (check-type minuend fixnum) - (check-type subtrahend fixnum) - (with-inline-assembly (:returns :eax :side-effects nil) - (:compile-two-forms (:eax :ebx) minuend subtrahend) - (:subl :ebx :eax) - (:into))) + (cond + ((eq 0 minuend) + (- subtrahend)) + (t (check-type minuend fixnum) + (check-type subtrahend fixnum) + (with-inline-assembly (:returns :eax :side-effects nil) + (:compile-two-forms (:eax :ebx) minuend subtrahend) + (:subl :ebx :eax) + (:into))))) (t (minuend &rest subtrahends) (declare (dynamic-extent subtrahends)) (if subtrahends @@ -1262,3 +1294,23 @@ (t (values (1- q) (+ r divisor)))))) (t (n &optional (divisor 1)) (floor n divisor)))) + +(defun copy-bignum (old) + (check-type old bignum) + (let* ((length (with-inline-assembly (:returns :eax) + (:compile-form (:result-mode :eax) old) + (:movzxw (:eax #.(bt:slot-offset 'movitz::movitz-bignum + 'movitz::length)) + :ecx) + (:leal ((:ecx #.movitz:+movitz-fixnum-factor+) + #.movitz:+movitz-fixnum-factor+) + :eax))) + (new (malloc-data-clumps length))) + (with-inline-assembly (:returns :eax) + (:compile-two-forms (:eax :ebx) new old) + (:compile-form (:result-mode :edx) length) + copy-bignum-loop + (:subl #.movitz:+movitz-fixnum-factor+ :edx) + (:movl (:ebx :edx #.movitz:+other-type-offset+) :ecx) + (:movl :ecx (:eax :edx #.movitz:+other-type-offset+)) + (:jnz 'copy-bignum-loop))))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp
by Frode Vatvedt Fjeld 02 Jun '04

02 Jun '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv2677 Modified Files: integers.lisp Log Message: Added some bignum support to +, i.e. two fixnums may now overflow to a bignum. Also changed - a bit. Date: Wed Jun 2 13:34:04 2004 Author: ffjeld Index: movitz/losp/muerte/integers.lisp diff -u movitz/losp/muerte/integers.lisp:1.13 movitz/losp/muerte/integers.lisp:1.14 --- movitz/losp/muerte/integers.lisp:1.13 Tue Jun 1 06:38:35 2004 +++ movitz/losp/muerte/integers.lisp Wed Jun 2 13:34:04 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Wed Nov 8 18:44:57 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: integers.lisp,v 1.13 2004/06/01 13:38:35 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.14 2004/06/02 20:34:04 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -28,6 +28,13 @@ (deftype positive-bignum () `(integer ,(1+ movitz:+movitz-most-positive-fixnum+) *)) +(defmacro number-double-dispatch ((x y) &rest clauses) + `(let ((x ,x) (y ,y)) + (cond ,@(loop for ((x-type y-type) . then-body) in clauses + collect `((and (typep x ',x-type) (typep y ',y-type)) + ,@then-body)) + (t (error "Not numbers: ~S or ~S." x y))))) + (defun fixnump (x) (typep x 'fixnum)) @@ -134,16 +141,32 @@ (numargs-case (1 (x) x) (2 (x y) - (with-inline-assembly (:returns :eax) - (:compile-form (:result-mode :eax) x) - (:compile-form (:result-mode :ebx) y) - (:movl :eax :ecx) - (:orl :ebx :ecx) - (:testb #.movitz::+movitz-fixnum-zmask+ :cl) - (:jnz '(:sub-program (not-integer) ; - (:int 107))) - (:addl :ebx :eax) - (:into))) + (macrolet + ((do-it () + `(number-double-dispatch (x y) + ((fixnum fixnum) + (with-inline-assembly (:returns :eax) + (:compile-form (:result-mode :eax) x) + (:compile-form (:result-mode :ebx) y) + (:addl :ebx :eax) + (:jo '(:sub-program (fix-fix-overflow) + (:movl :eax :ecx) + (:jns 'fix-fix-negative) + (:shrl ,movitz:+movitz-fixnum-shift+ :ecx) + (:call-global-constant box-u32-ecx) + (:jmp 'fix-fix-ok) + fix-fix-negative + (:negl :ecx) + (:shrl ,movitz:+movitz-fixnum-shift+ :ecx) + (:call-global-constant box-u32-ecx) + (:movl ,(dpb 1 (byte 16 16) + (movitz:tag :bignum #xff)) + (:eax ,movitz:+other-type-offset+)) + (:jmp 'fix-fix-ok) + )) + fix-fix-ok + ))))) + (do-it))) (3 (x y z) (with-inline-assembly (:returns :eax) (:compile-form (:result-mode :eax) x) @@ -153,7 +176,8 @@ (:orl :ebx :ecx) (:orl :edx :ecx) (:testb #.movitz::+movitz-fixnum-zmask+ :cl) - (:jnz 'not-integer) + (:jnz '(:sub-program (not-integer) + (:int 107))) (:addl :ebx :eax) (:into) (:addl :edx :eax) @@ -171,62 +195,34 @@ ;;; Subtraction -(define-compiler-macro - (&whole form &rest operands) +(define-compiler-macro - (&whole form &rest operands &environment env) (case (length operands) (0 0) - (1 `(-%2op 0 ,(first operands))) - (2 `(-%2op ,(first operands) ,(second operands))) - (t `(- (-%2op ,(first operands) ,(second operands)) - ,@(cddr operands))))) - - -(define-compiler-macro -%2op (&whole form minuend subtrahend) - (cond - ((and (movitz:movitz-constantp minuend) ; first operand zero? - (zerop (movitz:movitz-eval minuend))) - `(with-inline-assembly (:returns :register :side-effects nil) - (:compile-form (:result-mode :register) ,subtrahend) - (:negl (:result-register)) ; (- 0 x) => -x - (:into))) - ((and (movitz:movitz-constantp subtrahend) ; second operand zero? - (zerop (movitz:movitz-eval subtrahend))) - (movitz:movitz-eval minuend)) ; (- x 0) => x - ((and (movitz:movitz-constantp minuend) - (movitz:movitz-constantp subtrahend)) - (- (movitz:movitz-eval minuend) - (movitz:movitz-eval subtrahend))) ; compile-time constant folding. - ((movitz:movitz-constantp minuend) - (let ((constant-minuend (movitz:movitz-eval minuend))) - (check-type constant-minuend (signed-byte 30)) - `(with-inline-assembly (:returns :register :side-effects nil) ; inline - (:compile-form (:result-mode :register) ,subtrahend) - (:subl ,(* movitz::+movitz-fixnum-factor+ constant-minuend) (:result-register)) - ;;;;;;; NEED CHECKING HERE - (:into) - (:negl (:result-register))))) - ((movitz:movitz-constantp subtrahend) - (let ((constant-subtrahend (movitz:movitz-eval subtrahend))) - (check-type constant-subtrahend (signed-byte 30)) - `(+ ,minuend ,(- constant-subtrahend)))) - (t `(with-inline-assembly (:returns :eax :side-effects nil) - (:compile-two-forms (:eax :ebx) ,minuend ,subtrahend) - (:subl :ebx :eax) - (:into))))) - -(defun -%2op (minuend subtrahend) - (check-type minuend fixnum) - (check-type subtrahend fixnum) - (-%2op minuend subtrahend)) + (1 `(- 0 ,(first operands))) + (2 (let ((minuend (first operands)) + (subtrahend (second operands))) + (cond + ((movitz:movitz-constantp subtrahend env) + `(+ ,minuend ,(- (movitz:movitz-eval subtrahend env)))) + (t form)))) + (t `(- ,(first operands) (+ ,@(rest operands)))))) (defun - (minuend &rest subtrahends) (declare (dynamic-extent subtrahends)) - (if subtrahends - (reduce #'-%2op subtrahends :initial-value minuend) - (-%2op 0 minuend))) + (numargs-case + (2 (minuend subtrahend) + (check-type minuend fixnum) + (check-type subtrahend fixnum) + (with-inline-assembly (:returns :eax :side-effects nil) + (:compile-two-forms (:eax :ebx) minuend subtrahend) + (:subl :ebx :eax) + (:into))) + (t (minuend &rest subtrahends) + (declare (dynamic-extent subtrahends)) + (if subtrahends + (reduce #'- subtrahends :initial-value minuend) + (- 0 minuend))))) -;;;(defmacro decf (place &optional (delta-form 1)) -;;; `(setf ,place (- ,place ,delta-form))) - (define-modify-macro decf (&optional (delta-form 1)) -) ;;; Comparison @@ -775,13 +771,6 @@ (:idivl :ebx :eax :edx) (:shll #.movitz::+movitz-fixnum-shift+ :eax)))))) (t form))) - -(defmacro number-double-dispatch ((x y) &rest clauses) - `(let ((x ,x) (y ,y)) - (cond ,@(loop for ((x-type y-type) . then-body) in clauses - collect `((and (typep x ',x-type) (typep y ',y-type)) - ,@then-body)) - (t (error "Not numbers: ~S or ~S." x y))))) (defun truncate (number &optional (divisor 1)) (numargs-case

1 0