Changeset 4703

Timestamp:

11/11/03 20:13:03 (18 years ago)

Author:

piso

Message:

Handlers now take second argument FOR-EFFECT.

File:

• trunk/j/src/org/armedbear/lisp/jvm.lisp (modified) (15 diffs)

trunk/j/src/org/armedbear/lisp/jvm.lisp

@@ -2 +2 @@
 ;;;
 ;;; Copyright (C) 2003 Peter Graves
-;;; $Id: jvm.lisp,v 1.23 2003-11-11 19:32:43 piso Exp $
+;;; $Id: jvm.lisp,v 1.24 2003-11-11 20:13:03 piso Exp $
 ;;;
 ;;; This program is free software; you can redistribute it and/or
@@ -1522 +1522 @@
   'if_acmpeq)
 
-(defun compile-if (form)
+(defun compile-if (form for-effect)
   (let* ((test (second form))
          (consequent (third form))
@@ -1537 +1537 @@
     (emit 'label `,label2)))
 
-(defun compile-multiple-value-list (form)
+(defun compile-multiple-value-list (form for-effect)
   (compile-form (second form))
   (unless (remove-store-value)
@@ -1547 +1547 @@
   (emit-store-value))
 
-(defun compile-let/let* (form)
+(defun compile-let/let* (form for-effect)
   (let* ((saved-fp (fill-pointer *locals*))
          (varlist (second form))
@@ -1680 +1680 @@
       (tag-label (aref *tags* index)))))
 
-(defun compile-tagbody (form)
+(defun compile-tagbody (form for-effect)
   (let ((saved-fp (fill-pointer *tags*))
         (body (cdr form)))
@@ -1702 +1702 @@
   (emit-store-value))
 
-(defun compile-go (form)
+(defun compile-go (form for-effect)
   (let* ((name (cadr form))
          (label (label-for-tag name)))
@@ -1709 +1709 @@
   (emit 'goto label)))
 
-(defun compile-block (form)
+(defun compile-block (form for-effect)
    (let* ((rest (cdr form))
           (block-label (car rest))
@@ -1719 +1719 @@
      (emit 'label `,block-exit)))
 
-(defun compile-progn (form)
+(defun compile-progn (form for-effect)
   (do ((forms (cdr form) (cdr forms)))
       ((null forms))
     (compile-form (car forms) (cdr forms))))
 
-(defun compile-setq (form)
+(defun compile-setq (form for-effect)
   (unless (= (length form) 3)
     (error "COMPILE-SETQ too many args for SETQ"))
@@ -1765 +1765 @@
       (emit-store-value))))
 
-(defun compile-quote (form)
+(defun compile-quote (form for-effect)
    (let ((obj (second form)))
      (cond ((null obj)
@@ -1791 +1791 @@
             (error "COMPILE-QUOTE: unsupported case: ~S" form)))))
 
-(defun compile-declare (form)
+(defun compile-declare (form for-effect)
   ;; Nothing to do.
   )
 
-(defun compile-function (form)
+(defun compile-function (form for-effect)
    (let ((obj (second form)))
      (cond ((symbolp obj)
@@ -1825 +1825 @@
             (error "COMPILE-FUNCTION: unsupported case: ~S" form)))))
 
-(defun compile-return-from (form)
+(defun compile-return-from (form for-effect)
    (let* ((rest (cdr form))
           (block-label (car rest))
@@ -1835 +1835 @@
      (emit 'goto `,block-exit)))
 
-(defun compile-plus (form)
+(defun compile-plus (form for-effect)
   (let* ((args (cdr form))
          (len (length args)))
@@ -1854 +1854 @@
        (compile-function-call '+ args)))))
 
-(defun compile-minus (form)
+(defun compile-minus (form for-effect)
   (let* ((args (cdr form))
          (len (length args)))
@@ -1907 +1907 @@
   (cond
    ((consp form)
-    (let ((first (first form))
-          (rest (rest form)))
-      (when (macro-function first)
+    (let ((op (car form))
+          (args (cdr form)))
+      (when (macro-function op)
         (compile-form (macroexpand form))
         (return-from compile-form))
-      (when (symbolp first)
-        (let ((handler (get first 'jvm-compile)))
+      (when (symbolp op)
+        (let ((handler (get op 'jvm-compile-handler)))
           (when handler
-            (funcall handler form)
+            (funcall handler form for-effect)
             (return-from compile-form))))
       (cond
-       ((special-operator-p first)
-        (error "COMPILE-FORM unhandled special operator ~S" first))
+       ((special-operator-p op)
+        (error "COMPILE-FORM unhandled special operator ~S" op))
        (t ; Function call.
-        (compile-function-call first rest for-effect)))))
+        (compile-function-call op args for-effect)))))
    ((eq form '())
     (unless for-effect
@@ -2156 +2156 @@
     (unless (and handler (fboundp handler))
       (error "no handler for ~S" fun))
-    (setf (get fun 'jvm-compile) handler)))
+    (setf (get fun 'jvm-compile-handler) handler)))
 
 (mapc #'install-handler '(block