Changeset 8598


Ignore:
Timestamp:
02/17/05 18:38:44 (16 years ago)
Author:
piso
Message:

Work in progress (tested).

File:
1 edited

Legend:

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

    r8567 r8598  
    22;;;
    33;;; Copyright (C) 2003-2005 Peter Graves
    4 ;;; $Id: jvm.lisp,v 1.397 2005-02-14 04:06:11 piso Exp $
     4;;; $Id: jvm.lisp,v 1.398 2005-02-17 18:38:44 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    491491               (setf (block-non-local-return-p block) t))))
    492492          (t
    493            (setf (block-non-local-return-p block) t))))
     493           (setf (block-non-local-return-p block) t)))
     494    (when (block-non-local-return-p block)
     495      (dformat t "non-local return from block ~S~%" (block-name block))))
    494496  (list* 'RETURN-FROM (cadr form) (mapcar #'p1 (cddr form))))
    495497
     
    15241526              (let ((label (car (instruction-args instruction))))
    15251527                (walk-code code (symbol-value label) depth))))
    1526         (when (member opcode '(167 169 191)) ; GOTO RET ATHROW
     1528        (when (member opcode '(167 169 176 191)) ; GOTO RET ATHROW
    15271529          ;; Current path ends.
    15281530          (return-from walk-code))))))
     
    17711773               (setf (instruction-opcode instruction) 176
    17721774                     (instruction-args instruction) nil
    1773                      changed t)))))))
     1775                     changed t))
     1776              )))))
    17741777    (when changed
    17751778      (setf *code* (delete nil code))
     
    27532756      (unless (> *speed* *debug*)
    27542757        (emit-push-current-thread))
    2755       (cond ((inline-ok op)
    2756              (if (eq op (compiland-name *current-compiland*)) ; recursive call
    2757                  (emit 'aload 0) ; this
    2758                  (emit 'getstatic *this-class* (declare-function op) +lisp-object+)))
     2758      (cond ((eq op (compiland-name *current-compiland*)) ; recursive call
     2759             (if (notinline-p op)
     2760                 (emit 'getstatic *this-class* (declare-symbol op) +lisp-symbol+)
     2761                 (emit 'aload 0)))
     2762            ((inline-ok op)
     2763             (emit 'getstatic *this-class* (declare-function op) +lisp-object+))
    27592764            ((null (symbol-package op))
    27602765             (let ((g (if *compile-file-truename*
     
    33263331    ;; If we're going to bind any special variables...
    33273332    (when bind-special-p
     3333      (dformat t "p2-m-v-b-node lastSpecialBinding~%")
    33283334      ;; Save current dynamic environment.
    33293335      (setf (block-environment-register block) (allocate-register))
     
    34063412    ;; If so...
    34073413    (when specialp
     3414      (dformat t "p2-let/let*-node lastSpecialBinding~%")
    34083415      ;; Save current dynamic environment.
    34093416      (setf (block-environment-register block) (allocate-register))
     
    35903597          (push tag *visible-tags*))))
    35913598    (when (block-non-local-go-p block)
     3599      (dformat t "p2-tagbody-node lastSpecialBinding~%")
    35923600      (setf environment-register (allocate-register))
    35933601      (emit-push-current-thread)
     
    37313739    (setf (block-target block) target)
    37323740    (when (block-return-p block)
    3733       ;; Save current dynamic environment.
    3734       (setf (block-environment-register block) (allocate-register))
    3735       (emit-push-current-thread)
    3736       (emit 'getfield +lisp-thread-class+ "lastSpecialBinding" +lisp-binding+)
    3737       (emit 'astore (block-environment-register block)))
     3741      (dformat t "p2-block-node lastSpecialBinding~%")
     3742      (dformat t "*all-variables* = ~S~%" (mapcar #'variable-name *all-variables*))
     3743      (cond ((some #'variable-special-p *all-variables*)
     3744;;              Save current dynamic environment.
     3745             (setf (block-environment-register block) (allocate-register))
     3746             (emit-push-current-thread)
     3747             (emit 'getfield +lisp-thread-class+ "lastSpecialBinding" +lisp-binding+)
     3748             (emit 'astore (block-environment-register block)))
     3749            (t
     3750             (dformat t "no specials~%"))))
    37383751    (setf (block-catch-tag block) (gensym))
    37393752    (let* ((*register* *register*)
Note: See TracChangeset for help on using the changeset viewer.