Changeset 8451


Ignore:
Timestamp:
02/02/05 21:42:04 (17 years ago)
Author:
piso
Message:

Work in progress (tested).

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/j/src/org/armedbear/lisp/jvm.lisp

    r8448 r8451  
    22;;;
    33;;; Copyright (C) 2003-2005 Peter Graves
    4 ;;; $Id: jvm.lisp,v 1.384 2005-02-02 16:47:14 piso Exp $
     4;;; $Id: jvm.lisp,v 1.385 2005-02-02 21:42:04 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    15991599                  (emit-move-from-stack target))
    16001600                 ((variable-special-p variable)
    1601                   (dformat t "soecial~%")
     1601                  (dformat t "special~%")
    16021602                  (compile-special-reference (variable-name variable) target nil))
    16031603                 ((variable-closure-index variable)
     
    23532353(define-unary-operator 'SYMBOLP         "SYMBOLP")
    23542354(define-unary-operator 'VECTORP         "VECTORP")
    2355 (define-unary-operator 'ZEROP           "ZEROP")
     2355;; (define-unary-operator 'ZEROP           "ZEROP")
    23562356
    23572357(defun compile-function-call-1 (op args target representation)
     
    28842884    (when (memq op '(NOT NULL))
    28852885      (return-from compile-test-2 (compile-test arg (not negatep))))
    2886     (when (setf variable (unboxed-fixnum-variable arg))
     2886;;     (when (setf variable (unboxed-fixnum-variable arg))
     2887;;       (case op
     2888;;         (MINUSP
     2889;;          (dformat t "compile-test-2 minusp case~%")
     2890;;          (aver (variable-register variable))
     2891;;          (emit 'iload (variable-register variable))
     2892;;          (return-from compile-test-2 (if negatep 'iflt 'ifge)))))
     2893    (when (subtypep (derive-type arg) 'FIXNUM)
    28872894      (case op
    28882895        (MINUSP
    28892896         (dformat t "compile-test-2 minusp case~%")
    2890          (aver (variable-register variable))
    2891          (emit 'iload (variable-register variable))
    2892          (return-from compile-test-2 (if negatep 'iflt 'ifge)))))
     2897         (compile-form arg :target :stack :representation :unboxed-fixnum)
     2898         (return-from compile-test-2 (if negatep 'iflt 'ifge)))
     2899        (ZEROP
     2900         (dformat t "compile-test-2 zerop case~%")
     2901         (compile-form arg :target :stack :representation :unboxed-fixnum)
     2902         (return-from compile-test-2 (if negatep 'ifeq 'ifne)))))
    28932903    (when (eq op 'SYMBOLP)
    28942904      (process-args args)
     
    31093119          (t
    31103120           (emit (compile-test test nil) LABEL1)
    3111            (compile-form consequent :target target)
     3121           (compile-form consequent :target target :representation representation)
    31123122           (emit 'goto LABEL2)
    31133123           (label LABEL1)
    3114            (compile-form alternate :target target)
     3124           (compile-form alternate :target target :representation representation)
    31153125           (label LABEL2)))))
    31163126
     
    41264136  (compile-function-call form target representation))
    41274137
     4138(defun p2-zerop (form &key (target :stack) representation)
     4139  (unless (check-arg-count form 1)
     4140    (compile-function-call form target representation)
     4141    (return-from p2-zerop))
     4142  (let* ((arg (cadr form))
     4143         (var (unboxed-fixnum-variable arg)))
     4144    (cond ((subtypep (derive-type arg) 'FIXNUM)
     4145           (compile-form arg :target :stack :representation :unboxed-fixnum)
     4146           (let ((LABEL1 (gensym))
     4147                 (LABEL2 (gensym)))
     4148             (emit 'ifne LABEL1)
     4149             (emit-push-t)
     4150             (emit 'goto LABEL2)
     4151             (label LABEL1)
     4152             (emit-push-nil)
     4153             (label LABEL2)
     4154             (emit-move-from-stack target)))
     4155          (t
     4156           (compile-form arg :target :stack)
     4157           (maybe-emit-clear-values arg)
     4158           (emit-invoke-method "ZEROP" target representation)))))
     4159
    41284160(defun derive-type (form)
    41294161  (cond ((fixnump form)
     
    41494181  t)
    41504182
    4151 (defun compile-length (form &key (target :stack) representation)
    4152   (check-arg-count form 1)
     4183(defun p2-length (form &key (target :stack) representation)
     4184  (unless (check-arg-count form 1)
     4185    (compile-function-call form target representation)
     4186    (return-from p2-length))
    41534187  (let ((arg (cadr form)))
    41544188    (compile-form arg :target :stack)
     
    44624496      (1
    44634497       (let ((arg (first args)))
    4464          (compile-form arg :target target)
     4498         (compile-form arg :target target :representation representation)
    44654499         (unless (single-valued-p arg)
    44664500           (emit-clear-values))))
     
    46154649(defun p2-the (form &key (target :stack) representation)
    46164650;;   (compile-form (third form) :target target :representation representation)
     4651  (dformat t "p2-the ~S ~S ~S~%" form target representation)
    46174652  (cond ((subtypep (second form) 'FIXNUM)
     4653         (dformat t "p2-the fixnum case~%")
    46184654         (unless (eq representation :unboxed-fixnum)
    46194655           (emit 'new +lisp-fixnum-class+)
     
    48364872                (p2-unwind-protect-node form target))
    48374873               (t
    4838                 (p2-block-node form target))))
     4874                (p2-block-node form target)))
     4875         (when (eq representation :unboxed-fixnum)
     4876           (emit-unbox-fixnum)))
    48394877        ((constantp form)
    48404878         (compile-constant form :target target :representation representation))
     
    51645202    (let ((specials (process-special-declarations body)))
    51655203      (dolist (name specials)
     5204        (dformat t "recognizing ~S as special~%" name)
    51665205        (let ((variable (find-visible-variable name)))
    51675206          (cond ((null variable)
     
    55975636                             funcall
    55985637                             if
    5599                              length
    56005638                             locally
    56015639                             multiple-value-call
     
    56265664(install-p2-handler 'function       'p2-function)
    56275665(install-p2-handler 'labels         'p2-labels)
     5666(install-p2-handler 'length         'p2-length)
    56285667(install-p2-handler 'logand         'p2-logand)
    56295668(install-p2-handler 'not            'p2-not/null)
     
    56335672(install-p2-handler 'schar          'p2-schar)
    56345673(install-p2-handler 'the            'p2-the)
     5674(install-p2-handler 'zerop          'p2-zerop)
    56355675
    56365676(install-p2-handler '%call-internal 'p2-%call-internal)
Note: See TracChangeset for help on using the changeset viewer.