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

    r8412 r8416  
    22;;;
    33;;; Copyright (C) 2003-2005 Peter Graves
    4 ;;; $Id: jvm.lisp,v 1.378 2005-01-30 12:46:41 piso Exp $
     4;;; $Id: jvm.lisp,v 1.379 2005-01-31 05:53:38 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    544544        (compilands '()))
    545545    (dolist (definition (cadr form))
    546       (let* ((name (car definition))
    547              (lambda-list (cadr definition))
    548              (body (cddr definition))
    549              (compiland (make-compiland :name name
    550                                         :parent *current-compiland*)))
    551         (multiple-value-bind (body decls)
     546      (let ((name (car definition)))
     547        ;; FIXME
     548        (when (and (consp name) (eq (car name) 'SETF))
     549          (compiler-unsupported "P1-FLET: can't handle ~S." name))
     550        (let* ((lambda-list (cadr definition))
     551               (body (cddr definition))
     552               (compiland (make-compiland :name name
     553                                          :parent *current-compiland*)))
     554          (multiple-value-bind (body decls)
    552555            (sys::parse-body body)
    553           (setf (compiland-lambda-expression compiland)
    554                 `(lambda ,lambda-list ,@decls (block ,name ,@body)))
    555           (let ((*visible-variables* *visible-variables*)
    556                 (*current-compiland* compiland))
    557             (p1-compiland compiland)))
    558         (push compiland compilands)))
     556            (setf (compiland-lambda-expression compiland)
     557                  `(lambda ,lambda-list ,@decls (block ,name ,@body)))
     558            (let ((*visible-variables* *visible-variables*)
     559                  (*current-compiland* compiland))
     560              (p1-compiland compiland)))
     561          (push compiland compilands))))
    559562  (list* (car form) (nreverse compilands) (mapcar #'p1 (cddr form)))))
    560563
     
    566569        (local-functions ()))
    567570    (dolist (definition (cadr form))
    568       (let* ((name (car definition))
    569              (lambda-list (cadr definition))
    570              (body (cddr definition))
    571              (compiland (make-compiland :name name
    572                                         :parent *current-compiland*))
    573              (variable (make-variable :name (copy-symbol name)))
    574              (local-function (make-local-function :name name
    575                                                   :compiland compiland
    576                                                   :variable variable)))
    577         (multiple-value-bind (body decls)
    578           (sys::parse-body body)
    579           (setf (compiland-lambda-expression compiland)
    580                 `(lambda ,lambda-list ,@decls (block ,name ,@body))))
    581         (push variable *all-variables*)
    582         (push local-function local-functions)))
     571      (let ((name (car definition)))
     572        ;; FIXME
     573        (when (and (consp name) (eq (car name) 'SETF))
     574          (compiler-unsupported "P1-LABELS: can't handle ~S." name))
     575        (let* ((lambda-list (cadr definition))
     576               (body (cddr definition))
     577               (compiland (make-compiland :name name
     578                                          :parent *current-compiland*))
     579               (variable (make-variable :name (copy-symbol name)))
     580               (local-function (make-local-function :name name
     581                                                    :compiland compiland
     582                                                    :variable variable)))
     583          (multiple-value-bind (body decls)
     584            (sys::parse-body body)
     585            (setf (compiland-lambda-expression compiland)
     586                  `(lambda ,lambda-list ,@decls (block ,name ,@body))))
     587          (push variable *all-variables*)
     588          (push local-function local-functions))))
    583589    (setf local-functions (nreverse local-functions))
    584590    ;; Make the local functions visible.
     
    738744                         (p1 (macroexpand form)))
    739745                        ((special-operator-p op)
    740                          (error "P1: unsupported special operator ~S" op))
     746                         (compiler-unsupported "P1: unsupported special operator ~S" op))
    741747                        (t
    742748                         ;; Function call.
     
    12331239        :format-arguments format-arguments))
    12341240
     1241(defun compiler-unsupported (format-control &rest format-arguments)
     1242  (error 'compiler-unsupported-feature-error
     1243         :format-control format-control
     1244         :format-arguments format-arguments))
     1245
    12351246(defun check-args (form n)
    12361247  (declare (type fixnum n))
     
    24442455(defun p2-eql (form &key (target :stack) representation)
    24452456  (unless (= (length form) 3)
    2446     (error "Wrong number of arguments for EQL."))
     2457    (error 'program-error "Wrong number of arguments for EQL."))
    24472458  (let ((arg1 (second form))
    24482459        (arg2 (third form)))
     
    35603571(defun compile-atom (form &key (target :stack) representation)
    35613572  (unless (= (length form) 2)
    3562     (error "Wrong number of arguments for ATOM."))
     3573    (error 'program-error "Wrong number of arguments for ATOM."))
    35633574  (compile-form (cadr form) :target :stack)
    35643575  (maybe-emit-clear-values (cadr form))
     
    35733584    (label LABEL2)
    35743585    (emit-move-from-stack target)))
    3575 
    3576 ;; (defun contains-return (form)
    3577 ;;   (if (atom form)
    3578 ;;       (if (node-p form)
    3579 ;;           (contains-return (node-form form))
    3580 ;;           nil)
    3581 ;;       (case (car form)
    3582 ;;         (QUOTE
    3583 ;;          nil)
    3584 ;;         (RETURN-FROM
    3585 ;;          t)
    3586 ;;         (t
    3587 ;;          (dolist (subform form)
    3588 ;;            (when (contains-return subform)
    3589 ;;              (return t)))))))
    35903586
    35913587(defun compile-block (form &key (target :stack) representation)
     
    37633759            (compile-constant obj :target target))
    37643760           (t
    3765             (error "COMPILE-QUOTE: unsupported case: ~S" form)))))
     3761            (compiler-unsupported "COMPILE-QUOTE: unsupported case: ~S" form)))))
    37663762
    37673763(defun compile-rplacd (form &key (target :stack) representation)
    37683764  (let ((args (cdr form)))
    37693765    (unless (= (length args) 2)
    3770       (error "wrong number of arguments for RPLACD"))
     3766      (error 'program-error "Wrong number of arguments for RPLACD."))
    37713767    (compile-form (first args) :target :stack)
    37723768    (when target
     
    37963792                 (when (and (consp arg)
    37973793                            (not (constantp (second arg))))
    3798                    (error "P2-LOCAL-FUNCTION: can't handle optional argument with non-constant initform.")))))))
     3794                   (compiler-unsupported "P2-LOCAL-FUNCTION: can't handle optional argument with non-constant initform.")))))))
    37993795    (let* ((name (compiland-name compiland))
    38003796           form
     
    38623858        (aver (null (variable-register variable)))
    38633859        (unless (variable-closure-index variable)
    3864           (setf (variable-register variable) (allocate-register)))
    3865         (setf (variable-index variable) nil)))
     3860          (setf (variable-register variable) (allocate-register)))))
    38663861    (dolist (local-function local-functions)
    38673862      (p2-local-function (local-function-compiland local-function) local-function))
     
    38813876                 (when (and (consp arg)
    38823877                            (not (constantp (second arg))))
    3883                    (error "P2-LAMBDA: can't handle optional argument with non-constant initform.")))))))
     3878                   (compiler-unsupported
     3879                    "P2-LAMBDA: can't handle optional argument with non-constant initform.")))))))
    38843880    (aver (null (compiland-class-file compiland)))
    38853881    (setf (compiland-class-file compiland)
     
    39753971           (p2-lambda name target))
    39763972          (t
    3977            (error "p2-function: unsupported case: ~S" form)))))
     3973           (compiler-unsupported "p2-function: unsupported case: ~S" form)))))
    39783974
    39793975(defun p2-ash (form &key (target :stack) representation)
     
    45104506                    (emit-invokespecial-init +lisp-fixnum-class+ '("I"))))
    45114507           (emit-move-from-stack target representation))
    4512           (t (dformat t "compile-variable-reference ~S closure index = ~S~%"
    4513                       name (variable-closure-index variable))
    4514              (emit 'var-ref variable target representation)))))
     4508          (t
     4509           (dformat t "compile-variable-reference ~S closure index = ~S~%"
     4510                    name (variable-closure-index variable))
     4511           (emit 'var-ref variable target representation)))))
    45154512
    45164513(defun rewrite-setq (form)
     
    47664763                        ((special-operator-p op)
    47674764                         (dformat t "form = ~S~%" form)
    4768                          (error "COMPILE-FORM: unsupported special operator ~S" op))
     4765                         (compiler-unsupported
     4766                          "COMPILE-FORM: unsupported special operator ~S" op))
    47694767                        (t
    47704768                         (compile-function-call form target representation))))
     
    47764774                                  :representation representation)))
    47774775                 (t
    4778                   (error "COMPILE-FORM unhandled case ~S" form)))))
     4776                  (compiler-unsupported "COMPILE-FORM unhandled case ~S" form)))))
    47794777        ((symbolp form)
    47804778         (cond ((null form)
     
    47924790                  (if (eq expansion form)
    47934791                      (compile-variable-reference form target representation)
    4794                       (compile-form expansion :target target :representation representation))))))
     4792                      (compile-form expansion
     4793                                    :target target
     4794                                    :representation representation))))))
    47954795        ((block-node-p form)
    47964796         (cond ((equal (block-name form) '(TAGBODY))
     
    48074807         (compile-constant form :target target :representation representation))
    48084808        (t
    4809          (error "COMPILE-FORM unhandled case ~S" form))))
     4809         (compiler-unsupported "COMPILE-FORM unhandled case ~S" form))))
    48104810
    48114811;; Returns descriptor.
     
    51235123                 (setf (variable-register variable) (if *using-arg-array* nil register))
    51245124                 (aver (null (variable-index variable)))
    5125                  (setf (variable-index variable) index)
     5125                 (if *using-arg-array*
     5126                     (setf (variable-index variable) index))
    51265127                 (push variable parameters)
    51275128                 (incf register)
     
    52825283        (emit 'astore (compiland-argument-register compiland)))
    52835284
    5284       (cond ((and (not *child-p*) (not *using-arg-array*))
    5285              (dolist (variable (reverse *visible-variables*))
    5286                (when (eq (variable-representation variable) :unboxed-fixnum)
    5287                  (emit 'aload (variable-register variable))
    5288                  (emit-unbox-fixnum)
    5289                  (emit 'istore (variable-register variable))))))
     5285      (unless (or *child-p* *using-arg-array*)
     5286;;         (dolist (variable (reverse *visible-variables*))
     5287        (dolist (variable (compiland-arg-vars compiland))
     5288          (when (eq (variable-representation variable) :unboxed-fixnum)
     5289            (emit 'aload (variable-register variable))
     5290            (emit-unbox-fixnum)
     5291            (emit 'istore (variable-register variable)))))
    52905292
    52915293      (maybe-initialize-thread-var)
    52925294      (setf *code* (append code *code*)))
     5295
     5296;;     (let ((prologue *code*))
     5297;;       (setf *code* ())
     5298;;       (compile-progn-body body :stack)
     5299;;       (unless *code*
     5300;;         (emit-push-nil))
     5301;;       (emit 'areturn)
     5302;;       (let ((body-code *code*))
     5303;;         (setf *code* prologue)
     5304;;         (maybe-initialize-thread-var)
     5305;;         (setf prologue *code*)
     5306;;         (setf *code* (append body-code prologue))))
     5307
     5308;;     (resolve-variables)
    52935309
    52945310    (finalize-code)
     
    53685384  (aver (eq (car form) 'LAMBDA))
    53695385  (unless (or (null environment) (sys::empty-environment-p environment))
    5370     (error "COMPILE-DEFUN: unable to compile LAMBDA form defined in non-null lexical environment."))
     5386    (compiler-unsupported "COMPILE-DEFUN: unable to compile LAMBDA form defined in non-null lexical environment."))
    53715387  (aver (null *current-compiland*))
    53725388  (handler-bind ((warning #'handle-warning))
     
    54725488        (handler-case
    54735489            (%jvm-compile name definition)
     5490          (compiler-unsupported-feature-error
     5491           (c)
     5492           (fresh-line)
     5493           (%format t "; UNSUPPORTED FEATURE: ~A~%" c)
     5494           (if name
     5495               (%format t "~A Unable to compile ~S.~%" prefix name)
     5496               (%format t "~A Unable to compile top-level form.~%" prefix))
     5497           (precompiler::precompile name definition))
     5498          #+nil
    54745499          (error (c)
    54755500                 (fresh-line)
     
    54785503                     (%format t "~A Unable to compile ~S.~%" prefix name)
    54795504                     (%format t "~A Unable to compile top-level form.~%" prefix))
    5480                  (precompiler::precompile name definition))))
     5505                 (precompiler::precompile name definition))
     5506          ))
    54815507      (%jvm-compile name definition)))
    54825508
Note: See TracChangeset for help on using the changeset viewer.