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