src/parser.lisp

   1 (in-package :parenscript)
   2
   3 ;;;; The mechanisms for defining macros & parsing Parenscript.
   4
   5 (eval-when (:compile-toplevel :load-toplevel)
   6   (defun macro-name-hash-function ()
   7     #'eql))
   8
   9 (defclass script-package ()
  10   ;; configuration slots
  11   ((name          :accessor script-package-name          :initform nil :initarg :name :type string
  12                   :documentation "Canonical name of the package (a String).")
  13    (nicknames     :accessor script-package-nicknames     :initform nil :initarg :nicknames
  14                   :documentation "List of nicknames for the package (as strings).")
  15    (prefix        :accessor script-package-prefix        :initform nil :initarg :prefix :type string
  16                   :documentation "The prefix string that will be used when translating the symbols in the current package to Javascript.")
  17    (lisp-package  :accessor script-package-lisp-package  :initform nil :initarg :lisp-package)
  18    (secondary-lisp-packages :accessor script-package-secondary-lisp-packages :initform nil
  19                             :initarg :secondary-lisp-packages)
  20    (exports       :accessor script-package-exports       :initarg :exports
  21                   :initform nil;(make-hash-table :test #'equal)
  22                   :documentation "List of exported identifiers.")
  23    (used-packages :accessor script-package-used-packages :initform nil :initarg :used-packages
  24                   :documentation "")
  25    (documentation :accessor script-package-documentation :initform nil :initarg :documentation)
  26    (compilation-env :accessor script-package-comp-env    :initform nil :initarg :comp-env)
  27    (locked?       :accessor script-package-locked? :initform nil :initarg :locked?
  28                   :documentation "t if redefinition of top-level symbols is disallowed.")
  29    ;; internal use slots
  30    (symbol-table :accessor script-package-symbol-table :initform nil :initarg :symbol-table
  31                  :documentation "Contains symbols when there is no lisp package for this package.")
  32    )
  33   (:documentation "A Parenscript package is a lisp object that holds information
  34 about a set of code.
  35
  36 "))
  37
  38 (defmethod print-object ((sp script-package) stream)
  39   (format stream "#<SCRIPT-PACKAGE ~s>" (script-package-name sp)))
  40
  41 (defclass compilation-environment ()
  42   ((script-packages :accessor comp-env-script-packages :initform nil :initarg :packages
  43                     :documentation "List of packages defined in this environment.")
  44    (current-package :accessor comp-env-current-package :initform nil :initarg :current-package
  45                     :documentation "Current in-package.")
  46    (lisp-to-script-package-table
  47     :accessor comp-env-lisp-to-script-package-table :initform (make-hash-table)
  48     :documentation   "Maps a lisp package to a script package.")
  49    (compiling-toplevel-p
  50     :accessor comp-env-compiling-toplevel-p :initform nil :initarg :processing-toplevel-p
  51     :documentation "T if the environment is currently processing toplevel forms.")
  52    (symbol-table :accessor symbol-to-script-package :initform (make-hash-table)
  53                  :documentation "Maps symbols to script packages.  Used for only the
  54 symbols in script packages that do not have a primary lisp package."))
  55   (:documentation ""))
  56
  57 (defgeneric symbol-script-package (symbol)
  58   (:documentation "Gets the Parenscript package associated with a Lisp/Parenscript symbol."))
  59
  60 (defgeneric compiler-in-situation-p (comp-env situation)
  61   (:documentation "Returns true when the compiler is considered 'in' the situation
  62 given by SITUATION, which is one of :compile-toplevel :execute.")
  63   (:method ((comp-env compilation-environment) situation)
  64     (cond
  65       ((eql situation :compile-toplevel) (processing-toplevel-p comp-env))
  66       ((eql situation :execute) (not (processing-toplevel-p comp-env)))
  67       (t nil))))
  68
  69 (defgeneric processing-toplevel-p (comp-env)
  70   (:documentation "T if we are compiling TOPLEVEL forms, as in
  71 http://www.lispworks.com/documentation/HyperSpec/Body/03_bca.htm")
  72   (:method ((comp-env compilation-environment))
  73     (comp-env-compiling-toplevel-p comp-env)
  74     ))
  75
  76 (defvar *compilation-environment* nil
  77   "The active compilation environment."
  78 ;; Right now all code assumes that *compilation-environment* is accurately bound to the
  79 ;; current compilation environment--even some functions that take the compilation environment
  80 ;; as arguments.
  81   )
  82
  83 (defvar *package-prefix-style* :prefix
  84   "Determines how package symbols are serialized to JavaScript identifiers.  NIL for
  85 no prefixes.  :prefix to prefix variables with something like packagename_identifier.")
  86
  87 (defvar *warn-ps-package* nil
  88   "If true, warns when ParenScript attempts to compile symbols that
  89 don't have an associated ParenScript package.")
  90
  91 ;;; parenscript packages
  92 (defun lisp-to-script-package (lisp-package &optional (comp-env *compilation-environment*))
  93   "Gets a script package corresponding to the given Lisp package."
  94   (gethash lisp-package (comp-env-lisp-to-script-package-table comp-env)))
  95
  96 (defsetf lisp-to-script-package (lisp-package &optional (comp-env *compilation-environment*))
  97     (script-package)
  98   "Sets the script package corresponding to the given Lisp package."
  99   `(setf (gethash ,lisp-package (comp-env-lisp-to-script-package-table ,comp-env))
 100     ,script-package))
 101
 102 (defmethod symbol-script-package ((symbol symbol))
 103   (if (symbol-package symbol)
 104       (or (lisp-to-script-package (symbol-package symbol) *compilation-environment*)
 105           (progn (when *warn-ps-package*
 106                    (warn 'simple-style-warning
 107                          :format-control "~s is a symbol with lisp package ~s, which has no corresponding ParenScript package.
 108 Defaulting to :parenscript-user."
 109                          :format-arguments (list symbol (symbol-package symbol))))
 110                  (find-script-package "PARENSCRIPT-USER" (make-basic-compilation-environment))))
 111       (find-script-package "UNINTERNED" *compilation-environment*)))
 112
 113 (defun find-script-package (name &optional (comp-env *compilation-environment*))
 114   "Find the script package with the name NAME in the given compilation environment."
 115   (typecase name
 116     ((or symbol string)
 117      (find-if #'(lambda (script-package)
 118                   (find (string name)
 119                         (cons (script-package-name script-package)
 120                               (script-package-nicknames script-package))
 121                         :test #'equal))
 122               (comp-env-script-packages comp-env)))
 123     (script-package name)
 124     (t (error "~A has unknown type" name))))
 125
 126 (defun script-intern (name script-package-name)
 127   "Returns a Parenscript symbol with the string value STRING interned for the
 128 given SCRIPT-PACKAGE."
 129   (declare (type string name))
 130   (let ((script-package (find-script-package script-package-name)))
 131     (flet ((find-exported-symbol (name script-package)
 132              (let ((res
 133                     (find name (script-package-exports script-package)
 134                           :key #'(lambda (exported-symbol) (string exported-symbol))
 135                           :test #'equal)))
 136                res)))
 137       (let ((res
 138              (or
 139               (some #'(lambda (used-package)
 140                         (find-exported-symbol name used-package))
 141                     (script-package-used-packages script-package))
 142               (if (script-package-lisp-package script-package)
 143                   (intern name (script-package-lisp-package script-package))
 144                   (progn
 145                     (let ((sym (intern-without-package name)))
 146                       (setf (gethash name (script-package-symbol-table script-package))
 147                             sym)
 148                       (setf (gethash sym (symbol-to-script-package (script-package-comp-env script-package)))
 149                             script-package)
 150                       sym))))))
 151         (declare (type symbol res))
 152         res))))
 153
 154 (defun find-script-symbol (name script-package)
 155   "Finds the symbol with name NAME in the script package SCRIPT-PACKAGE.  NAME is a
 156 string and SCRIPT-PACKAGE is a package designator.  If NAME does not specify a symbol of
 157 script-package, returns nil.  Otherwise returns 2 values:
 158 1.  the symbol
 159 2.  :external if the symbol is external.  :internal if the symbol is internal. NIL if
 160 the symbol is not interned in the package."
 161   (setf script-package (find-script-package script-package))
 162   (let (symbol interned-p)
 163
 164     (if (script-package-lisp-package script-package)
 165         (multiple-value-bind (lisp-symbol lisp-status)
 166             (find-symbol name (script-package-lisp-package script-package))
 167           (setf symbol lisp-symbol)
 168           (setf interned-p (and lisp-status t)))
 169         (multiple-value-bind (sym sym-found-p)
 170             (gethash name (script-package-symbol-table script-package))
 171           (setf symbol sym)
 172           (setf interned-p sym-found-p)))
 173     (let ((exported? (member symbol (script-package-exports script-package))))
 174       (values symbol
 175               (if exported? :external (if interned-p :internal nil))))))
 176
 177 (defun script-export (symbols
 178                       &optional (script-package (comp-env-current-package *compilation-environment*)))
 179   "Exports the given symbols in the given script package."
 180   (when (not (listp symbols)) (setf symbols (list symbols)))
 181   (setf script-package (find-script-package script-package))
 182   (let ((symbols-not-in-package
 183          (remove-if #'(lambda (symbol)
 184                         (declare (type symbol symbol))
 185                         (eql symbol (find-script-symbol (string symbol) script-package)))
 186                     symbols)))
 187     (when symbols-not-in-package
 188       (error "Invalid exports.  The following symbols are not interned in the package ~A:~%~A"
 189              (script-package-name script-package) symbols-not-in-package)))
 190   (mapc #'(lambda (symbol)
 191             (pushnew symbol (script-package-exports script-package)))
 192         symbols)
 193   t)
 194
 195 (defun use-script-package (packages-to-use
 196                            &optional (into-package (comp-env-current-package *compilation-environment*)))
 197   "use-script-package causes INTO-PACKAGE to inherit all the external symbols of packages-to-use.
 198 The inherited symbols become accessible as internal symbols of package."
 199   (when (not (listp packages-to-use)) (setf packages-to-use (list packages-to-use)))
 200   (setf packages-to-use (mapcar #'find-script-package packages-to-use))
 201   (setf into-package (find-script-package into-package))
 202
 203   (let ((all-used-symbols (apply #'append (mapcar #'script-package-exports packages-to-use))))
 204     (mapc #'(lambda (used-symbol)
 205               (let ((symbol-same-name (find-script-symbol (string used-symbol) into-package)))
 206                 (when (not (or (null symbol-same-name)
 207                                (eql symbol-same-name used-symbol)))
 208                   (error "Import of symbol ~A into package ~A conflicts with interned symbol ~A"
 209                          used-symbol (script-package-name into-package) symbol-same-name))))
 210           all-used-symbols))
 211   (setf (script-package-used-packages into-package)
 212         (append (script-package-used-packages into-package) packages-to-use)))
 213
 214
 215
 216 ;; environmental considerations
 217 (defgeneric setup-compilation-environment (comp-env)
 218   (:documentation "Sets up a basic compilation environment prepared for a language user.
 219 This should do things like define packages and set the current package.
 220
 221 Returns the compilation-environment."))
 222
 223 (defgeneric install-standard-script-packages (comp-env)
 224   (:documentation "Creates standard script packages and installs them in the current compilation
 225 environment."))
 226
 227 (defun make-basic-compilation-environment ()
 228   "Creates a compilation environment object from scratch.  Fills it in with the default
 229 script packages (parenscript, global, and parenscript-user)."
 230   (let ((*compilation-environment* (make-instance 'compilation-environment)))
 231     (setup-compilation-environment *compilation-environment*)))
 232
 233 (defun intern-without-package (name)
 234   (macrolet ((with-temp-package ((var) &body body)
 235                (let ((result-var (gensym)))
 236                `(let* ((,var (make-package ',(gensym)))
 237                        (,result-var (progn ,@body)))
 238                  (delete-package ,var)
 239                  ,result-var))))
 240     (with-temp-package (package)
 241       (let ((sym (intern name package)))
 242         (unintern sym package)
 243         sym))))
 244
 245
 246
 247 (defun create-script-package (comp-env
 248                               &key name nicknames prefix secondary-lisp-packages used-packages
 249                               lisp-package exports documentation)
 250   "Creates a script package in the given compilation environment"
 251   (when (and lisp-package (not (find-package lisp-package)))
 252     (error "Package ~A does not exists" lisp-package))
 253   (let* ((script-package
 254           (make-instance 'script-package
 255                          :name (string name)
 256                          :comp-env comp-env
 257                          :prefix prefix
 258                          :nicknames (mapcar #'string nicknames)
 259                          :lisp-package (when lisp-package (find-package lisp-package))
 260                          :secondary-lisp-packages (mapcar #'find-package secondary-lisp-packages)
 261                          :documentation documentation)))
 262     (use-script-package used-packages script-package)
 263     (labels ((package-intern (string-like)
 264                (script-intern (string string-like) script-package)))
 265       (script-export (mapcar #'package-intern exports) script-package))
 266     (push script-package (comp-env-script-packages comp-env))
 267     script-package))
 268
 269 (defmethod initialize-instance :after ((package script-package) &key)
 270   (assert (script-package-comp-env package))
 271   (when (null (script-package-lisp-package package))
 272     (setf (script-package-symbol-table package)
 273           (make-hash-table :test #'equal)))
 274   (let ((lisp-packages
 275          (remove-if #'null
 276                     (cons (script-package-lisp-package package)
 277                           (script-package-secondary-lisp-packages package)))))
 278     (dolist (lisp-package lisp-packages)
 279       (when (lisp-to-script-package lisp-package (script-package-comp-env package))
 280         (error "Lisp package already has corresponding script package: ~A" (package-name lisp-package)))
 281       (setf (lisp-to-script-package lisp-package (script-package-comp-env package))
 282             package))))
 283
 284 (defgeneric comp-env-find-package (comp-env package-designator)
 285   (:documentation "Finds the script package named by PACKAGE-DESIGNATOR in the current
 286 compilation environment. PACKAGE-DESIGNATOR is a string or symbol.")
 287   (:method ((comp-env compilation-environment) (name string))
 288     (find name (comp-env-script-packages comp-env)
 289           :key #'script-package-name :test #'equal))
 290   (:method ((comp-env compilation-environment) (package-designator symbol))
 291     (comp-env-find-package comp-env (string package-designator))))
 292
 293 ;; TODO loop through all defined macros and add them to the script package's
 294 ;; macro environment
 295 ;         (labels ((name-member (name)
 296 ;                    (eql (script-package-lisp-package script-package) (symbol-package name)))
 297 ;                  (import-macro (name function)
 298 ;                    (when (name-member name)
 299 ;                      (setf (gethash name (script-package-macro-table script-package))
 300 ;                            function)))
 301 ;                  (import-special-form (name function)
 302 ;                    (when (name-member name)
 303 ;                      (setf (gethash name (script-package-special-form-table script-package))
 304 ;                            function))))
 305 ;         (maphash #'import-special-form *toplevel-special-forms*)
 306 ;         (maphash #'import-special-form *toplevel-special-forms*)
 307
 308 ;(defgeneric comp-env-select-package (comp-env script-package)
 309 ;  (:documentation "")
 310 ;  (:method ((comp-env compilation-environment) (package script-package))
 311 ;    (setf (comp-env-current-package
 312
 313
 314 (eval-when (:compile-toplevel :load-toplevel :execute)
 315   (defvar *toplevel-special-forms* (make-hash-table :test (macro-name-hash-function))
 316     "A hash-table containing functions that implement Parenscript special forms,
 317 indexed by name (as symbols)")
 318   (defun undefine-script-special-form (name)
 319     "Undefines the special form with the given name (name is a symbol)."
 320     (declare (type symbol name))
 321     (when (gethash name *toplevel-special-forms*)
 322       (remhash name *toplevel-special-forms*))))
 323
 324 (defmacro define-script-special-form (name lambda-list &rest body)
 325   "Define a special form NAME. Arguments are destructured according to
 326 LAMBDA-LIST. The resulting Parenscript language types are appended to the
 327 ongoing javascript compilation."
 328   (declare (type symbol name))
 329   (let ((script-name
 330          (intern (format nil "PAREN-~A" (symbol-name name))
 331                  (find-package :parenscript)))
 332         (arglist (gensym "ps-arglist-")))
 333     `(setf (gethash (quote ,name) *toplevel-special-forms*)
 334       #'(lambda (&rest ,arglist)
 335           (destructuring-bind ,lambda-list
 336               ,arglist
 337             ,@body)))))
 338
 339
 340 (defun get-script-special-form (name)
 341   "Returns the special form function corresponding to the given name."
 342   (when (symbolp name)
 343     (gethash name *toplevel-special-forms*)))
 344
 345 ;;; sexp form predicates
 346 (defun script-special-form-p (form)
 347   "Returns T if FORM is a special form and NIL otherwise."
 348   (and (consp form)
 349        (symbolp (car form))
 350        (get-script-special-form (car form))))
 351
 352 (defun funcall-form-p (form)
 353   (and (listp form)
 354        (not (ps-js::op-form-p form))
 355        (not (script-special-form-p form))))
 356
 357 (defun method-call-p (form)
 358   (and (funcall-form-p form)
 359        (symbolp (first form))
 360        (eql (char (symbol-name (first form)) 0) #\.)))
 361
 362 ;;; macro expansion
 363 (eval-when (:compile-toplevel :load-toplevel :execute)
 364   (defun make-macro-env-dictionary ()
 365     "Creates a standard macro dictionary."
 366     (make-hash-table :test (macro-name-hash-function)))
 367   (defvar *script-macro-toplevel* (make-macro-env-dictionary)
 368     "Toplevel macro environment dictionary. Key is the symbol of the
 369 macro, value is (symbol-macro-p . expansion-function).")
 370   (defvar *script-macro-env* (list *script-macro-toplevel*) ;(list nil)
 371     "Current macro environment.")
 372
 373   (defvar *script-setf-expanders* (make-macro-env-dictionary)
 374     "Setf expander dictionary. Key is the symbol of the access
 375 function of the place, value is an expansion function that takes the
 376 arguments of the access functions as a first value and the form to be
 377 stored as the second value.")
 378
 379   (defun find-macro-spec (name env-dict)
 380     (gethash name env-dict))
 381   (defsetf find-macro-spec (name env-dict)
 382       (spec)
 383     `(setf (gethash ,name ,env-dict) ,spec)))
 384
 385
 386 (defmacro get-macro-spec (name env-dict)
 387   "Retrieves the macro spec of the given name with the given environment dictionary.
 388 SPEC is of the form (symbol-macro-p . expansion-function)."
 389   `(find-macro-spec ,name ,env-dict))
 390
 391 (defun lookup-macro-spec (name &optional (environment *script-macro-env*))
 392   "Looks up the macro spec associated with NAME in the given environment.  A
 393 macro spec is of the form (symbol-macro-p . function). Returns two values:
 394 the SPEC and the parent macro environment.
 395
 396 NAME must be a symbol."
 397   (when (symbolp name)
 398     (do ((env environment (cdr env)))
 399         ((null env) nil)
 400       (let ((val (get-macro-spec name (car env))))
 401         (when val
 402           (return-from lookup-macro-spec
 403             (values val (or (cdr env)
 404                             (list *script-macro-toplevel*)))))))))
 405
 406 (defun script-symbol-macro-p (name &optional (environment *script-macro-env*))
 407   "True if there is a Parenscript symbol macro named by the symbol NAME."
 408   (and (symbolp name) (car (lookup-macro-spec name environment))))
 409
 410 (defun script-macro-p (name &optional (environment *script-macro-env*))
 411   "True if there is a Parenscript macro named by the symbol NAME."
 412   (and (symbolp name)
 413        (let ((macro-spec (lookup-macro-spec name environment)))
 414          (and macro-spec (not (car macro-spec))))))
 415
 416 (defun lookup-macro-expansion-function (name &optional (environment *script-macro-env*))
 417   "Lookup NAME in the given macro expansion environment (which
 418 defaults to the current macro environment). Returns the expansion
 419 function and the parent macro environment of the macro."
 420   (multiple-value-bind (macro-spec parent-env)
 421       (lookup-macro-spec name environment)
 422     (values (cdr macro-spec) parent-env)))
 423
 424 (defun define-script-macro% (name args body &key symbol-macro-p)
 425   (let ((lambda-list (gensym "ps-lambda-list-"))
 426         (body (if (and (cdr body) (stringp (first body))) (rest body) body))) ;; drop docstring
 427     (undefine-script-special-form name)
 428     (setf (get-macro-spec name *script-macro-toplevel*)
 429           (cons symbol-macro-p (compile nil `(lambda (&rest ,lambda-list)
 430                                    (destructuring-bind ,args
 431                                        ,lambda-list
 432                                      ,@body)))))
 433     nil))
 434
 435 (defmacro defscriptmacro (name args &body body)
 436   "Define a ParenScript macro, and store it in the toplevel ParenScript
 437 macro environment."
 438   (define-script-macro% name args body :symbol-macro-p nil))
 439
 440 (defmacro define-script-symbol-macro (name &body body)
 441   "Define a ParenScript symbol macro, and store it in the toplevel ParenScript
 442 macro environment.  BODY is a Lisp form that should return a ParenScript form."
 443   (define-script-macro% name () body :symbol-macro-p t))
 444
 445 (defun import-macros-from-lisp (&rest names)
 446   "Import the named Lisp macros into the ParenScript macro
 447 environment. When the imported macro is macroexpanded by ParenScript,
 448 it is first fully macroexpanded in the Lisp macro environment, and
 449 then that expansion is further expanded by ParenScript."
 450   (dolist (name names)
 451     (define-script-macro% name '(&rest args) (list `(common-lisp:macroexpand `(,',name ,@args))) :symbol-macro-p nil)))
 452
 453 (defmacro defmacro/ps (name args &body body)
 454   "Define a Lisp macro and import it into the ParenScript macro environment."
 455   `(progn (defmacro ,name ,args ,@body)
 456           (ps:import-macros-from-lisp ',name)))
 457
 458 (defmacro defmacro+ps (name args &body body)
 459   "Define a Lisp macro and a ParenScript macro in their respective
 460 macro environments. This function should be used when you want to use
 461 the same macro in both Lisp and ParenScript, but the 'macroexpand' of
 462 that macro in Lisp makes the Lisp macro unsuitable to be imported into
 463 the ParenScript macro environment."
 464   `(progn (defmacro ,name ,args ,@body)
 465           (defscriptmacro ,name ,args ,@body)))
 466
 467 (defmacro defpsmacro (&rest args)
 468   `(defscriptmacro ,@args))
 469
 470 (defun expand-script-form (expr)
 471   "Expands a Parenscript form until it reaches a special form.  Returns 2 values:
 472 1. the expanded form.
 473 2. whether the form was expanded."
 474   (if (consp expr)
 475       (let ((op (car expr))
 476             (args (cdr expr)))
 477         (cond ((equal op 'quote)
 478                (values
 479                 (if (equalp '(nil) args) nil expr) ;; leave quotes alone, unless it's a quoted nil
 480                 nil))
 481               ((script-macro-p op) ;; recursively expand parenscript macros in parent env.
 482                (multiple-value-bind (expansion-function macro-env)
 483                    (lookup-macro-expansion-function op)
 484                  (values
 485                   (expand-script-form (let ((*script-macro-env* macro-env))
 486                                         (apply expansion-function args)))
 487                   t)))
 488               ((script-special-form-p expr)
 489                (values expr nil))
 490               (t (values expr nil))))
 491       (cond ((script-symbol-macro-p expr)
 492              ;; recursively expand symbol macros in parent env.
 493              (multiple-value-bind (expansion-function macro-env)
 494                  (lookup-macro-expansion-function expr)
 495                (values
 496                 (expand-script-form (let ((*script-macro-env* macro-env))
 497                                       (funcall expansion-function)))
 498                 t)))
 499             ;; leave anything else alone
 500             (t (values expr nil)))))
 501
 502 (defun process-eval-when-args (args)
 503   "(eval-when form-language? (situation*) form*) - returns 3 values:
 504 form-language, a list of situations, and a list of body forms"
 505   (let* ((rest args)
 506          (form-language
 507           (when (not (listp (first rest)))
 508             (setf rest (rest args))
 509             (first args)))
 510          (situations (first rest))
 511          (body (rest rest)))
 512     (when (and (find :compile-toplevel situations) (find :execute situations))
 513       (error "Cannot use EVAL-WHEN to execute COMPILE-TOPLEVEL and EXECUTE code simultaneously."))
 514     (when (null form-language)
 515       (setf form-language
 516             (cond
 517               ((find :compile-toplevel situations) :lisp)
 518               ((find :execute situations)          :parenscript))))
 519     (values form-language situations body)))
 520
 521 ;;;; compiler interface ;;;;
 522 (defgeneric compile-parenscript-form (compilation-environment form)
 523   (:documentation "Compiles FORM, which is a ParenScript form.
 524 If toplevel-p is NIL, the result is a compilation object (the AST root).
 525 Subsequently TRANSLATE-AST can be called to convert the result to Javascript.
 526
 527 If the compiler is in the COMPILE-TOPLEVEL stage, then the result will
 528 be a Parenscript form (after it has been processed according to semantics
 529 like those of Lisp's COMPILE-FILE). See
 530 http://www.lispworks.com/documentation/HyperSpec/Body/03_bca.htm"))
 531
 532 (defgeneric compile-toplevel-parenscript-form (comp-env form)
 533   (:documentation "Compiles a parenscript form in the given compilation environment
 534 when the environment is in the :compile-toplevel situation.  Returns a form to be
 535 compiled in place of the original form upon exiting the :compile-toplevel situation."))
 536
 537 (defmethod compile-toplevel-parenscript-form ((comp-env compilation-environment) form)
 538   (cond
 539     ((not (listp form)) form)
 540     ;; process each clause of a progn as a toplevel form
 541     ((eql 'progn (car form))
 542      `(progn
 543        ,@(mapcar #'(lambda (subform)
 544                      (compile-parenscript-form comp-env subform))
 545                  (rest form))))
 546     ;; TODO process macrolets, symbol-macrolets, and file inclusions
 547
 548     ;; process eval-when.  evaluates in :COMPILE-TOPLEVEL situation and returns
 549     ;; the resultant form.  for :EXECUTE situation it returns
 550     ((eql 'eval-when (car form))
 551      (multiple-value-bind (body-language situations body)
 552          (process-eval-when-args (rest form))
 553        (cond
 554          ((find :compile-toplevel situations)
 555           (when (eql body-language :lisp)
 556             (let ((other-situations (remove :compile-toplevel situations)))
 557               (multiple-value-bind (function warnings-p failure-p)
 558                   (compile nil `(lambda () ,@body))
 559                 (declare (ignore warnings-p) (ignore failure-p))
 560                 (compile-parenscript-form
 561                  comp-env
 562                  `(progn
 563                    ,(funcall function)
 564                    ,@(when other-situations
 565                            (list `(eval-when ,other-situations ,@body)))))))))
 566          ;; if :compile-toplevel is not in the situation list, return the form
 567          (t form))))
 568     (t form)))
 569
 570
 571 (defmethod compile-parenscript-form :around ((comp-env compilation-environment) form)
 572   (multiple-value-bind (expanded-form expanded-p)
 573       (expand-script-form form)
 574     (cond
 575       (expanded-p
 576        (compile-parenscript-form comp-env expanded-form))
 577       ((comp-env-compiling-toplevel-p comp-env)
 578        (compile-toplevel-parenscript-form comp-env form))
 579       (t (call-next-method)))))
 580
 581 (defmethod compile-parenscript-form ((comp-env compilation-environment) (form string))
 582   (make-instance 'ps-js::string-literal :value form))
 583
 584 (defmethod compile-parenscript-form ((comp-env compilation-environment) (form character))
 585   (compile-parenscript-form comp-env (string form)))
 586
 587 (defmethod compile-parenscript-form ((comp-env compilation-environment) (form number))
 588   (make-instance 'ps-js::number-literal :value form))
 589
 590 (defmethod compile-parenscript-form ((comp-env compilation-environment) (form symbol))
 591   ;; is this the correct behavior?
 592   (let ((c-macro (get-script-special-form form)))
 593     (cond
 594       (c-macro  (funcall c-macro))
 595       ;; the following emulates the lisp behavior that a keyword is bound to itself
 596       ;; see http://clhs.lisp.se/Body/t_kwd.htm
 597       ((keywordp form) (compile-parenscript-form comp-env `(quote ,form)))
 598       (t (make-instance 'ps-js::js-variable :value form)))))
 599
 600 (defun compile-function-argument-forms (forms)
 601   "Compiles a bunch of Parenscript forms from a funcall form to an effective set of
 602 Javascript arguments.  The only extra processing this does is makes :keyword arguments
 603 into a single options argument via CREATE."
 604   (flet ((keyword-arg (arg)
 605            "If the given compiled expression is supposed to be a keyword argument, returns
 606 the keyword for it."
 607            (when (typep arg 'script-quote) (ps-js::value arg))))
 608   (let ((expressions (mapcar #'compile-to-expression forms)))
 609
 610     (do ((effective-expressions nil)
 611          (expressions-subl expressions))
 612
 613         ((not expressions-subl)
 614          (nreverse effective-expressions))
 615
 616       (let ((arg-expr (first expressions-subl)))
 617         (if (keyword-arg arg-expr)
 618             (progn
 619               (when (oddp (length expressions-subl))
 620                 (error "Odd number of keyword arguments."))
 621               (push
 622                (make-instance 'ps-js::js-object
 623                               :slots
 624                               (loop for (name val) on expressions-subl by #'cddr
 625                                     collect (list name val)))
 626                effective-expressions)
 627               (setf expressions-subl nil))
 628             (progn
 629               (push arg-expr effective-expressions)
 630               (setf expressions-subl (rest expressions-subl)))))))))
 631
 632 (defmethod compile-parenscript-form ((comp-env compilation-environment) (form cons))
 633   (let* ((name (car form))
 634          (args (cdr form))
 635          (script-form (when (symbolp name) (get-script-special-form name))))
 636     (cond
 637       ((eql name 'quote)       (make-instance 'script-quote :value (first args)))
 638       (script-form             (apply script-form args))
 639       ((ps-js::op-form-p form)
 640        (make-instance 'ps-js::op-form
 641                       :operator (ps-js::script-convert-op-name (compile-to-symbol (first form)))
 642                       :args (mapcar #'compile-to-expression (rest form))))
 643       ((method-call-p form)
 644        (make-instance 'ps-js::method-call
 645                       :method (compile-to-symbol name)
 646                       :object (compile-to-expression (first args))
 647                       :args (compile-function-argument-forms (rest args))))
 648       ((funcall-form-p form)
 649        (make-instance 'ps-js::function-call
 650                       :function (compile-to-expression name)
 651                       :args (compile-function-argument-forms args)))
 652       (t (error "Unknown form ~S" form)))))
 653
 654 (defun compile-script-form (form &key (comp-env *compilation-environment*))
 655   "Compiles a Parenscript form to an AST node."
 656   (compile-parenscript-form comp-env form))
 657
 658 (defun compile-to-expression (form)
 659   "Compiles the given Parenscript form and guarantees the result is an expression."
 660   (let ((res (compile-script-form form)))
 661     (assert (typep res 'ps-js::expression) ()
 662             "Error: ~s was expected to compile to a ParenScript expression, but instead compiled to ~s, which has type ~s"
 663             form res (type-of res))
 664     res))
 665
 666 (defun compile-to-symbol (form)
 667   "Compiles the given Parenscript form and guarantees a symbolic result.  This
 668 also guarantees that the symbol has an associated script-package."
 669   (let ((res (compile-script-form form)))
 670     (when (typep res 'ps-js::js-variable)
 671       (setf res (ps-js::value res)))
 672     (when (typep res 'ps-js::script-quote)
 673       (setf res (ps-js::value res)))
 674     (assert (symbolp res) ()
 675             "~a is expected to be a symbol, but compiles to ~a (the ParenScript output for ~a alone is \"~a\"). This could be due to ~a being a special form." form res form (ps::ps* form) form)
 676     (unless (symbol-script-package res)
 677       (when *warn-ps-package*
 678         (warn 'simple-style-warning
 679               :format-control "The symbol ~A::~A has no associated script package."
 680               :format-arguments (list (if (symbol-package res) (package-name (symbol-package res)) "ANONYMOUS-PACKAGE")
 681                                       res))))
 682     res))
 683
 684 (defun compile-to-statement (form)
 685   "Compiles the given Parenscript form and guarantees the result is a statement."
 686   (let ((res (compile-script-form form)))
 687     (assert (typep res 'ps-js::statement))
 688     res))
 689
 690 (defun compile-to-block (form &key (indent ""))
 691   "Compiles the given Parenscript form and guarantees the result is of type SCRIPT-BODY"
 692   (let ((res (compile-to-statement form)))
 693     (if (typep res 'ps-js::js-block)
 694         (progn (setf (ps-js::block-indent res) indent)
 695                res)
 696         (make-instance 'ps-js::js-block
 697                        :indent indent
 698                        :statements (list res)))))