Changeset 8307

Timestamp:

12/28/04 02:10:52 (18 years ago)

Author:

piso

Message:

Work in progress (fixed MISC.510).

File:

• trunk/j/src/org/armedbear/lisp/jvm.lisp (modified) (12 diffs)

trunk/j/src/org/armedbear/lisp/jvm.lisp

@@ -2 +2 @@
 ;;;
 ;;; Copyright (C) 2003-2004 Peter Graves
-;;; $Id: jvm.lisp,v 1.323 2004-12-27 18:14:09 piso Exp $
+;;; $Id: jvm.lisp,v 1.324 2004-12-28 02:10:52 piso Exp $
 ;;;
 ;;; This program is free software; you can redistribute it and/or
@@ -155 +155 @@
 ;; returns variable or nil
 (defun unboxed-fixnum-variable (obj)
-  (cond ((symbolp obj)
-         (let ((variable (find-visible-variable obj)))
-           (if (and variable
-                    (eq (variable-representation variable) :unboxed-fixnum))
-               variable
-               nil)))
-        ((variable-p obj)
-         (if (eq (variable-representation obj) :unboxed-fixnum)
-             obj
-             nil))
-        (t
-         nil)))
+  (cond
+   ((symbolp obj)
+    (let ((variable (find-visible-variable obj)))
+      (if (and variable
+               (eq (variable-representation variable) :unboxed-fixnum))
+          variable
+          nil)))
+   ((variable-p obj)
+    (if (eq (variable-representation obj) :unboxed-fixnum)
+        obj
+        nil))
+   (t
+    nil)))
 
 (defun arg-is-fixnum-p (arg)
@@ -405 +406 @@
   (list 'SETQ (second form) (p1 (third form))))
 
-;; (defun p1-the (form)
-;; ;;   (dformat t "p1-the form = ~S~%" form)
-;; ;;   (if (= *safety* 3)
-;;       (list 'THE (second form) (p1 (third form)))
-;; ;;       (p1 (third form))
-;; ;;       )
-;; )
 (defun p1-the (form)
   (dformat t "p1-the form = ~S~%" form)
@@ -457 +451 @@
 (defun p1 (form)
   (cond
-;;    ((and (symbolp form) (constantp form)) ; a DEFCONSTANT
-;;     (let ((value (symbol-value form)))
-;;       (if (numberp value)
-;;           value
-;;           form)))
    ((symbolp form)
     (cond
@@ -528 +517 @@
 (install-p1-handler 'multiple-value-list  'p1-default)
 (install-p1-handler 'multiple-value-prog1 'p1-default)
-(install-p1-handler 'multiple-value-setq  'p1-lambda)
 (install-p1-handler 'progn                'p1-default)
 (install-p1-handler 'progv                'identity)
@@ -936 +924 @@
   (emit-move-from-stack target representation))
 
+(defun require-args (form n)
+  (declare (type fixnum n))
+  (unless (= (length form) (1+ n))
+    (error 'program-error
+           :format-control "Wrong number of arguments for ~A."
+           :format-arguments (list (car form)))))
+
 (defparameter *resolvers* (make-hash-table :test #'eql))
 
@@ -973 +968 @@
              97 ; LADD
              101 ; LSUB
+             116 ; INEG
+             121 ; LSHL
+             123 ; LSHR
              132 ; IINC
              133 ; I2L
@@ -2914 +2912 @@
 
 (defun compile-if (form &key (target *val*) representation)
-  (dformat t "compile-if form = ~S~%" form)
+;;   (dformat t "compile-if form = ~S~%" form)
   (let* ((test (second form))
          (consequent (third form))
@@ -3967 +3965 @@
            (error "COMPILE-FUNCTION: unsupported case: ~S" form)))))
 
-(defun compile-ash (form &key (target *val*) representation)
-  (let ((new-form (rewrite-function-call form)))
-    (when (neq new-form form)
-      (return-from compile-ash (compile-form new-form :target target))))
+(defun p2-ash (form &key (target *val*) representation)
+  (dformat t "p2-ash form = ~S~%" form)
+;;   (let ((new-form (rewrite-function-call form)))
+;;     (when (neq new-form form)
+;;       (return-from compile-ash (compile-form new-form :target target))))
+  (require-args form 2)
   (let* ((args (cdr form))
-         (len (length args)))
-    (when (= len 2)
-      (let ((first (first args))
-            (second (second args)))
-        (when (fixnump second)
-          (compile-form first :target :stack)
-          (maybe-emit-clear-values first)
-          (emit-push-constant-int second)
-          (emit-invokevirtual +lisp-object-class+
-                              "ash"
-                              "(I)Lorg/armedbear/lisp/LispObject;"
-                              -1)
-          (emit-move-from-stack target)
-          (return-from compile-ash t)))))
-  (compile-function-call form target representation))
+         (len (length args))
+         (first (first args))
+         (var (unboxed-fixnum-variable first))
+         (second (second args)))
+    (cond
+     ((and var (fixnump second) (< 0 second 32))
+      (dformat t "p2-ash case 1~%")
+      (emit-push-int var)
+      (emit 'i2l)
+      (emit-push-constant-int second)
+      (emit 'lshl)
+      (emit-box-long)
+      (emit-move-from-stack target))
+     ((and var (fixnump second) (< -32 second 0))
+      (dformat t "p2-ash case 2~%")
+      (emit-push-int var)
+      (emit 'i2l)
+      (emit-push-constant-int second)
+      (emit 'ineg)
+      (emit 'lshr)
+      (emit-box-long)
+      (emit-move-from-stack target))
+     ((fixnump second)
+      (dformat t "p2-ash case 3~%")
+      (compile-form first :target :stack)
+      (maybe-emit-clear-values first)
+      (emit-push-constant-int second)
+      (emit-invokevirtual +lisp-object-class+
+                          "ash"
+                          "(I)Lorg/armedbear/lisp/LispObject;"
+                          -1)
+      (emit-move-from-stack target))
+     (t
+      (dformat t "p2-ash case 4~%")
+      (compile-function-call form target representation)))))
 
 (defun compile-logand (form &key (target *val*) representation)
-  (let ((new-form (rewrite-function-call form)))
-    (when (neq new-form form)
-      (return-from compile-logand (compile-form new-form :target target))))
+;;   (let ((new-form (rewrite-function-call form)))
+;;     (when (neq new-form form)
+;;       (return-from compile-logand (compile-form new-form :target target))))
   (let* ((args (cdr form))
          (len (length args)))
@@ -4706 +4726 @@
                                        :representation representation))
                         ((special-operator-p op)
+                         (dformat t "form = ~S~%" form)
                          (error "COMPILE-FORM: unsupported special operator ~S" op))
                         (t
@@ -5175 +5196 @@
 
 (mapc #'install-p2-handler '(aref
-                             ash
                              atom
                              block
@@ -5213 +5233 @@
 (install-p2-handler '+      'compile-plus)
 (install-p2-handler '-      'compile-minus)
+(install-p2-handler 'ash    'p2-ash)
 (install-p2-handler 'eql    'p2-eql)
 (install-p2-handler 'not    'compile-not/null)