Changeset 4703
- Timestamp:
- 11/11/03 20:13:03 (19 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
trunk/j/src/org/armedbear/lisp/jvm.lisp
r4698 r4703 2 2 ;;; 3 3 ;;; Copyright (C) 2003 Peter Graves 4 ;;; $Id: jvm.lisp,v 1.2 3 2003-11-11 19:32:43 piso Exp $4 ;;; $Id: jvm.lisp,v 1.24 2003-11-11 20:13:03 piso Exp $ 5 5 ;;; 6 6 ;;; This program is free software; you can redistribute it and/or … … 1522 1522 'if_acmpeq) 1523 1523 1524 (defun compile-if (form )1524 (defun compile-if (form for-effect) 1525 1525 (let* ((test (second form)) 1526 1526 (consequent (third form)) … … 1537 1537 (emit 'label `,label2))) 1538 1538 1539 (defun compile-multiple-value-list (form )1539 (defun compile-multiple-value-list (form for-effect) 1540 1540 (compile-form (second form)) 1541 1541 (unless (remove-store-value) … … 1547 1547 (emit-store-value)) 1548 1548 1549 (defun compile-let/let* (form )1549 (defun compile-let/let* (form for-effect) 1550 1550 (let* ((saved-fp (fill-pointer *locals*)) 1551 1551 (varlist (second form)) … … 1680 1680 (tag-label (aref *tags* index))))) 1681 1681 1682 (defun compile-tagbody (form )1682 (defun compile-tagbody (form for-effect) 1683 1683 (let ((saved-fp (fill-pointer *tags*)) 1684 1684 (body (cdr form))) … … 1702 1702 (emit-store-value)) 1703 1703 1704 (defun compile-go (form )1704 (defun compile-go (form for-effect) 1705 1705 (let* ((name (cadr form)) 1706 1706 (label (label-for-tag name))) … … 1709 1709 (emit 'goto label))) 1710 1710 1711 (defun compile-block (form )1711 (defun compile-block (form for-effect) 1712 1712 (let* ((rest (cdr form)) 1713 1713 (block-label (car rest)) … … 1719 1719 (emit 'label `,block-exit))) 1720 1720 1721 (defun compile-progn (form )1721 (defun compile-progn (form for-effect) 1722 1722 (do ((forms (cdr form) (cdr forms))) 1723 1723 ((null forms)) 1724 1724 (compile-form (car forms) (cdr forms)))) 1725 1725 1726 (defun compile-setq (form )1726 (defun compile-setq (form for-effect) 1727 1727 (unless (= (length form) 3) 1728 1728 (error "COMPILE-SETQ too many args for SETQ")) … … 1765 1765 (emit-store-value)))) 1766 1766 1767 (defun compile-quote (form )1767 (defun compile-quote (form for-effect) 1768 1768 (let ((obj (second form))) 1769 1769 (cond ((null obj) … … 1791 1791 (error "COMPILE-QUOTE: unsupported case: ~S" form))))) 1792 1792 1793 (defun compile-declare (form )1793 (defun compile-declare (form for-effect) 1794 1794 ;; Nothing to do. 1795 1795 ) 1796 1796 1797 (defun compile-function (form )1797 (defun compile-function (form for-effect) 1798 1798 (let ((obj (second form))) 1799 1799 (cond ((symbolp obj) … … 1825 1825 (error "COMPILE-FUNCTION: unsupported case: ~S" form))))) 1826 1826 1827 (defun compile-return-from (form )1827 (defun compile-return-from (form for-effect) 1828 1828 (let* ((rest (cdr form)) 1829 1829 (block-label (car rest)) … … 1835 1835 (emit 'goto `,block-exit))) 1836 1836 1837 (defun compile-plus (form )1837 (defun compile-plus (form for-effect) 1838 1838 (let* ((args (cdr form)) 1839 1839 (len (length args))) … … 1854 1854 (compile-function-call '+ args))))) 1855 1855 1856 (defun compile-minus (form )1856 (defun compile-minus (form for-effect) 1857 1857 (let* ((args (cdr form)) 1858 1858 (len (length args))) … … 1907 1907 (cond 1908 1908 ((consp form) 1909 (let (( first (firstform))1910 ( rest (restform)))1911 (when (macro-function first)1909 (let ((op (car form)) 1910 (args (cdr form))) 1911 (when (macro-function op) 1912 1912 (compile-form (macroexpand form)) 1913 1913 (return-from compile-form)) 1914 (when (symbolp first)1915 (let ((handler (get first 'jvm-compile)))1914 (when (symbolp op) 1915 (let ((handler (get op 'jvm-compile-handler))) 1916 1916 (when handler 1917 (funcall handler form )1917 (funcall handler form for-effect) 1918 1918 (return-from compile-form)))) 1919 1919 (cond 1920 ((special-operator-p first)1921 (error "COMPILE-FORM unhandled special operator ~S" first))1920 ((special-operator-p op) 1921 (error "COMPILE-FORM unhandled special operator ~S" op)) 1922 1922 (t ; Function call. 1923 (compile-function-call first restfor-effect)))))1923 (compile-function-call op args for-effect))))) 1924 1924 ((eq form '()) 1925 1925 (unless for-effect … … 2156 2156 (unless (and handler (fboundp handler)) 2157 2157 (error "no handler for ~S" fun)) 2158 (setf (get fun 'jvm-compile ) handler)))2158 (setf (get fun 'jvm-compile-handler) handler))) 2159 2159 2160 2160 (mapc #'install-handler '(block
Note: See TracChangeset
for help on using the changeset viewer.