Changeset 8446


Ignore:
Timestamp:
02/01/05 22:24:26 (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

    r8442 r8446  
    22;;;
    33;;; Copyright (C) 2003-2005 Peter Graves
    4 ;;; $Id: jvm.lisp,v 1.382 2005-02-01 14:20:29 piso Exp $
     4;;; $Id: jvm.lisp,v 1.383 2005-02-01 22:24:26 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    479479         (block (find-block name)))
    480480    (when (null block)
    481       (error "P1-RETURN-FROM: no block named ~S is currently visible." name))
     481      (compiler-error "RETURN-FROM ~S: no block named ~S is currently visible."
     482                      name name))
    482483    (dformat t "p1-return-from block = ~S~%" (block-name block))
    483484    (setf (block-return-p block) t)
     
    12511252         :format-arguments format-arguments))
    12521253
    1253 (defun check-args (form n)
     1254;; "In addition to situations for which the standard specifies
     1255;; that conditions of type WARNING must or might be signaled, warnings might be
     1256;; signaled in situations where the compiler can determine that the
     1257;; consequences are undefined or that a run-time error will be signaled.
     1258;; Examples of this situation are as follows: violating type declarations,
     1259;; altering or assigning the value of a constant defined with DEFCONSTANT,
     1260;; calling built-in Lisp functions with a wrong number of arguments or
     1261;; malformed keyword argument lists, and using unrecognized declaration
     1262;; specifiers." (3.2.5)
     1263(defun check-arg-count (form n)
    12541264  (declare (type fixnum n))
    1255   (cond ((= (length form) (1+ n))
    1256          t)
    1257         (t
    1258          (compiler-style-warn "Wrong number of arguments for ~A." (car form))
    1259          nil)))
     1265  (let* ((op (car form))
     1266         (args (cdr form))
     1267         (ok (= (length args) n)))
     1268    (unless ok
     1269      (funcall (if (eq (symbol-package op) sys:+cl-package+)
     1270                   #'compiler-warn ; See above!
     1271                   #'compiler-style-warn)
     1272               "Wrong number of arguments for ~A (expected ~D, but received ~D)."
     1273               op n (length args)))
     1274    ok))
    12601275
    12611276(defparameter *resolvers* (make-hash-table :test #'eql))
     
    18891904       (write-u2 (second entry) stream))
    18901905      (t
    1891        (error "WRITE-CP-ENTRY unhandled tag ~D~%" tag)))))
     1906       (error "write-constant-pool-entry unhandled tag ~D~%" tag)))))
    18921907
    18931908(defun write-constant-pool (stream)
     
    24612476
    24622477(defun p2-eql (form &key (target :stack) representation)
    2463   (unless (= (length form) 3)
    2464     (error 'program-error "Wrong number of arguments for EQL."))
     2478  (unless (check-arg-count form 2)
     2479    (compile-function-call form target representation)
     2480    (return-from p2-eql))
    24652481  (let ((arg1 (second form))
    24662482        (arg2 (third form)))
     
    35763592      (emit-move-from-stack target))))
    35773593
    3578 (defun compile-atom (form &key (target :stack) representation)
    3579   (unless (= (length form) 2)
    3580     (error 'program-error "Wrong number of arguments for ATOM."))
     3594(defun p2-atom (form &key (target :stack) representation)
     3595  (unless (check-arg-count form 1)
     3596    (compile-function-call form target representation)
     3597    (return-from p2-atom))
    35813598  (compile-form (cadr form) :target :stack)
    35823599  (maybe-emit-clear-values (cadr form))
     
    35913608    (label LABEL2)
    35923609    (emit-move-from-stack target)))
    3593 
    3594 (defun compile-block (form &key (target :stack) representation)
    3595 ;;   (format t "compile-block ~S~%" (cadr form))
    3596   ;; This shouldn't be called, now that we have pass 1.
    3597 ;;   (assert nil)
    3598   (let ((block (make-block-node :form form
    3599                                 :name (cadr form)
    3600                                 :target target)))
    3601     (p2-block-node block target)
    3602   ))
    36033610
    36043611(defun p2-block-node (block target)
     
    37063713      (emit-move-from-stack target))))
    37073714
    3708 (defun compile-cons (form &key (target :stack) representation)
    3709   (unless (check-args form 2)
     3715(defun p2-cons (form &key (target :stack) representation)
     3716  (unless (check-arg-count form 2)
    37103717    (compile-function-call form target representation)
    3711     (return-from compile-cons))
     3718    (return-from p2-cons))
    37123719  (emit 'new +lisp-cons-class+)
    37133720  (emit 'dup)
     
    37683775            (compiler-unsupported "COMPILE-QUOTE: unsupported case: ~S" form)))))
    37693776
    3770 (defun compile-rplacd (form &key (target :stack) representation)
     3777(defun p2-rplacd (form &key (target :stack) representation)
     3778  (unless (check-arg-count form 2)
     3779    (compile-function-call form target representation)
     3780    (return-from p2-rplacd))
    37713781  (let ((args (cdr form)))
    3772     (unless (= (length args) 2)
    3773       (error 'program-error "Wrong number of arguments for RPLACD."))
    37743782    (compile-form (first args) :target :stack)
    37753783    (when target
     
    39823990(defun p2-ash (form &key (target :stack) representation)
    39833991  (dformat t "p2-ash form = ~S representation = ~S~%" form representation)
    3984   (unless (check-args form 2)
     3992  (unless (check-arg-count form 2)
    39853993    (compile-function-call form target representation)
    39863994    (return-from p2-ash))
     
    41234131
    41244132(defun compile-length (form &key (target :stack) representation)
    4125   (check-args form 1)
     4133  (check-arg-count form 1)
    41264134  (let ((arg (cadr form)))
    41274135    (compile-form arg :target :stack)
     
    41344142
    41354143(defun compile-nth (form &key (target :stack) representation)
    4136   (unless (check-args form 2)
     4144  (unless (check-arg-count form 2)
    41374145    (compile-function-call form target representation)
    41384146    (return-from compile-nth))
     
    43704378     (compile-function-call form target representation))))
    43714379
    4372 (defun compile-schar (form &key (target :stack) representation)
    4373   (unless (= (length form) 3)
    4374     (error 'program-error
    4375            :format-control "Wrong number of arguments for ~S."
    4376            :format-arguments (list (car form))))
     4380(defun p2-schar (form &key (target :stack) representation)
     4381  (unless (check-arg-count form 2)
     4382    (compile-function-call form target representation)
     4383    (return-from p2-schar))
    43774384  (compile-form (second form) :target :stack)
    43784385  (compile-form (third form) :target :stack :representation :unboxed-fixnum)
     
    43834390  (emit-move-from-stack target))
    43844391
    4385 (defun compile-aref (form &key (target :stack) representation)
     4392(defun p2-aref (form &key (target :stack) representation)
     4393  ;; We only optimize the 2-arg case.
    43864394  (unless (= (length form) 3)
    4387     (return-from compile-aref (compile-function-call form target representation)))
     4395       (return-from p2-aref (compile-function-call form target representation)))
    43884396  (compile-form (second form) :target :stack)
    43894397  (compile-form (third form) :target :stack :representation :unboxed-fixnum)
     
    43944402  (emit-move-from-stack target))
    43954403
    4396 (defun compile-not/null (form &key (target :stack) representation)
    4397   (unless (= (length form) 2)
    4398     (error 'program-error
    4399            :format-control "Wrong number of arguments for ~S."
    4400            :format-arguments (list (car form))))
     4404(defun p2-not/null (form &key (target :stack) representation)
     4405  (unless (check-arg-count form 1)
     4406    (compile-function-call form target representation)
     4407    (return-from p2-not/null))
    44014408  (let ((arg (second form)))
    44024409    (cond ((null arg)
     
    53855392    (class-file-pathname (compiland-class-file compiland))))
    53865393
     5394(defvar *compiler-error-bailout*)
     5395
     5396(defun make-compiler-error-form (form)
     5397  `(lambda ,(cadr form)
     5398     (error 'program-error :format-control "Execution of a form compiled with errors.")))
     5399
    53875400(defun compile-defun (name form environment &optional (filespec "out.class"))
    53885401  (aver (eq (car form) 'LAMBDA))
     
    53905403    (compiler-unsupported "COMPILE-DEFUN: unable to compile LAMBDA form defined in non-null lexical environment."))
    53915404  (aver (null *current-compiland*))
    5392   (handler-bind ((warning #'handle-warning)
    5393                  (compiler-error #'handle-compiler-error))
    5394     (compile-1 (make-compiland :name name
    5395                                :lambda-expression (precompile-form form t)
    5396                                :class-file (make-class-file :pathname filespec
    5397                                                             :lambda-list (cadr form))))))
     5405  (catch 'compile-defun-abort
     5406    (let* ((class-file (make-class-file :pathname filespec
     5407                                        :lambda-list (cadr form)))
     5408           (*compiler-error-bailout*
     5409            (lambda ()
     5410              (compile-1 (make-compiland :name name
     5411                                         :lambda-expression (make-compiler-error-form form)
     5412                                         :class-file class-file)))))
     5413      (handler-bind ((warning #'handle-warning)
     5414                     (compiler-error #'handle-compiler-error))
     5415        (compile-1 (make-compiland :name name
     5416                                   :lambda-expression (precompile-form form t)
     5417                                   :class-file class-file))))))
    53985418
    53995419(defun handle-warning (condition)
    54005420  (fresh-line)
    5401   (format t "~%; Caught ~A:~%;   ~A~%~%" (type-of condition) condition)
     5421  (format t "~%; Caught ~A:~%;   ~A~2%" (type-of condition) condition)
    54025422  (muffle-warning))
    54035423
    54045424(defun handle-compiler-error (condition)
    54055425  (fresh-line)
    5406   (format t "; Caught ~A:~%;   ~A~%" (type-of condition) condition))
     5426  (format t "~%; Caught ERROR:~%;   ~A~2%" condition)
     5427  (throw 'compile-defun-abort (funcall *compiler-error-bailout*)))
    54075428
    54085429(defun get-lambda-to-compile (definition-designator)
     
    54355456      (let ((*style-warnings* 0)
    54365457            (*warnings* 0)
    5437             (*errors* 0))
     5458            (*errors* 0)
     5459            (*in-compilation-unit* t))
    54385460        (unwind-protect
    54395461            (funcall fn)
    5440           (unless (and (zerop *warnings*) (zerop *style-warnings*))
     5462          (unless (zerop (+ *errors* *warnings* *style-warnings*))
    54415463            (format t "~%; Compilation unit finished~%")
     5464            (unless (zerop *errors*)
     5465              (format t ";   Caught ~D ERROR condition~P~%"
     5466                      *errors* *errors*))
    54425467            (unless (zerop *warnings*)
    54435468              (format t ";   Caught ~D WARNING condition~P~%"
     
    55425567    (setf (get symbol 'p2-handler) handler)))
    55435568
    5544 (mapc #'install-p2-handler '(aref
    5545                              atom
    5546                              block
    5547                              catch
    5548                              cons
     5569(mapc #'install-p2-handler '(catch
    55495570                             declare
    55505571                             funcall
     
    55585579                             progn
    55595580                             quote
    5560                              rplacd
    5561                              schar
    55625581                             setq
    55635582                             throw
     
    55725591(install-p2-handler '+              'p2-plus)
    55735592(install-p2-handler '-              'p2-minus)
     5593(install-p2-handler 'aref           'p2-aref)
    55745594(install-p2-handler 'ash            'p2-ash)
     5595(install-p2-handler 'atom           'p2-atom)
     5596(install-p2-handler 'cons           'p2-cons)
    55755597(install-p2-handler 'eql            'p2-eql)
    55765598(install-p2-handler 'flet           'p2-flet)
     
    55795601(install-p2-handler 'labels         'p2-labels)
    55805602(install-p2-handler 'logand         'p2-logand)
    5581 (install-p2-handler 'not            'compile-not/null)
    5582 (install-p2-handler 'null           'compile-not/null)
     5603(install-p2-handler 'not            'p2-not/null)
     5604(install-p2-handler 'null           'p2-not/null)
    55835605(install-p2-handler 'return-from    'p2-return-from)
     5606(install-p2-handler 'rplacd         'p2-rplacd)
     5607(install-p2-handler 'schar          'p2-schar)
    55845608(install-p2-handler 'the            'p2-the)
    5585 ;; (install-p2-handler 'unwind-protect 'p2-unwind-protect)
    55865609
    55875610(install-p2-handler '%call-internal 'p2-%call-internal)
Note: See TracChangeset for help on using the changeset viewer.