Changeset 8368


Ignore:
Timestamp:
01/17/05 16:34:39 (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

    r8367 r8368  
    22;;;
    33;;; Copyright (C) 2003-2005 Peter Graves
    4 ;;; $Id: jvm.lisp,v 1.354 2005-01-17 04:50:38 piso Exp $
     4;;; $Id: jvm.lisp,v 1.355 2005-01-17 16:34:39 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    249249  free-specials
    250250  )
     251
     252(defun node-constant-p (object)
     253  (cond ((block-node-p object)
     254         nil)
     255        ((constantp object)
     256         t)
     257        (t
     258         nil)))
    251259
    252260(defvar *blocks* ())
     
    38143822      (emit 'putfield +lisp-thread-class+ "lastSpecialBinding" +lisp-binding+))))
    38153823
    3816 (defun compile-return-from (form &key (target *val*) representation)
     3824(defun p2-return-from (form &key (target *val*) representation)
    38173825  (let* ((name (second form))
    38183826         (result-form (third form))
     
    38323840        (when protected
    38333841          (error "COMPILE-RETURN-FROM: enclosing UNWIND-PROTECT")))
    3834 
    3835       ;; Added Dec 9 2004 7:28 AM
    3836 ;;       (dformat t "compile-return-from calling emit-clear-values~%")
    38373842      (emit-clear-values)
    3838 
    38393843      (compile-form result-form :target (block-target block))
    38403844      (emit 'goto (block-exit block)))
     
    38423846      ;; Non-local RETURN.
    38433847      (setf (block-non-local-return-p block) t)
    3844       (let* ((*register* *register*)
    3845              (temp-register (allocate-register)))
    3846 
    3847         (emit-clear-values)
    3848         (compile-form (third form) :target temp-register) ; Result.
    3849 
    3850         (emit 'new +lisp-return-class+)
    3851         (emit 'dup)
    3852         (compile-form `',(block-catch-tag block) :target :stack) ; Tag.
    3853 
    3854 ;        (emit-clear-values)
    3855 
    3856 ;;         (compile-form (third form) :target :stack) ; Result.
    3857         (emit 'aload temp-register)
    3858 
    3859         (emit-invokespecial +lisp-return-class+
    3860                             "<init>"
    3861                             "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)V"
    3862                             -3)
    3863         (emit 'athrow)
    3864         ;; Following code will not be reached, but is needed for JVM stack
    3865         ;; consistency.
    3866         (when target
    3867           (emit-push-nil)
    3868           (emit-move-from-stack target)))))))
     3848      (cond ((node-constant-p result-form)
     3849             (emit 'new +lisp-return-class+)
     3850             (emit 'dup)
     3851             (compile-form `',(block-catch-tag block) :target :stack) ; Tag.
     3852             (emit-clear-values)
     3853             (compile-form result-form :target :stack)) ; Result.
     3854            (t
     3855             (let* ((*register* *register*)
     3856                    (temp-register (allocate-register)))
     3857               (emit-clear-values)
     3858               (compile-form result-form :target temp-register) ; Result.
     3859               (emit 'new +lisp-return-class+)
     3860               (emit 'dup)
     3861               (compile-form `',(block-catch-tag block) :target :stack) ; Tag.
     3862               (emit 'aload temp-register))))
     3863      (emit-invokespecial +lisp-return-class+
     3864                          "<init>"
     3865                          "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)V"
     3866                          -3)
     3867      (emit 'athrow)
     3868      ;; Following code will not be reached, but is needed for JVM stack
     3869      ;; consistency.
     3870      (when target
     3871        (emit-push-nil)
     3872        (emit-move-from-stack target))))))
    38693873
    38703874(defun compile-cons (form &key (target *val*) representation)
     
    57485752                             progn
    57495753                             quote
    5750                              return-from
    57515754                             rplacd
    57525755                             schar
     
    57565759                             values))
    57575760
    5758 (install-p2-handler '<      'p2-numeric-comparison)
    5759 (install-p2-handler '<=     'p2-numeric-comparison)
    5760 (install-p2-handler '>      'p2-numeric-comparison)
    5761 (install-p2-handler '>=     'p2-numeric-comparison)
    5762 (install-p2-handler '=      'p2-numeric-comparison)
    5763 (install-p2-handler '/=     'p2-numeric-comparison)
    5764 (install-p2-handler '+      'compile-plus)
    5765 (install-p2-handler '-      'compile-minus)
    5766 (install-p2-handler 'ash    'p2-ash)
    5767 (install-p2-handler 'eql    'p2-eql)
    5768 (install-p2-handler 'flet   'p2-flet)
    5769 (install-p2-handler 'function   'p2-function)
    5770 (install-p2-handler 'labels 'p2-labels)
    5771 (install-p2-handler 'logand 'p2-logand)
    5772 (install-p2-handler 'not    'compile-not/null)
    5773 (install-p2-handler 'null   'compile-not/null)
    5774 (install-p2-handler 'the    'p2-the)
     5761(install-p2-handler '<           'p2-numeric-comparison)
     5762(install-p2-handler '<=          'p2-numeric-comparison)
     5763(install-p2-handler '>           'p2-numeric-comparison)
     5764(install-p2-handler '>=          'p2-numeric-comparison)
     5765(install-p2-handler '=           'p2-numeric-comparison)
     5766(install-p2-handler '/=          'p2-numeric-comparison)
     5767(install-p2-handler '+           'compile-plus)
     5768(install-p2-handler '-           'compile-minus)
     5769(install-p2-handler 'ash         'p2-ash)
     5770(install-p2-handler 'eql         'p2-eql)
     5771(install-p2-handler 'flet        'p2-flet)
     5772(install-p2-handler 'function    'p2-function)
     5773(install-p2-handler 'labels      'p2-labels)
     5774(install-p2-handler 'logand      'p2-logand)
     5775(install-p2-handler 'not         'compile-not/null)
     5776(install-p2-handler 'null        'compile-not/null)
     5777(install-p2-handler 'return-from 'p2-return-from)
     5778(install-p2-handler 'the         'p2-the)
    57755779
    57765780(defun process-optimization-declarations (forms)
Note: See TracChangeset for help on using the changeset viewer.