Changeset 8320


Ignore:
Timestamp:
01/01/05 16:38: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

    r8319 r8320  
    22;;;
    33;;; Copyright (C) 2003-2004 Peter Graves
    4 ;;; $Id: jvm.lisp,v 1.334 2005-01-01 06:07:58 piso Exp $
     4;;; $Id: jvm.lisp,v 1.335 2005-01-01 16:38:03 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    333333        (when (special-variable-p (variable-name variable))
    334334          (setf (variable-special-p variable) t)))
     335      ;; Process declarations.
     336      (dolist (subform body)
     337        (unless (and (consp subform) (eq (car subform) 'DECLARE))
     338          (return))
     339        (let ((decls (cdr subform)))
     340          (dolist (decl decls)
     341            (case (car decl)
     342              (SPECIAL
     343               (dolist (sym (cdr decl))
     344                 (dolist (variable vars)
     345                   (when (eq sym (variable-name variable))
     346                     (setf (variable-special-p variable) t)))))
     347              (TYPE
     348               (dolist (sym (cddr decl))
     349                 (dolist (variable vars)
     350                   (when (eq sym (variable-name variable))
     351                     (setf (variable-declared-type variable) (cadr decl))))))))))
    335352      (setf (block-vars block) vars))
    336353    (setf body (mapcar #'p1 body))
    337354    (setf (block-form block) (list* op varlist body))
    338     ;; Process declarations.
    339     (dolist (subform body)
    340       (unless (and (consp subform) (eq (car subform) 'DECLARE))
    341         (return))
    342       (let ((decls (cdr subform)))
    343         (dolist (decl decls)
    344           (case (car decl)
    345             (SPECIAL
    346              (dolist (sym (cdr decl))
    347                (dolist (variable (block-vars block))
    348                  (when (eq sym (variable-name variable))
    349                    (setf (variable-special-p variable) t)))))
    350             (TYPE
    351              (dolist (sym (cddr decl))
    352                (dolist (variable (block-vars block))
    353                  (when (eq sym (variable-name variable))
    354                    (setf (variable-declared-type variable) (cadr decl))))))))))
    355355    block))
    356356
    357 (defun p1-multiple-value-bind (form)
     357(defun p1-m-v-b (form)
    358358;;   (dformat t "p1-multiple-value-bind~%")
    359359  (let* ((*visible-variables* *visible-variables*)
     
    374374          (push var vars)
    375375          (push var *visible-variables*)))
     376      ;; Check for globally declared specials.
     377      (dolist (variable vars)
     378        (when (special-variable-p (variable-name variable))
     379          (setf (variable-special-p variable) t)))
    376380      ;; Process declarations.
    377381      (dolist (subform body)
     
    390394                 (dolist (variable vars)
    391395                   (when (eq sym (variable-name variable))
    392                      (setf (variable-declared-type variable) (cadr decl)))))))))))
     396                     (setf (variable-declared-type variable) (cadr decl))))))))))
     397      (setf (block-vars block) (nreverse vars)))
    393398    (setf body (mapcar #'p1 body))
    394399    (setf (block-form block) (list* 'MULTIPLE-VALUE-BIND varlist values-form body))
     
    607612(install-p1-handler 'load-time-value      'identity)
    608613(install-p1-handler 'locally              'p1-default)
    609 (install-p1-handler 'multiple-value-bind  'p1-multiple-value-bind)
     614(install-p1-handler 'multiple-value-bind  'p1-m-v-b)
    610615(install-p1-handler 'multiple-value-call  'p1-default)
    611616(install-p1-handler 'multiple-value-list  'p1-default)
     
    31623167         (aver nil))))
    31633168
    3164 ;; (defun compile-multiple-value-bind (form &key (target *val*) representation)
    3165 (defun compile-multiple-value-bind-node (block target)
    3166   (let* (;;(block (make-block-node :name '(MULTIPLE-VALUE-BIND)))
    3167          (*blocks* (cons block *blocks*))
     3169(defun p2-m-v-b-node (block target)
     3170  (let* ((*blocks* (cons block *blocks*))
    31683171         (*register* *register*)
    31693172         (form (block-form block))
     
    31723175         (vars (second form))
    31733176         (bind-special-p nil)
    3174          (variables ()))
     3177         (variables (block-vars block)))
    31753178    ;; Process declarations.
    3176     (dolist (f (cdddr form))
    3177       (unless (and (consp f) (eq (car f) 'declare))
    3178         (return))
    3179       (let ((decls (cdr f)))
    3180         (dolist (decl decls)
    3181           (when (eq (car decl) 'special)
    3182             (setf specials (append (cdr decl) specials))))))
     3179;;     (dolist (f (cdddr form))
     3180;;       (unless (and (consp f) (eq (car f) 'declare))
     3181;;         (return))
     3182;;       (let ((decls (cdr f)))
     3183;;         (dolist (decl decls)
     3184;;           (when (eq (car decl) 'special)
     3185;;             (setf specials (append (cdr decl) specials))))))
    31833186    ;; Process variables and allocate registers for them.
    3184     (dolist (var vars)
    3185       (let* ((special-p (if (or (memq var specials) (special-variable-p var)) t nil))
    3186              (variable
    3187               (make-variable :name var
    3188                              :special-p special-p
    3189                              :index (if special-p nil (length (context-vars *context*)))
    3190                              :register (if (or special-p *use-locals-vector*) nil (allocate-register)))))
    3191         (if special-p
    3192             (setf bind-special-p t)
    3193             (add-variable-to-context variable))
    3194         (push variable variables)))
    3195     (setf variables (nreverse variables))
     3187;;     (dolist (var vars)
     3188;;       (let* ((special-p (if (or (memq var specials) (special-variable-p var)) t nil))
     3189;;              (variable
     3190;;               (make-variable :name var
     3191;;                              :special-p special-p
     3192;;                              :index (if special-p nil (length (context-vars *context*)))
     3193;;                              :register (if (or special-p *use-locals-vector*) nil (allocate-register)))))
     3194;;         (if special-p
     3195;;             (setf bind-special-p t)
     3196;;             (add-variable-to-context variable))
     3197;;         (push variable variables)))
     3198;;     (setf variables (nreverse variables))
     3199    (dolist (variable variables)
     3200      (let ((special-p (variable-special-p variable)))
     3201        (cond (special-p
     3202               (setf bind-special-p t))
     3203              (t
     3204               (setf (variable-index variable) (length (context-vars *context*)))
     3205               (unless *use-locals-vector*
     3206                 (setf (variable-register variable) (allocate-register)))
     3207               (add-variable-to-context variable)))))
    31963208    ;; If we're going to bind any special variables...
    31973209    (when bind-special-p
     
    32693281      (emit 'putfield +lisp-thread-class+ "lastSpecialBinding" +lisp-binding+))))
    32703282
    3271 (defun compile-let/let*-node (block target)
     3283(defun p2-let/let*-node (block target)
    32723284  (let* ((*blocks* (cons block *blocks*))
    32733285         (*register* *register*)
     
    32903302    (ecase (car form)
    32913303      (LET
    3292        (compile-let-bindings block))
     3304       (p2-let-bindings block))
    32933305      (LET*
    32943306       (compile-let*-bindings block)))
     
    33013313      (emit 'putfield +lisp-thread-class+ "lastSpecialBinding" +lisp-binding+))))
    33023314
    3303 (defun compile-let-bindings (block)
     3315(defun p2-let-bindings (block)
    33043316  (dolist (variable (block-vars block))
    33053317    (unless (variable-special-p variable)
     
    33253337                      (variable-declared-type variable)
    33263338                      (subtypep (variable-declared-type variable) 'FIXNUM))
    3327                  (dformat t "compile-let-bindings declared fixnum case: ~S~%"
     3339                 (dformat t "p2-let-bindings declared fixnum case: ~S~%"
    33283340                          (variable-name variable))
    33293341                 (setf (variable-representation variable) :unboxed-fixnum)
     
    33323344                      (eql (variable-writes variable) 0)
    33333345                      (subtypep (derive-type initform) 'FIXNUM))
    3334                  (dformat t "compile-let-bindings read-only fixnum case: ~S~%"
     3346                 (dformat t "p2-let-bindings read-only fixnum case: ~S~%"
    33353347                          (variable-name variable))
    33363348                 (setf (variable-representation variable) :unboxed-fixnum)
     
    49764988                (compile-tagbody-node form target))
    49774989               ((equal (block-name form) '(LET))
    4978                 (compile-let/let*-node form target))
     4990                (p2-let/let*-node form target))
    49794991               ((equal (block-name form) '(MULTIPLE-VALUE-BIND))
    4980                 (compile-multiple-value-bind-node form target))
     4992                (p2-m-v-b-node form target))
    49814993               (t
    49824994                (compile-block-node form target))))
Note: See TracChangeset for help on using the changeset viewer.