Ignore:
Timestamp:
01/02/05 01:55:29 (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

    r8322 r8323  
    22;;;
    33;;; Copyright (C) 2003-2004 Peter Graves
    4 ;;; $Id: jvm.lisp,v 1.337 2005-01-01 19:26:12 piso Exp $
     4;;; $Id: jvm.lisp,v 1.338 2005-01-02 01:55:29 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    456456      form))
    457457
     458(defun p1-eval-when (form)
     459  (list* (car form) (cadr form) (mapcar #'p1 (cddr form))))
     460
    458461(defun p1-lambda (form)
    459   (when (eq (car form) 'LAMBDA)
    460     (when *current-compiland*
    461       (unless (or (compiland-contains-lambda *current-compiland*)
    462                   (eq form (compiland-lambda-expression *current-compiland*)))
    463         (do ((compiland *current-compiland* (compiland-parent compiland)))
    464             ((null compiland))
    465           (setf (compiland-contains-lambda compiland) t)))))
    466   (list* (car form) (cadr form) (mapcar #'p1 (cddr form))))
     462  (aver (eq (car form) 'LAMBDA))
     463  (when *current-compiland*
     464    (unless (or (compiland-contains-lambda *current-compiland*)
     465                (eq form (compiland-lambda-expression *current-compiland*)))
     466      (do ((compiland *current-compiland* (compiland-parent compiland)))
     467          ((null compiland))
     468        (setf (compiland-contains-lambda compiland) t))))
     469  (let* ((lambda-list (cadr form))
     470         (body (cddr form))
     471         (auxvars (memq '&AUX lambda-list)))
     472    (when auxvars
     473      (setf lambda-list (subseq lambda-list 0 (position '&AUX lambda-list)))
     474      (setf body (list (append (list 'LET* (cdr auxvars)) body))))
     475    (list* 'LAMBDA lambda-list (mapcar #'p1 body))))
    467476
    468477(defun p1-quote (form)
     
    600609(install-p1-handler 'catch                'p1-default)
    601610(install-p1-handler 'declare              'identity)
    602 (install-p1-handler 'eval-when            'p1-lambda)
     611(install-p1-handler 'eval-when            'p1-eval-when)
    603612(install-p1-handler 'flet                 'p1-flet/labels)
    604613(install-p1-handler 'function             'p1-function)
Note: See TracChangeset for help on using the changeset viewer.