parse.lisp

   1 ;;;;------------------------------------------------------------------
   2 ;;;;
   3 ;;;;    Copyright (C) 20012000, 2002-2004,
   4 ;;;;    Department of Computer Science, University of Tromso, Norway
   5 ;;;;
   6 ;;;; Filename:      parse.lisp
   7 ;;;; Description:
   8 ;;;; Author:        Frode Vatvedt Fjeld <frodef@acm.org>
   9 ;;;; Created at:    Fri Nov 24 16:49:17 2000
  10 ;;;; Distribution:  See the accompanying file COPYING.
  11 ;;;;
  12 ;;;; $Id: parse.lisp,v 1.7 2007/02/01 19:37:41 ffjeld Exp $
  13 ;;;;
  14 ;;;;------------------------------------------------------------------
  15
  16
  17 (in-package movitz)
  18
  19 (defun declare-form-p (form &optional (declare-symbol 'muerte.cl::declare))
  20   (and (consp form)
  21        (eq declare-symbol (car form))))
  22
  23 (defun parse-declarations-and-body (forms &optional (declare-symbol 'muerte.cl::declare))
  24   "From the list of FORMS, return first the list of non-declaration forms, ~
  25    second the list of declaration-specifiers."
  26   (loop for declaration-form = (when (declare-form-p (car forms) declare-symbol)
  27                                  (pop forms))
  28      while declaration-form
  29      append (cdr declaration-form) into declarations
  30      finally (return (values forms declarations))))
  31
  32 (defun parse-docstring-declarations-and-body (forms &optional (declare-symbol 'muerte.cl::declare))
  33   "From the list of FORMS, return first the non-declarations forms, second the declarations, ~
  34    and third the documentation string."
  35   (let ((docstring (when (and (cdr forms) (stringp (car forms)))
  36                      (pop forms))))
  37     (multiple-value-bind (body declarations)
  38         (parse-declarations-and-body forms declare-symbol)
  39       (values body declarations docstring))))
  40
  41 (defun unfold-circular-list (list)
  42   "If LIST is circular (through cdr), return (a copy of) the non-circular portion of LIST, and the index (in LIST) of the cons-cell pointed to by (cdr (last LIST))."
  43   (flet ((find-cdr (l c end)
  44            (loop for x on l as i upfrom 0 to end
  45                thereis (and (eq c x) i))))
  46     (loop for x on list as i upfrom 0
  47         as cdr-index = (find-cdr list (cdr x) i)
  48         until cdr-index
  49         finally (return (values (subseq list 0 (1+ i))
  50                                 cdr-index)))))
  51
  52 (defun symbol-package-fix-cl (symbol)
  53   *package*)
  54
  55 (eval-when (:execute :compile-toplevel :load-toplevel)
  56   (defun muerte::translate-program
  57       (program from-package to-package &key remove-double-quotes-p
  58                                             (quote-symbol 'muerte.cl::quote)
  59                                             when)
  60     "In PROGRAM, exchange symbols in FROM-PACKAGE with external symbols
  61 in TO-PACKAGE, whenever such symbols exists in TO-PACAKGE.
  62 Doubly quoted forms are copied verbatim (sans the quotes)."
  63     (setf from-package (find-package from-package))
  64     (setf to-package (find-package to-package))
  65     (flet ((translate-symbol (s)
  66              (if (not (eq s (find-symbol (symbol-name s) from-package)))
  67                  s
  68                (multiple-value-bind (symbol status)
  69                    (find-symbol (symbol-name s) to-package)
  70                  (when (or (and (find-symbol (symbol-name s) to-package)
  71                                 (not (find-symbol (symbol-name s) from-package)))
  72                            (and (find-symbol (symbol-name s) from-package)
  73                                 (not (find-symbol (symbol-name s) to-package))))
  74                    (error "blurgh ~S" s))
  75                  (or symbol s) #+ignore (if (eq :external status) symbol s)))))
  76       (cond
  77        ((symbolp program)               ; single symbol?
  78         (translate-symbol program))
  79        ((simple-vector-p program)
  80         (map 'vector
  81           (lambda (x) (translate-program x from-package to-package
  82                                          :quote-symbol quote-symbol
  83                                          :when when))
  84           program))
  85        ((atom program)                  ; atom?
  86         program)
  87        ((ignore-errors (null (list-length program))) ; circular list?
  88         (multiple-value-bind (unfolded-program cdr-index)
  89             (unfold-circular-list program)
  90           (let ((translated-program (muerte::translate-program unfolded-program from-package to-package
  91                                                                       :when when
  92                                                                       :remove-double-quotes-p remove-double-quotes-p
  93                                                                       :quote-symbol quote-symbol)))
  94             (setf (cdr (last translated-program))
  95               (nthcdr cdr-index translated-program))
  96             translated-program)))
  97        ((and (eq :translate-when (first program))
  98              (or (string= t (second program))
  99                  (and when (eq when (second program)))))
 100         (muerte::translate-program (third program) (fourth program) (fifth program) :when when))
 101        ((and (eq :translate-when (first program))
 102              (eq nil (second program)))
 103         (third program))
 104        ((symbolp (car program))
 105         (cons (translate-symbol (car program))
 106               (muerte::translate-program (cdr program) from-package to-package
 107                                          :when when
 108                                          :remove-double-quotes-p remove-double-quotes-p
 109                                          :quote-symbol quote-symbol)))
 110        ((consp (car program))
 111         (cons (muerte::translate-program (car program) from-package to-package
 112                                          :when when
 113                                          :remove-double-quotes-p remove-double-quotes-p
 114                                          :quote-symbol quote-symbol)
 115               (muerte::translate-program (cdr program) from-package to-package
 116                                          :when when
 117                                          :remove-double-quotes-p remove-double-quotes-p
 118                                          :quote-symbol quote-symbol)))
 119        (t (cons (car program)
 120                 (muerte::translate-program (cdr program) from-package to-package
 121                                            :when when
 122                                            :remove-double-quotes-p remove-double-quotes-p
 123                                            :quote-symbol quote-symbol))))))
 124   (defun muerte::movitz-program (program)
 125     (translate-program program :common-lisp :muerte.cl))
 126   (defun muerte::host-program (program)
 127     (translate-program program :muerte.cl :common-lisp)))
 128
 129 (defun decode-normal-lambda-list (lambda-list &optional host-symbols-p)
 130   "3.4.1 Ordinary Lambda Lists.
 131 Returns the requireds, &optionals, &rests, &keys, and &aux formal variables,
 132 a boolean signalling whether &allow-other-keys was present, and then
 133 the minimum and maximum number of arguments (or nil if max is infinite).
 134 Finally, whether &key was present or not."
 135   ;; Movitz extension: &edx <var> may appear first in lambda-list
 136   (let ((edx-var nil))
 137     (when (eq 'muerte::&edx (first lambda-list))
 138       (pop lambda-list)
 139       (setf edx-var (pop lambda-list)))
 140
 141     ;; We use sort of a unidirectional state-machine to traverse the
 142     ;; LAMBDA-LIST, stuffing the formals we encounter into different
 143     ;; slots according to the current state.
 144     (macrolet ((optional () '(second program))
 145                (rest-var () '(third program))
 146                (key () '(fourth program))
 147                (aux () '(fifth program))
 148                (allow-other-keys () '(if host-symbols-p
 149                                       '&allow-other-keys
 150                                       'muerte.cl::&allow-other-keys)))
 151       (loop for formal in lambda-list
 152           with program = (if host-symbols-p
 153                              '(requireds &optional &rest &key &aux)
 154                            '(requireds muerte.cl::&optional muerte.cl::&rest
 155                              muerte.cl::&key muerte.cl::&aux))
 156           with state = program
 157                        ;; (first state) is "current" state,
 158                        ;; (rest state) is the set of possible next states.
 159           with results = (list nil)     ; this property-list-to-be collects the results.
 160           with allow-other-keys-p = nil
 161           if (member formal (rest state))
 162           do (progn                     ; proceed to next state
 163                (push (first state) results)
 164                (push nil results)       ; place for next state's results
 165                (setf state (member formal (rest state))))
 166           else if (and (eq (first state) (key))
 167                        (eq formal (allow-other-keys))
 168                        (not allow-other-keys-p))
 169           do (setf allow-other-keys-p t)
 170           else do (push formal (car results))
 171           finally
 172             (push (first state) results)
 173           finally
 174             (let ((requireds (nreverse (getf results 'requireds)))
 175                   (optionals (nreverse (getf results (optional))))
 176                   (rests     (nreverse (getf results (rest-var))))
 177                   (keys      (nreverse (getf results (key))))
 178                   (auxes     (nreverse (getf results (aux)))))
 179               (when (> (length rests) 1)
 180                 (error "There can only be one &REST formal parameter."))
 181               (let ((maxargs (and (null rests) ; max num. of arguments, or nil.
 182                                   (null keys)
 183                                   (not allow-other-keys-p)
 184                                   (+ (length requireds)
 185                                      (length optionals))))
 186                     (minargs (length requireds)))
 187                 (return (values requireds
 188                                 optionals
 189                                 (first rests)
 190                                 keys
 191                                 auxes
 192                                 allow-other-keys-p
 193                                 minargs
 194                                 maxargs
 195                                 edx-var
 196                                 (cond
 197                                  ((or (eql maxargs minargs)
 198                                       (eq :no-key (getf results (key) :no-key)))
 199                                   nil)
 200                                  ((assert (not maxargs)))
 201                                  ((evenp (+ (length requireds) (length optionals)))
 202                                   :even)
 203                                  (t :odd))
 204                                 (not (eq :missing
 205                                          (getf results (key) :missing)))))))))))
 206
 207 (defun decode-optional-formal (formal)
 208   "3.4.1.2 Specifiers for optional parameters.
 209 Decode {var | (var [init-form [supplied-p-parameter]])}
 210 Return the variable, init-form, and suplied-p-parameter."
 211   (etypecase formal
 212     (symbol (values formal nil nil))
 213     (cons (values (first formal) (second formal) (third formal)))))
 214
 215 (defun decode-keyword-formal (formal)
 216   "3.4.1.4 Specifiers for keyword parameters.
 217 Parse {var | ({var | (keyword-name var)} [init-form [supplied-p-parameter]])}
 218 Return the variable, keyword-name, init-form and supplied-p-parameter, if any."
 219   (etypecase formal
 220     (null
 221      (error "Illegal keyword formal: ~S" formal))
 222     (symbol
 223      (values formal
 224              (intern (string formal) :keyword)
 225              nil
 226              nil))
 227     (cons
 228      (if (consp (car formal))
 229          (values (cadar formal) (caar formal) (second formal) (third formal))
 230        (values (car formal)
 231                (intern (string (car formal)) :keyword)
 232                (second formal)
 233                (third formal))))))
 234
 235 (defun decode-aux-formal (formal)
 236   "Return variable-name and init-form."
 237   (etypecase formal
 238     (symbol (values formal nil))
 239     (cons (values (first formal) (second formal)))))
 240
 241 (defun list-normal-lambda-list-variables (lambda-list)
 242   "Return the list of variables that <lambda-list> defines."
 243   (multiple-value-bind (requireds optionals rest keys auxes)
 244       (decode-normal-lambda-list lambda-list)
 245     (append requireds
 246             (mapcar #'decode-optional-formal optionals)
 247             (mapcar #'decode-keyword-formal keys)
 248             (mapcar #'decode-optional-formal auxes)
 249             (list rest))))
 250
 251 (defun lambda-list-simplify (lambda-list)
 252   "Return a version of lambda-list with only the variables for &optional and &key formals."
 253   (multiple-value-bind (requireds optionals rest keys auxes x y z edx-var)
 254       (decode-normal-lambda-list lambda-list)
 255     (declare (ignore x y z))
 256     (append (when edx-var
 257               `(muerte::&edx ,edx-var))
 258             requireds
 259             (when optionals
 260               '(muerte.cl::&optional))
 261             (mapcar #'decode-optional-formal optionals)
 262             (when rest
 263               (append '(muerte.cl::&rest) (list rest)))
 264             (when (member 'muerte.cl::&key lambda-list)
 265               '(muerte.cl::&key))
 266             (mapcar #'decode-keyword-formal keys)
 267             (when auxes
 268               '(muerte.cl::&aux))
 269             (mapcar #'decode-optional-formal auxes))))
 270
 271
 272 (defun decode-macro-lambda-list (lambda-list)
 273   "3.4.4 Macro Lambda Lists.
 274 Does not deal with destructuring."
 275   (flet ((state-keywords (state)
 276            (case state
 277              (:env '(muerte.cl::&environment))
 278              (:rest-or-body '(muerte.cl::&rest muerte.cl::&body))
 279              (t (list state)))))
 280     (loop for (formal . next-formal) on lambda-list
 281         with state = '(nil muerte.cl::&whole :env reqvars :env muerte.cl::&optional :env
 282                        :rest-or-body :env muerte.cl::&key :env muerte.cl::&aux :env)
 283                      ;; (first state) is "current" state,
 284                      ;; (rest state) is the set of possible next states.
 285                      ;; nil means an indetermined state, where we need a lambda keyword.
 286         with results = nil              ; this property-list-to-be collects the results.
 287         with allow-other-keys-p = nil
 288         if (member formal (rest state) :test #'member :key #'state-keywords)
 289         do (progn
 290 ;;;          (push (first state) results) ; the plist indicator
 291 ;;;          (push nil results)         ; plist place for next state's results
 292              (setf state (member formal (rest state) :test #'member :key #'state-keywords)))
 293         else if (and (eq (first state) 'muerte.cl::&key)
 294                      (eq formal 'muerte.cl::&allow-other-keys)
 295                      (not allow-other-keys-p)) do
 296           (setf allow-other-keys-p t)
 297         else if (null (first state)) do ; at indetermined-state?
 298           (cond
 299            ((member 'reqvars state)     ; have we not yet passed reqvars state?
 300             (setf state (member 'reqvars state)) ; .. then jump to reqvars state.
 301             (push formal (getf results 'reqvars)))
 302            (t                           ; we have passed reqvars state..
 303             (error "Illegal formal ~S in lambda-list ~S. Expected one of ~S."
 304                    formal lambda-list
 305                    (mapcan #'state-keywords
 306                            (remove-duplicates (remove nil state))))))
 307         else do
 308              (push formal (getf results (first state)))
 309         and do
 310             (case (first state)
 311               ((muerte.cl::&whole :env) ; these only take one formal, so we must force state
 312                (setf state (cons nil (rest state))))) ; .. to proceed, to an indetermined state.
 313         unless (listp next-formal) do   ; deal with lambda lists that ends like (a b c . d).
 314           (progn (push next-formal (getf results 'muerte.cl::&rest))
 315                  (loop-finish))
 316         finally
 317           (let ((reqvars   (nreverse (getf results 'reqvars)))
 318                 (envvars   (nreverse (getf results :env)))
 319                 (wholevars (nreverse (getf results 'muerte.cl::&whole)))
 320                 (optionals (nreverse (getf results 'muerte.cl::&optional)))
 321                 (rests     (nreverse (getf results :rest-or-body)))
 322                 (keys      (nreverse (getf results 'muerte.cl::&key)))
 323                 (auxes     (nreverse (getf results 'muerte.cl::&aux))))
 324             (when (> (length rests) 1)
 325               (error "There can only be one &REST formal parameter in lambda-list ~S."
 326                      lambda-list))
 327             (when (> (length envvars) 1)
 328               (error "There can only be one &ENVIRONMENT formal parameter, found ~S." envvars))
 329             (when (> (length wholevars) 1)
 330               (error "There can only be one &WHOLE formal parameter, found ~S." wholevars))
 331             (return (values (first wholevars)
 332                             (first envvars)
 333                             reqvars
 334                             optionals
 335                             (first rests)
 336                             keys
 337                             auxes
 338                             allow-other-keys-p))))))
 339
 340 (defun parse-d-bind-lambda-list (lambda-list proceed-scan)
 341   (multiple-value-bind (whole env requireds optionals rest keys)
 342       (decode-macro-lambda-list lambda-list)
 343     (declare (ignore keys whole env))
 344     (let ((scan-var (gensym "d-bind-scan-")))
 345       (append `((,scan-var ,proceed-scan))
 346               (loop for required in requireds
 347                   append (parse-d-bind-formal required `(pop ,scan-var)))
 348               (loop for optional in optionals
 349                   with var and init-form and supplied-p-parameter
 350                   do (multiple-value-setq (var init-form supplied-p-parameter)
 351                        (decode-optional-formal optional))
 352                   when supplied-p-parameter
 353                   collect
 354                     `(,supplied-p-parameter (if ,scan-var t nil))
 355                   append
 356                     (parse-d-bind-formal var (if init-form
 357                                                  `(if ,scan-var (pop ,scan-var) ,init-form)
 358                                                `(pop ,scan-var))))
 359               (when rest
 360                 `((,rest ,scan-var)))))))
 361
 362 (defun parse-d-bind-formal (formal proceed-scan)
 363   (etypecase formal
 364     (null
 365      (let ((dummy-var (gensym "d-bind-dummy-")))
 366        `((,dummy-var ,proceed-scan))))
 367     (symbol
 368      `((,formal ,proceed-scan)))
 369     (list
 370      (parse-d-bind-lambda-list formal proceed-scan))))
 371
 372 (defun compute-function-block-name (function-name)
 373   (cond
 374    ((symbolp function-name) function-name)
 375    ((and (consp function-name)
 376          (symbolp (cadr function-name)))
 377     (cadr function-name))
 378    (t (error "Unknown kind of function-name: ~S" function-name))))
 379