Changeset 11141


Ignore:
Timestamp:
02/19/07 16:59:48 (15 years ago)
Author:
piso
Message:

MAYBE-REWRITE-LAMBDA

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/j/src/org/armedbear/lisp/precompiler.lisp

    r11091 r11141  
    22;;;
    33;;; Copyright (C) 2003-2006 Peter Graves
    4 ;;; $Id: precompiler.lisp,v 1.157 2006-08-17 23:52:49 piso Exp $
     4;;; $Id: precompiler.lisp,v 1.158 2007-02-19 16:59:48 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    7575(declaim (ftype (function (list) list) process-special-declarations))
    7676(defun process-special-declarations (forms)
    77   (let ((specials ()))
     77  (let ((specials nil))
    7878    (dolist (form forms)
    7979      (unless (and (consp form) (eq (%car form) 'DECLARE))
     
    8282        (dolist (decl decls)
    8383          (when (eq (car decl) 'special)
    84             (setf specials (append (cdr decl) specials))))))
     84            (setq specials (append (cdr decl) specials))))))
    8585    specials))
    8686
     
    548548  (let* ((args (cdr form))
    549549         (lambda-list (car args))
    550          (body (cdr args))
    551          (declared-specials (process-special-declarations body))
    552          (auxvars (memq '&AUX lambda-list))
    553          (specials '()))
     550         (auxvars (memq '&AUX lambda-list)))
    554551    (when auxvars
    555       (setf lambda-list (subseq lambda-list 0 (position '&AUX lambda-list)))
    556       (setf body (list (append (list 'LET* (cdr auxvars)) body))))
    557     ;; Scan for specials.
    558     (let ((keyp nil))
    559       (dolist (var lambda-list)
    560         (cond ((eq var '&KEY)
    561                (setf keyp t))
    562               ((atom var)
    563                (when (or (special-variable-p var) (memq var declared-specials))
    564                  (push var specials)))
    565               ((not keyp) ;; e.g. "&optional (*x* 42)"
    566                (setf var (%car var))
    567                (when (or (special-variable-p var) (memq var declared-specials))
    568                  (push var specials)))
    569               ;; Keyword parameters.
    570               ((atom (%car var)) ;; e.g. "&key (a 42)"
    571                ;; Not special.
    572                )
    573               (t
    574                ;; e.g. "&key ((:x *x*) 42)"
    575                (setf var (second (%car var))) ;; *x*
    576                (when (or (special-variable-p var) (memq var declared-specials))
    577                  (push var specials))))))
    578     (when specials
    579       ;; For each special...
    580       (dolist (special specials)
    581         (let ((sym (gensym)))
    582           (let ((res ())
    583                 (keyp nil))
    584             ;; Walk through the lambda list and replace each occurrence.
    585             (dolist (var lambda-list)
    586               (cond ((eq var '&KEY)
    587                      (setf keyp t)
    588                      (push var res))
    589                     ((atom var)
    590                      (when (eq var special)
    591                        (setf var sym))
    592                      (push var res))
    593                     ((not keyp) ;; e.g. "&optional (*x* 42)"
    594                      (when (eq (%car var) special)
    595                        (setf (first var) sym))
    596                      (push var res))
    597                     ((atom (%car var)) ;; e.g. "&key (a 42)"
    598                      (push var res))
    599                     (t
    600                      ;; e.g. "&key ((:x *x*) 42)"
    601                      (when (eq (second (%car var)) special)
    602                        (setf (second (%car var)) sym))
    603                      (push var res))))
    604             (setf lambda-list (nreverse res)))
    605           (setf body (list (append (list 'LET* (list (list special sym))) body))))))
    606     (list* 'LAMBDA lambda-list body)))
     552      (setq lambda-list (subseq lambda-list 0 (position '&AUX lambda-list)))
     553      (setf (cddr form) (list (append (list 'LET* (cdr auxvars)) (cddr form)))))
     554    (multiple-value-bind (body decls doc)
     555        (parse-body (cddr form))
     556      (let* ((declared-specials (process-special-declarations decls))
     557             (specials nil))
     558        ;; Scan for specials.
     559        (let ((keyp nil))
     560          (dolist (var lambda-list)
     561            (cond ((eq var '&KEY)
     562                   (setq keyp t))
     563                  ((atom var)
     564                   (when (or (special-variable-p var) (memq var declared-specials))
     565                     (push var specials)))
     566                  ((not keyp) ;; e.g. "&optional (*x* 42)"
     567                   (setq var (%car var))
     568                   (when (or (special-variable-p var) (memq var declared-specials))
     569                     (push var specials)))
     570                  ;; Keyword parameters.
     571                  ((atom (%car var)) ;; e.g. "&key (a 42)"
     572                   ;; Not special.
     573                   )
     574                  (t
     575                   ;; e.g. "&key ((:x *x*) 42)"
     576                   (setq var (second (%car var))) ;; *x*
     577                   (when (or (special-variable-p var) (memq var declared-specials))
     578                     (push var specials))))))
     579        (when specials
     580          ;; For each special...
     581          (dolist (special specials)
     582            (let ((sym (gensym)))
     583              (let ((res nil)
     584                    (keyp nil))
     585                ;; Walk through the lambda list and replace each occurrence.
     586                (dolist (var lambda-list)
     587                  (cond ((eq var '&KEY)
     588                         (setq keyp t)
     589                         (push var res))
     590                        ((atom var)
     591                         (when (eq var special)
     592                           (setq var sym))
     593                         (push var res))
     594                        ((not keyp) ;; e.g. "&optional (*x* 42)"
     595                         (when (eq (%car var) special)
     596                           (setf (car var) sym))
     597                         (push var res))
     598                        ((atom (%car var)) ;; e.g. "&key (a 42)"
     599                         (push var res))
     600                        (t
     601                         ;; e.g. "&key ((:x *x*) 42)"
     602                         (when (eq (second (%car var)) special)
     603                           (setf (second (%car var)) sym))
     604                         (push var res))))
     605                (setq lambda-list (nreverse res)))
     606              (setq body (list (append (list 'LET* (list (list special sym))) body))))))
     607        `(lambda ,lambda-list ,@decls ,@(when doc `(,doc)) ,@body)))))
    607608
    608609(defun precompile-lambda (form)
    609   (setf form (maybe-rewrite-lambda form))
     610  (setq form (maybe-rewrite-lambda form))
    610611  (let ((body (cddr form))
    611612        (*inline-declarations* *inline-declarations*))
     
    11191120      (parse-body body)
    11201121    (let* ((block-name (fdefinition-block-name name))
    1121            (lambda-expression `(named-lambda ,name ,lambda-list ,@decls (block ,block-name ,@body))))
     1122           (lambda-expression `(named-lambda ,name ,lambda-list ,@decls ,@(when doc `(,doc))
     1123                                             (block ,block-name ,@body))))
    11221124      (cond (*compile-file-truename*
    11231125             `(fset ',name ,lambda-expression))
Note: See TracChangeset for help on using the changeset viewer.