Changeset 8465


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

Work in progress.

File:
1 edited

Legend:

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

    r8459 r8465  
    22;;;
    33;;; Copyright (C) 2003-2005 Peter Graves
    4 ;;; $Id: jvm.lisp,v 1.390 2005-02-04 04:26:34 piso Exp $
     4;;; $Id: jvm.lisp,v 1.391 2005-02-05 16:38:40 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    336336;;; Pass 1.
    337337
     338;; Returns a list of declared free specials, if any are found.
     339(defun process-declarations-for-vars (body vars)
     340  (let ((free-specials '()))
     341    (dolist (subform body)
     342      (unless (and (consp subform) (eq (car subform) 'DECLARE))
     343        (return))
     344      (let ((decls (cdr subform)))
     345        (dolist (decl decls)
     346          (case (car decl)
     347            ((DYNAMIC-EXTENT FTYPE IGNORE IGNORABLE INLINE NOTINLINE OPTIMIZE)
     348             ;; Nothing to do here.
     349             )
     350            (SPECIAL
     351             (dolist (sym (cdr decl))
     352               (let ((variable (find sym vars :key #'variable-name)))
     353                 (cond (variable
     354                        (setf (variable-special-p variable) t))
     355                       (t
     356                        (dformat t "adding free special ~S~%" sym)
     357                        (push (make-variable :name sym :special-p t) free-specials))))))
     358            (TYPE
     359             (dolist (sym (cddr decl))
     360               (dolist (variable vars)
     361                 (when (eq sym (variable-name variable))
     362                   (setf (variable-declared-type variable) (cadr decl))))))
     363            (t
     364             (dolist (sym (cdr decl))
     365               (dolist (variable vars)
     366                 (when (eq sym (variable-name variable))
     367                   (setf (variable-declared-type variable) (car decl))))))))))
     368    free-specials))
     369
    338370(defun p1-let-vars (varlist)
    339371  (let ((vars ()))
     
    383415            (eq (car varspec) (cadr varspec))
    384416            (return nil))))
    385     (let ((vars (if (eq op 'LET) (p1-let-vars varlist) (p1-let*-vars varlist)))
    386           (free-specials '()))
     417    (let ((vars (if (eq op 'LET) (p1-let-vars varlist) (p1-let*-vars varlist))))
    387418      (dformat t "p1-let/let* vars = ~S~%" (mapcar #'variable-name vars))
    388419      ;; Check for globally declared specials.
     
    390421        (when (special-variable-p (variable-name variable))
    391422          (setf (variable-special-p variable) t)))
    392       ;; Process declarations.
    393       (dolist (subform body)
    394         (unless (and (consp subform) (eq (car subform) 'DECLARE))
    395           (return))
    396         (let ((decls (cdr subform)))
    397           (dolist (decl decls)
    398             (case (car decl)
    399               (SPECIAL
    400                (dolist (sym (cdr decl))
    401 ;;                  (dolist (variable vars)
    402 ;;                    (when (eq sym (variable-name variable))
    403 ;;                      (setf (variable-special-p variable) t)))
    404                  (let ((variable (find sym vars :key #'variable-name)))
    405                    (cond (variable
    406                           (setf (variable-special-p variable) t))
    407                          (t
    408                           (dformat t "adding free special ~S~%" sym)
    409                           (push (make-variable :name sym :special-p t) free-specials))))))
    410               (TYPE
    411                (dolist (sym (cddr decl))
    412                  (dolist (variable vars)
    413                    (when (eq sym (variable-name variable))
    414                      (setf (variable-declared-type variable) (cadr decl))))))))))
    415       (setf (block-vars block) vars)
    416       (setf (block-free-specials block) free-specials))
     423      (setf (block-free-specials block) (process-declarations-for-vars body vars))
     424      (setf (block-vars block) vars))
    417425    (setf body (mapcar #'p1 body))
    418426    (setf (block-form block) (list* op varlist body))
     
    445453        (when (special-variable-p (variable-name variable))
    446454          (setf (variable-special-p variable) t)))
    447       ;; Process declarations.
    448       (dolist (subform body)
    449         (unless (and (consp subform) (eq (car subform) 'DECLARE))
    450           (return))
    451         (let ((decls (cdr subform)))
    452           (dolist (decl decls)
    453             (case (car decl)
    454               (SPECIAL
    455                (dolist (sym (cdr decl))
    456                  (dolist (variable vars)
    457                    (when (eq sym (variable-name variable))
    458                      (setf (variable-special-p variable) t)))))
    459               (TYPE
    460                (dolist (sym (cddr decl))
    461                  (dolist (variable vars)
    462                    (when (eq sym (variable-name variable))
    463                      (setf (variable-declared-type variable) (cadr decl))))))))))
     455      (setf (block-free-specials block) (process-declarations-for-vars body vars))
    464456      (setf (block-vars block) (nreverse vars)))
    465457    (setf body (mapcar #'p1 body))
     
    53585350                                  (not (variable-used-non-locally-p variable))
    53595351                                  (subtypep (variable-declared-type variable) 'FIXNUM))
     5352                         (setf (variable-representation variable) :unboxed-fixnum))))))
     5353                ((DYNAMIC-EXTENT FTYPE IGNORE IGNORABLE INLINE NOTINLINE OPTIMIZE SPECIAL)
     5354                 ;; Nothing to do here.
     5355                 )
     5356                (t
     5357                 (dolist (name (cdr decl))
     5358                   (let ((variable (find-visible-variable name)))
     5359                     (when variable
     5360                       (setf (variable-declared-type variable) (car decl))
     5361                       (when (and (variable-register variable)
     5362                                  (not (variable-special-p variable))
     5363                                  (not (variable-used-non-locally-p variable))
     5364                                  (subtypep (variable-declared-type variable) 'FIXNUM))
    53605365                         (setf (variable-representation variable) :unboxed-fixnum))))))))))))
    53615366
Note: See TracChangeset for help on using the changeset viewer.