Changeset 12409


Ignore:
Timestamp:
01/30/10 23:08:35 (11 years ago)
Author:
astalla
Message:

Rewriting of function calls with (lambda ...) as the operator to let* forms.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp

    r12401 r12409  
    140140     rest allow-others-p
    141141     (nreverse aux) whole env)))
     142
     143(define-condition lambda-list-mismatch (error)
     144  ((mismatch-type :reader lambda-list-mismatch-type :initarg :mismatch-type)))
     145
     146(defmacro push-argument-binding (var form temp-bindings bindings)
     147  (let ((g (gensym)))
     148    `(let ((,g (gensym (symbol-name '#:temp))))
     149       (push (list ,g ,form) ,temp-bindings)
     150       (push (list ,var ,g) ,bindings))))
     151
     152(defun match-lambda-list (parsed-lambda-list arguments)
     153  (flet ((pop-required-argument ()
     154     (if (null arguments)
     155         (error 'lambda-list-mismatch :mismatch-type :too-few-arguments)
     156         (pop arguments)))
     157   (var (var-info) (car var-info))
     158   (initform (var-info) (cadr var-info))
     159   (p-var (var-info) (caddr var-info)))
     160    (destructuring-bind (req opt key key-p rest allow-others-p aux whole env)
     161  parsed-lambda-list
     162      (declare (ignore whole env))
     163      (let (req-bindings temp-bindings bindings ignorables)
     164  ;;Required arguments.
     165  (setf req-bindings
     166        (loop :for var :in req :collect `(,var ,(pop-required-argument))))
     167
     168  ;;Optional arguments.
     169  (when opt
     170    (dolist (var-info opt)
     171      (if arguments
     172    (progn
     173      (push-argument-binding (var var-info) (pop arguments)
     174           temp-bindings bindings)
     175      (when (p-var var-info)
     176        (push `(,(p-var var-info) t) bindings)))
     177    (progn
     178      (push `(,(var var-info) ,(initform var-info)) bindings)
     179      (when (p-var var-info)
     180        (push `(,(p-var var-info) nil) bindings)))))
     181    (setf bindings (nreverse bindings)))
     182 
     183  (unless (or key-p rest (null arguments))
     184    (error 'lambda-list-mismatch :mismatch-type :too-many-arguments))
     185
     186  ;;Keyword and rest arguments.
     187  (if key-p
     188      (multiple-value-bind (kbindings ktemps kignor)
     189    (match-keyword-and-rest-args
     190     key allow-others-p rest arguments)
     191        (setf bindings (append bindings kbindings)
     192        temp-bindings (append temp-bindings ktemps)
     193        ignorables (append kignor ignorables)))
     194      (when rest
     195        (let (rest-binding)
     196    (push-argument-binding (var rest) `(list ,@arguments)
     197               temp-bindings rest-binding)
     198    (setf bindings (append bindings rest-binding)))))
     199
     200  ;;Aux parameters.
     201  (when aux
     202    (setf bindings
     203    `(,@bindings
     204      ,@(loop
     205           :for var-info :in aux
     206           :collect `(,(var var-info) ,(initform var-info))))))
     207 
     208  (values
     209   (append req-bindings temp-bindings bindings)
     210   ignorables)))))
     211
     212(defun match-keyword-and-rest-args (key allow-others-p rest arguments)
     213  (flet ((var (var-info) (car var-info))
     214   (initform (var-info) (cadr var-info))
     215   (p-var (var-info) (caddr var-info))
     216   (keyword (var-info) (cadddr var-info)))
     217    (when (oddp (list-length arguments))
     218      (error 'lambda-list-mismatch
     219       :mismatch-type :odd-number-of-keyword-arguments))
     220   
     221    (let (temp-bindings bindings other-keys-found-p ignorables)
     222      ;;If necessary, make up a fake argument to hold :allow-other-keys,
     223      ;;needed later. This also handles nicely:
     224      ;;  3.4.1.4.1 Suppressing Keyword Argument Checking
     225      ;;third statement.
     226      (unless (find :allow-other-keys key :key #'keyword)
     227  (let ((allow-other-keys-temp (gensym (symbol-name :allow-other-keys))))
     228    (push allow-other-keys-temp ignorables)
     229    (push (list allow-other-keys-temp nil nil :allow-other-keys) key)))
     230     
     231      ;;First, let's bind the keyword arguments that have been passed by
     232      ;;the caller. If we encounter an unknown keyword, remember it.
     233      ;;As per the above, :allow-other-keys will never be considered
     234      ;;an unknown keyword.
     235      (loop
     236   :for var :in arguments :by #'cddr
     237   :for value :in (cdr arguments) by #'cddr
     238   :do (let ((var-info (find var key :key #'keyword)))
     239         (if var-info
     240       ;;var is one of the declared keyword arguments
     241       (progn
     242         (push-argument-binding (var var-info) value
     243              temp-bindings bindings)
     244         ;(push `(,(var var-info) ,value) bindings)
     245         (when (p-var var-info)
     246           (push `(,(p-var var-info) t) bindings)))
     247       (setf other-keys-found-p t))))
     248     
     249      ;;Then, let's bind those arguments that haven't been passed in
     250      ;;to their default value, in declaration order.
     251      (loop
     252   :for var-info :in key
     253   :do (unless (find (var var-info) bindings :key #'car)
     254         (push `(,(var var-info) ,(initform var-info)) bindings)
     255         (when (p-var var-info)
     256     (push `(,(p-var var-info) nil) bindings))))
     257     
     258      ;;If necessary, check for unrecognized keyword arguments.
     259      (when (and other-keys-found-p (not allow-others-p))
     260  (if (loop
     261         :for var :in arguments :by #'cddr
     262         :if (eq var :allow-other-keys)
     263         :do (return t))
     264      ;;We know that :allow-other-keys has been passed, so we
     265      ;;can access the binding for it and be sure to get the
     266      ;;value passed by the user and not an initform.
     267      (let* ((arg (var (find :allow-other-keys key :key #'keyword)))
     268       (binding (find arg bindings :key #'car))
     269       (form (cadr binding)))
     270        (if (constantp form)
     271      (unless (eval form)
     272        (error 'lambda-list-mismatch
     273         :mismatch-type :unknown-keyword))
     274      (setf (cadr binding)
     275      `(or ,(cadr binding)
     276           (error 'program-error
     277            "Unrecognized keyword argument")))))
     278      ;;TODO: it would be nice to report *which* keyword
     279      ;;is unknown
     280      (error 'lambda-list-mismatch :mismatch-type :unknown-keyword)))
     281      (when rest
     282  (push `(,(var rest)
     283     (list ,@(let (list)
     284         (loop
     285            :for var :in arguments :by #'cddr
     286            :for val :in (cdr arguments) :by #'cddr
     287            :do (let ((bound-var
     288           (var (find var key :key #'keyword))))
     289            (push var list)
     290            (if bound-var
     291          (push bound-var list)
     292          (push val list))))
     293         (nreverse list))))
     294        bindings))
     295      (values
     296       (nreverse bindings)
     297       temp-bindings
     298       ignorables))))
     299
     300#||test for the above
     301(handler-case
     302    (let ((lambda-list
     303     (multiple-value-list
     304      (jvm::parse-lambda-list
     305       '(a b &optional (c 42) &rest foo &key (bar c) baz ((kaz kuz) bar))))))
     306      (jvm::match-lambda-list
     307       lambda-list
     308       '((print 1) 3 (print 32) :bar 2)))
     309  (jvm::lambda-list-mismatch (x) (jvm::lambda-list-mismatch-type x)))
     310||#
    142311
    143312;; Returns a list of declared free specials, if any are found.
     
    10561225(defknown rewrite-function-call (t) t)
    10571226(defun rewrite-function-call (form)
    1058   (let ((args (cdr form)))
    1059     (if (unsafe-p args)
    1060         (let ((arg1 (car args)))
    1061           (cond ((and (consp arg1) (eq (car arg1) 'GO))
    1062                  arg1)
    1063                 (t
    1064                  (let ((syms ())
    1065                        (lets ()))
    1066                    ;; Preserve the order of evaluation of the arguments!
    1067                    (dolist (arg args)
    1068                      (cond ((constantp arg)
    1069                             (push arg syms))
    1070                            ((and (consp arg) (eq (car arg) 'GO))
    1071                             (return-from rewrite-function-call
    1072                                          (list 'LET* (nreverse lets) arg)))
    1073                            (t
    1074                             (let ((sym (gensym)))
    1075                               (push sym syms)
    1076                               (push (list sym arg) lets)))))
    1077                    (list 'LET* (nreverse lets)
    1078                          (list* (car form) (nreverse syms)))))))
    1079         form)))
     1227  (let ((op (car form))
     1228  (args (cdr form)))
     1229    (if (and (listp op)
     1230       (eq (car op) 'lambda))
     1231  (handler-case
     1232      (let ((lambda-list
     1233       (multiple-value-list (parse-lambda-list (cadr op))))
     1234      (body (cddr op)))
     1235        (multiple-value-bind (bindings ignorables)
     1236      (match-lambda-list lambda-list args)
     1237    `(let* ,bindings
     1238       (declare (ignorable ,@ignorables))
     1239       ,@body)))
     1240    (lambda-list-mismatch (x)
     1241      (warn "Invalid function call: ~S (mismatch type: ~A)"
     1242      form (lambda-list-mismatch-type x))
     1243      form))
     1244  (if (unsafe-p args)
     1245      (let ((arg1 (car args)))
     1246        (cond ((and (consp arg1) (eq (car arg1) 'GO))
     1247         arg1)
     1248        (t
     1249         (let ((syms ())
     1250         (lets ()))
     1251           ;; Preserve the order of evaluation of the arguments!
     1252           (dolist (arg args)
     1253       (cond ((constantp arg)
     1254        (push arg syms))
     1255             ((and (consp arg) (eq (car arg) 'GO))
     1256        (return-from rewrite-function-call
     1257          (list 'LET* (nreverse lets) arg)))
     1258             (t
     1259        (let ((sym (gensym)))
     1260          (push sym syms)
     1261          (push (list sym arg) lets)))))
     1262           (list 'LET* (nreverse lets)
     1263           (list* (car form) (nreverse syms)))))))
     1264      form))))
    10801265
    10811266(defknown p1-function-call (t) t)
     
    11851370                         (p1-function-call form))))
    11861371                 ((and (consp op) (eq (%car op) 'LAMBDA))
    1187                   (p1 (list* 'FUNCALL form)))
     1372                  (p1 (rewrite-function-call form)))
    11881373                 (t
    11891374                  form))))))
Note: See TracChangeset for help on using the changeset viewer.