src/parser.lisp

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