Changeset 8321


Ignore:
Timestamp:
01/01/05 18:31:03 (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

    r8320 r8321  
    22;;;
    33;;; Copyright (C) 2003-2004 Peter Graves
    4 ;;; $Id: jvm.lisp,v 1.335 2005-01-01 16:38:03 piso Exp $
     4;;; $Id: jvm.lisp,v 1.336 2005-01-01 18:31:03 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    7474  name
    7575  lambda-expression
     76  arg-vars
     77  p1-result
    7678  classfile
    7779  parent
     
    365367    ;; Process the values-form first. ("The scopes of the name binding and
    366368    ;; declarations do not include the values-form.")
    367 ;;     (setf values-form (if (consp values-form)
    368 ;;                           (mapcar #'p1 values-form)
    369 ;;                           (p1 values-form)))
    370369    (setf values-form (p1 values-form))
    371370    (let ((vars ()))
     
    34683467      (return tag))))
    34693468
    3470 (defun compile-tagbody-node (block target)
     3469(defun p2-tagbody-node (block target)
    34713470  (let* ((*blocks* (cons block *blocks*))
    34723471         (*visible-tags* *visible-tags*)
     
    35603559    (label EXIT)
    35613560    (when must-clear-values
    3562 ;;       (dformat t "compile-tagbody-node calling emit-clear-values~%")
     3561;;       (dformat t "p2-tagbody-node calling emit-clear-values~%")
    35633562      (emit-clear-values))
    35643563    ;; TAGBODY returns NIL.
     
    49864985        ((block-node-p form)
    49874986         (cond ((equal (block-name form) '(TAGBODY))
    4988                 (compile-tagbody-node form target))
     4987                (p2-tagbody-node form target))
    49894988               ((equal (block-name form) '(LET))
    49904989                (p2-let/let*-node form target))
     
    50675066      (write-u2 0 stream))))
    50685067
    5069 (defun compile-1 (compiland)
    5070   (dformat t "compile-1 ~S~%" (compiland-name compiland))
    5071   (let ((*current-compiland* compiland)
    5072         (precompiled-form (compiland-lambda-expression compiland))
    5073         (classfile (compiland-classfile compiland))
    5074         (*speed* *speed*)
    5075         (*safety* *safety*)
    5076         (*debug* *debug*)
    5077         )
    5078     (process-optimization-declarations (cddr precompiled-form))
    5079     ;; Pass 1.
    5080     (let ((*visible-variables* *visible-variables*))
    5081       (setf precompiled-form (p1 precompiled-form)))
    5082     ;; Pass 2.
    5083     (let* ((*declared-symbols* (make-hash-table :test 'eq))
    5084            (*declared-functions* (make-hash-table :test 'equal))
    5085            (*declared-strings* (make-hash-table :test 'eq))
    5086            (*declared-fixnums* (make-hash-table :test 'eql))
    5087            (class-name
    5088             (let* ((pathname (pathname classfile))
    5089                    (name (pathname-name classfile)))
    5090               (dotimes (i (length name))
    5091                 (when (eql (char name i) #\-)
    5092                   (setf (char name i) #\_)))
    5093               name))
    5094            (*this-class*
    5095             (concatenate 'string "org/armedbear/lisp/" class-name))
    5096            (args (cadr precompiled-form))
    5097            (body (cddr precompiled-form))
    5098            (*using-arg-array* nil)
    5099            (*hairy-arglist-p* nil)
    5100            (*arity* nil)
    5101 
    5102            (*child-p* (not (null (compiland-parent compiland))))
    5103 
    5104            (*use-locals-vector* (or (> (compiland-children *current-compiland*) 0)
    5105                                     (compiland-contains-lambda *current-compiland*)))
    5106 
    5107            (descriptor (analyze-args args))
    5108            (execute-method (make-method :name "execute"
    5109                                         :descriptor descriptor))
    5110            (*code* ())
    5111            (*static-code* ())
    5112            (*fields* ())
    5113            (*register* 0)
    5114            (*registers-allocated* 0)
    5115            (*handlers* ())
    5116 
    5117            (*context* *context*)
    5118 
    5119            (*context-register* *context-register*)
    5120 
    5121            (*visible-variables* *visible-variables*)
    5122            (*all-variables* *all-variables*)
    5123            (*undefined-variables* *undefined-variables*)
    5124 
    5125            (parameters ())
    5126 
    5127            (*pool* ())
    5128            (*pool-count* 1)
    5129            (*pool-entries* (make-hash-table :test #'equal))
    5130            (*val* nil)
    5131            (*thread* nil)
    5132            (*initialize-thread-var* nil))
     5068(defun p2-compiland (compiland)
     5069  (let* ((p1-result (compiland-p1-result compiland))
     5070         (*declared-symbols* (make-hash-table :test 'eq))
     5071         (*declared-functions* (make-hash-table :test 'equal))
     5072         (*declared-strings* (make-hash-table :test 'eq))
     5073         (*declared-fixnums* (make-hash-table :test 'eql))
     5074         (classfile (compiland-classfile compiland))
     5075         (class-name
     5076          (let* ((pathname (pathname classfile))
     5077                 (name (pathname-name classfile)))
     5078            (dotimes (i (length name))
     5079              (when (eql (char name i) #\-)
     5080                (setf (char name i) #\_)))
     5081            name))
     5082         (*this-class*
     5083          (concatenate 'string "org/armedbear/lisp/" class-name))
     5084         (args (cadr p1-result))
     5085         (body (cddr p1-result))
     5086         (*using-arg-array* nil)
     5087         (*hairy-arglist-p* nil)
     5088         (*arity* nil)
     5089
     5090         (*child-p* (not (null (compiland-parent compiland))))
     5091
     5092         (*use-locals-vector* (or (> (compiland-children *current-compiland*) 0)
     5093                                  (compiland-contains-lambda *current-compiland*)))
     5094
     5095         (descriptor (analyze-args args))
     5096         (execute-method (make-method :name "execute"
     5097                                      :descriptor descriptor))
     5098         (*code* ())
     5099         (*static-code* ())
     5100         (*fields* ())
     5101         (*register* 0)
     5102         (*registers-allocated* 0)
     5103         (*handlers* ())
     5104
     5105         (*context* *context*)
     5106
     5107         (*context-register* *context-register*)
     5108
     5109         (*visible-variables* *visible-variables*)
     5110         (*all-variables* *all-variables*)
     5111         (*undefined-variables* *undefined-variables*)
     5112
     5113         (parameters ())
     5114
     5115         (*pool* ())
     5116         (*pool-count* 1)
     5117         (*pool-entries* (make-hash-table :test #'equal))
     5118         (*val* nil)
     5119         (*thread* nil)
     5120         (*initialize-thread-var* nil))
     5121
     5122      (setf *visible-variables*
     5123            (append *visible-variables* (compiland-arg-vars compiland)))
     5124
     5125      (dformat t "pass2 *visible-variables* = ~S~%"
     5126               (mapcar #'variable-name *visible-variables*))
    51335127
    51345128      (when (zerop *nesting-level*)
     
    51405134            (pool-name (method-descriptor execute-method)))
    51415135      (cond (*hairy-arglist-p*
    5142              (let* ((closure (sys::make-closure precompiled-form nil))
     5136             (let* ((closure (sys::make-closure p1-result nil))
    51435137                    (vars (sys::varlist closure))
    51445138                    (index 0))
    51455139               (dolist (var vars)
    51465140                 (let ((variable (make-variable :name var
    5147 ;;                                                 :kind 'ARG
    51485141                                                :special-p nil ;; FIXME
    51495142                                                :register nil
     
    53115304      (setf (method-handlers execute-method) (nreverse *handlers*))
    53125305      (write-class-file args body execute-method classfile)
    5313       classfile)))
     5306      classfile))
     5307
     5308(defun compile-1 (compiland)
     5309  (dformat t "compile-1 ~S~%" (compiland-name compiland))
     5310  (let ((*current-compiland* compiland)
     5311        (precompiled-form (compiland-lambda-expression compiland))
     5312        (*speed* *speed*)
     5313        (*safety* *safety*)
     5314        (*debug* *debug*))
     5315    (process-optimization-declarations (cddr precompiled-form))
     5316    (aver (eq (car precompiled-form) 'LAMBDA))
     5317    (let ((lambda-list (cadr precompiled-form))
     5318          syms vars)
     5319      (multiple-value-bind (required optional restp rest keyp keys allowp auxp aux)
     5320          (sys::parse-lambda-list lambda-list)
     5321        (setf syms required)
     5322        (when optional
     5323          (setf syms (append syms optional)))
     5324        (when restp
     5325          (setf syms (append syms (list rest))))
     5326        (when keyp
     5327          (setf syms (append syms keys)))
     5328        (dformat t "syms = ~S~%" syms))
     5329      (dolist (sym syms)
     5330        (push (make-variable :name sym) vars))
     5331      (setf (compiland-arg-vars compiland) (nreverse vars)))
     5332    ;; Pass 1.
     5333    (let ((*visible-variables* *visible-variables*))
     5334      (setf *visible-variables*
     5335            (append *visible-variables* (compiland-arg-vars compiland)))
     5336      (setf (compiland-p1-result compiland) (p1 precompiled-form)))
     5337    ;; Pass 2.
     5338    (p2-compiland compiland)))
    53145339
    53155340(defun compile-defun (name form environment &optional (classfile "out.class"))
Note: See TracChangeset for help on using the changeset viewer.