Changeset 14077


Ignore:
Timestamp:
08/13/12 08:29:26 (9 years ago)
Author:
ehuelsmann
Message:

Untabify.

File:
1 edited

Legend:

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

    r14075 r14077  
    166166(defun match-lambda-list (parsed-lambda-list arguments)
    167167  (flet ((pop-required-argument ()
    168      (if (null arguments)
    169          (error 'lambda-list-mismatch :mismatch-type :too-few-arguments)
    170          (pop arguments)))
    171   (var (var-info) (car var-info))
    172   (initform (var-info) (cadr var-info))
    173   (p-var (var-info) (caddr var-info)))
     168           (if (null arguments)
     169               (error 'lambda-list-mismatch :mismatch-type :too-few-arguments)
     170               (pop arguments)))
     171        (var (var-info) (car var-info))
     172        (initform (var-info) (cadr var-info))
     173        (p-var (var-info) (caddr var-info)))
    174174    (destructuring-bind (req opt key key-p rest allow-others-p aux whole env)
    175   parsed-lambda-list
     175        parsed-lambda-list
    176176      (declare (ignore whole env))
    177177      (let (req-bindings temp-bindings bindings ignorables)
    178   ;;Required arguments.
    179   (setf req-bindings
    180         (loop :for var :in req :collect `(,var ,(pop-required-argument))))
    181 
    182   ;;Optional arguments.
    183   (when opt
    184     (dolist (var-info opt)
    185       (if arguments
    186     (progn
    187       (push-argument-binding (var var-info) (pop arguments)
    188           temp-bindings bindings)
    189       (when (p-var var-info)
    190         (push `(,(p-var var-info) t) bindings)))
    191     (progn
    192       (push `(,(var var-info) ,(initform var-info)) bindings)
    193       (when (p-var var-info)
    194         (push `(,(p-var var-info) nil) bindings)))))
    195     (setf bindings (nreverse bindings)))
    196  
    197   (unless (or key-p rest (null arguments))
    198     (error 'lambda-list-mismatch :mismatch-type :too-many-arguments))
    199 
    200   ;;Keyword and rest arguments.
    201   (if key-p
    202       (multiple-value-bind (kbindings ktemps kignor)
    203     (match-keyword-and-rest-args
    204     key allow-others-p rest arguments)
    205         (setf bindings (append bindings kbindings)
    206         temp-bindings (append temp-bindings ktemps)
    207         ignorables (append kignor ignorables)))
    208       (when rest
    209         (let (rest-binding)
    210     (push-argument-binding (var rest) `(list ,@arguments)
    211                temp-bindings rest-binding)
    212     (setf bindings (append bindings rest-binding)))))
    213   ;;Aux parameters.
    214   (when aux
    215     (setf bindings
    216     `(,@bindings
    217       ,@(loop
    218            :for var-info :in aux
    219            :collect `(,(var var-info) ,(initform var-info))))))
    220   (values (append req-bindings temp-bindings bindings)
    221     ignorables)))))
     178        ;;Required arguments.
     179        (setf req-bindings
     180              (loop :for var :in req :collect `(,var ,(pop-required-argument))))
     181
     182        ;;Optional arguments.
     183        (when opt
     184          (dolist (var-info opt)
     185            (if arguments
     186                (progn
     187                  (push-argument-binding (var var-info) (pop arguments)
     188                                        temp-bindings bindings)
     189                  (when (p-var var-info)
     190                    (push `(,(p-var var-info) t) bindings)))
     191                (progn
     192                  (push `(,(var var-info) ,(initform var-info)) bindings)
     193                  (when (p-var var-info)
     194                    (push `(,(p-var var-info) nil) bindings)))))
     195          (setf bindings (nreverse bindings)))
     196       
     197        (unless (or key-p rest (null arguments))
     198          (error 'lambda-list-mismatch :mismatch-type :too-many-arguments))
     199
     200        ;;Keyword and rest arguments.
     201        (if key-p
     202            (multiple-value-bind (kbindings ktemps kignor)
     203                (match-keyword-and-rest-args
     204                key allow-others-p rest arguments)
     205              (setf bindings (append bindings kbindings)
     206                    temp-bindings (append temp-bindings ktemps)
     207                    ignorables (append kignor ignorables)))
     208            (when rest
     209              (let (rest-binding)
     210                (push-argument-binding (var rest) `(list ,@arguments)
     211                                       temp-bindings rest-binding)
     212                (setf bindings (append bindings rest-binding)))))
     213        ;;Aux parameters.
     214        (when aux
     215          (setf bindings
     216                `(,@bindings
     217                  ,@(loop
     218                       :for var-info :in aux
     219                       :collect `(,(var var-info) ,(initform var-info))))))
     220        (values (append req-bindings temp-bindings bindings)
     221                ignorables)))))
    222222
    223223(defun match-keyword-and-rest-args (key allow-others-p rest arguments)
    224224  (flet ((var (var-info) (car var-info))
    225   (initform (var-info) (cadr var-info))
    226   (p-var (var-info) (caddr var-info))
    227   (keyword (var-info) (cadddr var-info)))
     225        (initform (var-info) (cadr var-info))
     226        (p-var (var-info) (caddr var-info))
     227        (keyword (var-info) (cadddr var-info)))
    228228    (when (oddp (list-length arguments))
    229229      (error 'lambda-list-mismatch
    230        :mismatch-type :odd-number-of-keyword-arguments))
     230             :mismatch-type :odd-number-of-keyword-arguments))
    231231   
    232232    (let (temp-bindings bindings other-keys-found-p ignorables already-seen
    233     args)
     233          args)
    234234      ;;If necessary, make up a fake argument to hold :allow-other-keys,
    235235      ;;needed later. This also handles nicely:
     
    237237      ;;third statement.
    238238      (unless (find :allow-other-keys key :key #'keyword)
    239   (let ((allow-other-keys-temp (gensym (symbol-name :allow-other-keys))))
    240     (push allow-other-keys-temp ignorables)
    241     (push (list allow-other-keys-temp nil nil :allow-other-keys) key)))
     239        (let ((allow-other-keys-temp (gensym (symbol-name :allow-other-keys))))
     240          (push allow-other-keys-temp ignorables)
     241          (push (list allow-other-keys-temp nil nil :allow-other-keys) key)))
    242242     
    243243      ;;First, let's bind the keyword arguments that have been passed by
     
    246246      ;;an unknown keyword.
    247247      (loop
    248   :for var :in arguments :by #'cddr
    249   :for value :in (cdr arguments) :by #'cddr
    250   :do (let ((var-info (find var key :key #'keyword)))
    251          (if (and var-info (not (member var already-seen)))
    252        ;;var is one of the declared keyword arguments
    253        (progn
    254          (push-argument-binding (var var-info) value
    255               temp-bindings bindings)
    256          (when (p-var var-info)
    257            (push `(,(p-var var-info) t) bindings))
    258          (push var args)
    259          (push (var var-info) args)
    260          (push var already-seen))
    261        (let ((g (gensym)))
    262          (push `(,g ,value) temp-bindings)
    263          (push var args)
    264          (push g args)
    265          (push g ignorables)
    266          (unless var-info
    267            (setf other-keys-found-p t))))))
     248        :for var :in arguments :by #'cddr
     249        :for value :in (cdr arguments) :by #'cddr
     250        :do (let ((var-info (find var key :key #'keyword)))
     251               (if (and var-info (not (member var already-seen)))
     252                   ;;var is one of the declared keyword arguments
     253                   (progn
     254                     (push-argument-binding (var var-info) value
     255                                            temp-bindings bindings)
     256                     (when (p-var var-info)
     257                       (push `(,(p-var var-info) t) bindings))
     258                     (push var args)
     259                     (push (var var-info) args)
     260                     (push var already-seen))
     261                   (let ((g (gensym)))
     262                     (push `(,g ,value) temp-bindings)
     263                     (push var args)
     264                     (push g args)
     265                     (push g ignorables)
     266                     (unless var-info
     267                       (setf other-keys-found-p t))))))
    268268     
    269269      ;;Then, let's bind those arguments that haven't been passed in
    270270      ;;to their default value, in declaration order.
    271271      (let (defaults)
    272   (loop
    273      :for var-info :in key
    274      :do (unless (find (var var-info) bindings :key #'car)
    275     (push `(,(var var-info) ,(initform var-info)) defaults)
    276     (when (p-var var-info)
    277        (push `(,(p-var var-info) nil) defaults))))
    278   (setf bindings (append (nreverse defaults) bindings)))
     272        (loop
     273           :for var-info :in key
     274           :do (unless (find (var var-info) bindings :key #'car)
     275                (push `(,(var var-info) ,(initform var-info)) defaults)
     276                (when (p-var var-info)
     277                   (push `(,(p-var var-info) nil) defaults))))
     278        (setf bindings (append (nreverse defaults) bindings)))
    279279     
    280280      ;;If necessary, check for unrecognized keyword arguments.
    281281      (when (and other-keys-found-p (not allow-others-p))
    282   (if (loop
    283          :for var :in arguments :by #'cddr
    284          :if (eq var :allow-other-keys)
    285          :do (return t))
    286       ;;We know that :allow-other-keys has been passed, so we
    287       ;;can access the binding for it and be sure to get the
    288       ;;value passed by the user and not an initform.
    289       (let* ((arg (var (find :allow-other-keys key :key #'keyword)))
    290        (binding (find arg bindings :key #'car))
    291        (form (cadr binding)))
    292         (if (constantp form)
    293       (unless (eval form)
    294         (error 'lambda-list-mismatch
    295          :mismatch-type :unknown-keyword))
    296       (setf (cadr binding)
    297       `(or ,(cadr binding)
    298            (error 'program-error
    299             "Unrecognized keyword argument")))))
    300       ;;TODO: it would be nice to report *which* keyword
    301       ;;is unknown
    302       (error 'lambda-list-mismatch :mismatch-type :unknown-keyword)))
     282        (if (loop
     283               :for var :in arguments :by #'cddr
     284               :if (eq var :allow-other-keys)
     285               :do (return t))
     286            ;;We know that :allow-other-keys has been passed, so we
     287            ;;can access the binding for it and be sure to get the
     288            ;;value passed by the user and not an initform.
     289            (let* ((arg (var (find :allow-other-keys key :key #'keyword)))
     290                   (binding (find arg bindings :key #'car))
     291                   (form (cadr binding)))
     292              (if (constantp form)
     293                  (unless (eval form)
     294                    (error 'lambda-list-mismatch
     295                           :mismatch-type :unknown-keyword))
     296                  (setf (cadr binding)
     297                        `(or ,(cadr binding)
     298                             (error 'program-error
     299                                    "Unrecognized keyword argument")))))
     300            ;;TODO: it would be nice to report *which* keyword
     301            ;;is unknown
     302            (error 'lambda-list-mismatch :mismatch-type :unknown-keyword)))
    303303      (when rest
    304   (setf bindings (append bindings `((,(var rest) (list ,@(nreverse args)))))))
     304        (setf bindings (append bindings `((,(var rest) (list ,@(nreverse args)))))))
    305305      (values bindings temp-bindings ignorables))))
    306306
     
    308308(handler-case
    309309    (let ((lambda-list
    310      (multiple-value-list
    311       (jvm::parse-lambda-list
    312        '(a b &optional (c 42) &rest foo &key (bar c) baz ((kaz kuz) bar))))))
     310           (multiple-value-list
     311            (jvm::parse-lambda-list
     312             '(a b &optional (c 42) &rest foo &key (bar c) baz ((kaz kuz) bar))))))
    313313      (jvm::match-lambda-list
    314314       lambda-list
     
    320320  (handler-case
    321321      (multiple-value-bind (bindings ignorables)
    322     (match-lambda-list (multiple-value-list
    323             (parse-lambda-list lambda-list))
    324            args)
    325   `(let* ,bindings
    326      ,@(when ignorables
    327        `((declare (ignorable ,@ignorables))))
    328      ,@body))
     322          (match-lambda-list (multiple-value-list
     323                              (parse-lambda-list lambda-list))
     324                             args)
     325        `(let* ,bindings
     326           ,@(when ignorables
     327                   `((declare (ignorable ,@ignorables))))
     328           ,@body))
    329329    (lambda-list-mismatch (x)
    330330      (compiler-warn "Invalid function call: ~S (mismatch type: ~A)"
    331          form (lambda-list-mismatch-type x))
     331                     form (lambda-list-mismatch-type x))
    332332      form)))
    333333
     
    409409    (block varlist variables-var var body1 body2)
    410410  (let ((varspec (gensym))
    411   (initform (gensym))
    412   (name (gensym)))
     411        (initform (gensym))
     412        (name (gensym)))
    413413    `(let ((,variables-var ()))
    414414       (dolist (,varspec ,varlist)
    415   (cond ((consp ,varspec)
     415        (cond ((consp ,varspec)
    416416                ;; Even though the precompiler already signals this
    417417                ;; error, double checking can't hurt; after all, we're
    418418                ;; also rewriting &AUX into LET* bindings.
    419     (unless (<= 1 (length ,varspec) 2)
    420       (compiler-error "The LET/LET* binding specification ~S is invalid."
    421           ,varspec))
    422     (let* ((,name (%car ,varspec))
    423            (,initform (p1 (%cadr ,varspec)))
    424            (,var (make-variable :name (check-name ,name)
     419                (unless (<= 1 (length ,varspec) 2)
     420                  (compiler-error "The LET/LET* binding specification ~S is invalid."
     421                                  ,varspec))
     422                (let* ((,name (%car ,varspec))
     423                       (,initform (p1 (%cadr ,varspec)))
     424                       (,var (make-variable :name (check-name ,name)
    425425                                            :initform ,initform
    426426                                            :block ,block)))
    427       (when (neq ,initform (cadr ,varspec))
    428         (setf (cadr ,varspec) ,initform))
    429       (push ,var ,variables-var)
    430       ,@body1))
    431          (t
    432     (let ((,var (make-variable :name (check-name ,varspec)
     427                  (when (neq ,initform (cadr ,varspec))
     428                    (setf (cadr ,varspec) ,initform))
     429                  (push ,var ,variables-var)
     430                  ,@body1))
     431               (t
     432                (let ((,var (make-variable :name (check-name ,varspec)
    433433                                           :block ,block)))
    434       (push ,var ,variables-var)
    435       ,@body1))))
     434                  (push ,var ,variables-var)
     435                  ,@body1))))
    436436       ,@body2)))
    437437
     
    459459  (let* ((*visible-variables* *visible-variables*)
    460460         (block (make-let/let*-node))
    461   (*block* block)
     461        (*block* block)
    462462         (op (%car form))
    463463         (varlist (cadr form))
     
    500500  (let* ((*visible-variables* *visible-variables*)
    501501         (block (make-locally-node))
    502   (*block* block)
     502        (*block* block)
    503503         (free-specials (process-declarations-for-vars (cdr form) nil block)))
    504504    (setf (locally-free-specials block) free-specials)
     
    520520  (let* ((*visible-variables* *visible-variables*)
    521521         (block (make-m-v-b-node))
    522   (*block* block)
     522        (*block* block)
    523523         (varlist (cadr form))
    524524         ;; Process the values-form first. ("The scopes of the name binding and
     
    552552(defun p1-block (form)
    553553  (let* ((block (make-block-node (cadr form)))
    554   (*block* block)
     554        (*block* block)
    555555         (*blocks* (cons block *blocks*)))
    556556    (setf (cddr form) (p1-body (cddr form)))
     
    569569         (body (cddr form))
    570570         (block (make-catch-node))
    571   (*block* block)
     571        (*block* block)
    572572         ;; our subform processors need to know
    573573         ;; they're enclosed in a CATCH block
     
    593593         (body (cddr form))
    594594         (block (make-synchronized-node))
    595   (*block* block)
     595        (*block* block)
    596596         (*blocks* (cons block *blocks*))
    597597         result)
     
    617617      ;; need to copy the forms to create a second copy.
    618618      (let* ((block (make-unwind-protect-node))
    619        (*block* block)
     619             (*block* block)
    620620             ;; a bit of jumping through hoops...
    621621             (unwinding-forms (p1-body (copy-tree (cddr form))))
     
    668668(defun p1-tagbody (form)
    669669  (let* ((block (make-tagbody-node))
    670   (*block* block)
     670        (*block* block)
    671671         (*blocks* (cons block *blocks*))
    672672         (*visible-tags* *visible-tags*)
     
    10591059         (values-form (p1 (caddr form)))
    10601060         (block (make-progv-node))
    1061   (*block* block)
     1061        (*block* block)
    10621062         (*blocks* (cons block *blocks*))
    10631063         (body (cdddr form)))
     
    13171317                  (THREADS:SYNCHRONIZED-ON
    13181318                                        p1-threads-synchronized-on)
    1319       (JVM::WITH-INLINE-CODE identity)))
     1319                  (JVM::WITH-INLINE-CODE identity)))
    13201320    (install-p1-handler (%car pair) (%cadr pair))))
    13211321
Note: See TracChangeset for help on using the changeset viewer.