| 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 symbol-name of the macro, value |
| 373 | is (symbol-macro-p . expansion-function).") |
| 374 | (defvar *script-macro-env* (list *script-macro-toplevel*) ;(list nil) |
| 375 | "Current macro environment.") |
| 376 | |
| 377 | (defun find-macro-spec (name env-dict) |
| 378 | (if *enable-package-system* |
| 379 | (gethash name env-dict) |
| 380 | (with-hash-table-iterator (next-entry env-dict) |
| 381 | (loop |
| 382 | (multiple-value-bind (exists? macro-name spec) |
| 383 | (next-entry) |
| 384 | (if exists? |
| 385 | (when (equal (string macro-name) (string name)) |
| 386 | (return spec)) |
| 387 | (return nil))))))) |
| 388 | (defsetf find-macro-spec (name env-dict) |
| 389 | (spec) |
| 390 | `(setf (gethash ,name ,env-dict) ,spec))) |
| 391 | |
| 392 | |
| 393 | (defmacro get-macro-spec (name env-dict) |
| 394 | "Retrieves the macro spec of the given name with the given environment dictionary. |
| 395 | SPEC is of the form (symbol-macro-op expansion-function)." |
| 396 | `(find-macro-spec ,name ,env-dict)) |
| 397 | |
| 398 | (defun lookup-macro-spec (name &optional (environment *script-macro-env*)) |
| 399 | "Looks up the macro spec associated with NAME in the given environment. A |
| 400 | macro spec is of the form (symbol-macro-p function). Returns two values: |
| 401 | the SPEC and the parent macro environment. |
| 402 | |
| 403 | NAME must be a symbol." |
| 404 | (when (symbolp name) |
| 405 | (do ((env environment (cdr env))) |
| 406 | ((null env) nil) |
| 407 | (let ((val (get-macro-spec name (car env)))) |
| 408 | (when val |
| 409 | (return-from lookup-macro-spec |
| 410 | (values val (or (cdr env) |
| 411 | (list *script-macro-toplevel*))))))))) |
| 412 | |
| 413 | (defun script-symbol-macro-p (name &optional (environment *script-macro-env*)) |
| 414 | "True if there is a Parenscript symbol macro named by the symbol NAME." |
| 415 | (and (symbolp name) (car (lookup-macro-spec name environment)))) |
| 416 | |
| 417 | (defun script-macro-p (name &optional (environment *script-macro-env*)) |
| 418 | "True if there is a Parenscript macro named by the symbol NAME." |
| 419 | (and (symbolp name) |
| 420 | (let ((macro-spec (lookup-macro-spec name environment))) |
| 421 | (and macro-spec (not (car macro-spec)))))) |
| 422 | |
| 423 | (defun lookup-macro-expansion-function (name &optional (environment *script-macro-env*)) |
| 424 | "Lookup NAME in the given macro expansion environment (which |
| 425 | defaults to the current macro environment). Returns the expansion |
| 426 | function and the parent macro environment of the macro." |
| 427 | (multiple-value-bind (macro-spec parent-env) |
| 428 | (lookup-macro-spec name environment) |
| 429 | (values (cdr macro-spec) parent-env))) |
| 430 | |
| 431 | (defmacro defscriptmacro (name args &body body) |
| 432 | "Define a ParenScript macro, and store it in the toplevel ParenScript |
| 433 | macro environment." |
| 434 | (let ((lambda-list (gensym "ps-lambda-list-")) |
| 435 | (body (if (and (cdr body) (stringp (first body))) (rest body) body))) ;; drop docstring |
| 436 | (undefine-script-special-form name) |
| 437 | `(setf (get-macro-spec ',name *script-macro-toplevel*) |
| 438 | (cons nil (lambda (&rest ,lambda-list) |
| 439 | (destructuring-bind ,args |
| 440 | ,lambda-list |
| 441 | ,@body)))))) |
| 442 | |
| 443 | (defmacro define-script-symbol-macro (name &body body) |
| 444 | "Define a ParenScript symbol macro, and store it in the toplevel ParenScript |
| 445 | macro environment. BODY is a Lisp form that should return a ParenScript form." |
| 446 | (let ((body (if (and (cdr body) (stringp (first body))) (rest body) body))) ;; drop docstring |
| 447 | (undefine-script-special-form name) |
| 448 | `(setf (get-macro-spec ',name *script-macro-toplevel*) |
| 449 | (cons t (lambda () ,@body))))) |
| 450 | |
| 451 | (defun import-macros-from-lisp (&rest names) |
| 452 | "Import the named Lisp macros into the ParenScript macro |
| 453 | environment. When the imported macro is macroexpanded by ParenScript, |
| 454 | it is first fully macroexpanded in the Lisp macro environment, and |
| 455 | then that expansion is further expanded by ParenScript." |
| 456 | (dolist (name names) |
| 457 | (let ((name name)) |
| 458 | (undefine-script-special-form name) |
| 459 | (setf (get-macro-spec name *script-macro-toplevel*) |
| 460 | (cons nil (lambda (&rest args) |
| 461 | (macroexpand `(,name ,@args)))))))) |
| 462 | |
| 463 | (defmacro defmacro/ps (name args &body body) |
| 464 | "Define a Lisp macro and import it into the ParenScript macro environment." |
| 465 | `(progn (defmacro ,name ,args ,@body) |
| 466 | (ps:import-macros-from-lisp ',name))) |
| 467 | |
| 468 | (defmacro defmacro+ps (name args &body body) |
| 469 | "Define a Lisp macro and a ParenScript macro in their respective |
| 470 | macro environments. This function should be used when you want to use |
| 471 | the same macro in both Lisp and ParenScript, but the 'macroexpand' of |
| 472 | that macro in Lisp makes the Lisp macro unsuitable to be imported into |
| 473 | the ParenScript macro environment." |
| 474 | `(progn (defmacro ,name ,args ,@body) |
| 475 | (defscriptmacro ,name ,args ,@body))) |
| 476 | |
| 477 | (defmacro defpsmacro (&rest args) |
| 478 | `(defscriptmacro ,@args)) |
| 479 | |
| 480 | (defun expand-script-form (expr) |
| 481 | "Expands a Parenscript form until it reaches a special form. Returns 2 values: |
| 482 | 1. the expanded form. |
| 483 | 2. whether the form was expanded." |
| 484 | (if (consp expr) |
| 485 | (let ((op (car expr)) |
| 486 | (args (cdr expr))) |
| 487 | (cond ((equal op 'quote) |
| 488 | (values |
| 489 | (if (equalp '(nil) args) nil expr) ;; leave quotes alone, unless it's a quoted nil |
| 490 | nil)) |
| 491 | ((script-macro-p op) ;; recursively expand parenscript macros in parent env. |
| 492 | (multiple-value-bind (expansion-function macro-env) |
| 493 | (lookup-macro-expansion-function op) |
| 494 | (values |
| 495 | (expand-script-form (let ((*script-macro-env* macro-env)) |
| 496 | (apply expansion-function args))) |
| 497 | t))) |
| 498 | (t (values expr nil)))) |
| 499 | ;; not a cons |
| 500 | (cond ((script-special-form-p expr) |
| 501 | ;; leave special forms alone (expanded during compile) |
| 502 | (values expr nil)) |
| 503 | ((script-symbol-macro-p expr) |
| 504 | ;; recursively expand symbol macros in parent env. |
| 505 | (multiple-value-bind (expansion-function macro-env) |
| 506 | (lookup-macro-expansion-function expr) |
| 507 | (values |
| 508 | (expand-script-form (let ((*script-macro-env* macro-env)) |
| 509 | (funcall expansion-function))) |
| 510 | t))) |
| 511 | ;; leave anything else alone |
| 512 | (t (values expr nil))))) |
| 513 | |
| 514 | (defun process-eval-when-args (args) |
| 515 | "(eval-when form-language? (situation*) form*) - returns 3 values: |
| 516 | form-language, a list of situations, and a list of body forms" |
| 517 | (let* ((rest args) |
| 518 | (form-language |
| 519 | (when (not (listp (first rest))) |
| 520 | (setf rest (rest args)) |
| 521 | (first args))) |
| 522 | (situations (first rest)) |
| 523 | (body (rest rest))) |
| 524 | (when (and (find :compile-toplevel situations) (find :execute situations)) |
| 525 | (error "Cannot use EVAL-WHEN to execute COMPILE-TOPLEVEL and EXECUTE code simultaneously.")) |
| 526 | (when (null form-language) |
| 527 | (setf form-language |
| 528 | (cond |
| 529 | ((find :compile-toplevel situations) :lisp) |
| 530 | ((find :execute situations) :parenscript)))) |
| 531 | (values form-language situations body))) |
| 532 | |
| 533 | ;;;; compiler interface ;;;; |
| 534 | (defgeneric compile-parenscript-form (compilation-environment form) |
| 535 | (:documentation "Compiles FORM, which is a ParenScript form. |
| 536 | If toplevel-p is NIL, the result is a compilation object (the AST root). |
| 537 | Subsequently TRANSLATE-AST can be called to convert the result to Javascript. |
| 538 | |
| 539 | If the compiler is in the COMPILE-TOPLEVEL stage, then the result will |
| 540 | be a Parenscript form (after it has been processed according to semantics |
| 541 | like those of Lisp's COMPILE-FILE). See |
| 542 | http://www.lispworks.com/documentation/HyperSpec/Body/03_bca.htm")) |
| 543 | |
| 544 | (defgeneric compile-toplevel-parenscript-form (comp-env form) |
| 545 | (:documentation "Compiles a parenscript form in the given compilation environment |
| 546 | when the environment is in the :compile-toplevel situation. Returns a form to be |
| 547 | compiled in place of the original form upon exiting the :compile-toplevel situation.")) |
| 548 | |
| 549 | (defmethod compile-toplevel-parenscript-form ((comp-env compilation-environment) form) |
| 550 | (cond |
| 551 | ((not (listp form)) form) |
| 552 | ;; process each clause of a progn as a toplevel form |
| 553 | ((eql 'progn (car form)) |
| 554 | `(progn |
| 555 | ,@(mapcar #'(lambda (subform) |
| 556 | (compile-parenscript-form comp-env subform)) |
| 557 | (rest form)))) |
| 558 | ;; TODO process macrolets, symbol-macrolets, and file inclusions |
| 559 | |
| 560 | ;; process eval-when. evaluates in :COMPILE-TOPLEVEL situation and returns |
| 561 | ;; the resultant form. for :EXECUTE situation it returns |
| 562 | ((eql 'eval-when (car form)) |
| 563 | (multiple-value-bind (body-language situations body) |
| 564 | (process-eval-when-args (rest form)) |
| 565 | (cond |
| 566 | ((find :compile-toplevel situations) |
| 567 | (when (eql body-language :lisp) |
| 568 | (let ((other-situations (remove :compile-toplevel situations))) |
| 569 | (multiple-value-bind (function warnings-p failure-p) |
| 570 | (compile nil `(lambda () ,@body)) |
| 571 | (declare (ignore warnings-p) (ignore failure-p)) |
| 572 | (compile-parenscript-form |
| 573 | comp-env |
| 574 | `(progn |
| 575 | ,(funcall function) |
| 576 | ,@(when other-situations |
| 577 | (list `(eval-when ,other-situations ,@body))))))))) |
| 578 | ;; if :compile-toplevel is not in the situation list, return the form |
| 579 | (t form)))) |
| 580 | (t form))) |
| 581 | |
| 582 | |
| 583 | (defmethod compile-parenscript-form :around ((comp-env compilation-environment) form) |
| 584 | (multiple-value-bind (expanded-form expanded-p) |
| 585 | (expand-script-form form) |
| 586 | (cond |
| 587 | (expanded-p |
| 588 | (compile-parenscript-form comp-env expanded-form)) |
| 589 | ((comp-env-compiling-toplevel-p comp-env) |
| 590 | (compile-toplevel-parenscript-form comp-env form)) |
| 591 | (t (call-next-method))))) |
| 592 | |
| 593 | (defmethod compile-parenscript-form ((comp-env compilation-environment) (form string)) |
| 594 | (make-instance 'ps-js::string-literal :value form)) |
| 595 | |
| 596 | (defmethod compile-parenscript-form ((comp-env compilation-environment) (form character)) |
| 597 | (compile-parenscript-form comp-env (string form))) |
| 598 | |
| 599 | (defmethod compile-parenscript-form ((comp-env compilation-environment) (form number)) |
| 600 | (make-instance 'ps-js::number-literal :value form)) |
| 601 | |
| 602 | (defmethod compile-parenscript-form ((comp-env compilation-environment) (form symbol)) |
| 603 | ;; is this the correct behavior? |
| 604 | (let ((c-macro (get-script-special-form form))) |
| 605 | (cond |
| 606 | (c-macro (funcall c-macro)) |
| 607 | ;; the following emulates the lisp behavior that a keyword is bound to itself |
| 608 | ;; see http://clhs.lisp.se/Body/t_kwd.htm |
| 609 | ((keywordp form) (compile-parenscript-form comp-env `(quote ,form))) |
| 610 | (t (make-instance 'ps-js::js-variable :value form))))) |
| 611 | |
| 612 | (defun compile-function-argument-forms (forms) |
| 613 | "Compiles a bunch of Parenscript forms from a funcall form to an effective set of |
| 614 | Javascript arguments. The only extra processing this does is makes :keyword arguments |
| 615 | into a single options argument via CREATE." |
| 616 | (flet ((keyword-arg (arg) |
| 617 | "If the given compiled expression is supposed to be a keyword argument, returns |
| 618 | the keyword for it." |
| 619 | (when (typep arg 'script-quote) (ps-js::value arg)))) |
| 620 | (let ((expressions (mapcar #'compile-to-expression forms))) |
| 621 | |
| 622 | (do ((effective-expressions nil) |
| 623 | (expressions-subl expressions)) |
| 624 | |
| 625 | ((not expressions-subl) |
| 626 | (nreverse effective-expressions)) |
| 627 | |
| 628 | (let ((arg-expr (first expressions-subl))) |
| 629 | (if (keyword-arg arg-expr) |
| 630 | (progn |
| 631 | (when (oddp (length expressions-subl)) |
| 632 | (error "Odd number of keyword arguments.")) |
| 633 | (push |
| 634 | (make-instance 'ps-js::js-object |
| 635 | :slots |
| 636 | (loop for (name val) on expressions-subl by #'cddr |
| 637 | collect (list name val))) |
| 638 | effective-expressions) |
| 639 | (setf expressions-subl nil)) |
| 640 | (progn |
| 641 | (push arg-expr effective-expressions) |
| 642 | (setf expressions-subl (rest expressions-subl))))))))) |
| 643 | |
| 644 | (defmethod compile-parenscript-form ((comp-env compilation-environment) (form cons)) |
| 645 | (let* ((name (car form)) |
| 646 | (args (cdr form)) |
| 647 | (script-form (get-script-special-form name))) |
| 648 | (cond |
| 649 | ((eql name 'quote) (make-instance 'script-quote :value (first args))) |
| 650 | (script-form (apply script-form args)) |
| 651 | ((ps-js::op-form-p form) |
| 652 | (make-instance 'ps-js::op-form |
| 653 | :operator (ps-js::script-convert-op-name (compile-to-symbol (first form))) |
| 654 | :args (mapcar #'compile-to-expression (rest form)))) |
| 655 | ((method-call-p form) |
| 656 | (make-instance 'ps-js::method-call |
| 657 | :method (compile-to-symbol name) |
| 658 | :object (compile-to-expression (first args)) |
| 659 | :args (compile-function-argument-forms (rest args)))) |
| 660 | ((funcall-form-p form) |
| 661 | (make-instance 'ps-js::function-call |
| 662 | :function (compile-to-expression name) |
| 663 | :args (compile-function-argument-forms args))) |
| 664 | (t (error "Unknown form ~S" form))))) |
| 665 | |
| 666 | (defun compile-script-form (form &key (comp-env *compilation-environment*)) |
| 667 | "Compiles a Parenscript form to an AST node." |
| 668 | (compile-parenscript-form comp-env form)) |
| 669 | |
| 670 | (defun compile-to-expression (form) |
| 671 | "Compiles the given Parenscript form and guarantees the result is an expression." |
| 672 | (let ((res (compile-script-form form))) |
| 673 | (assert (typep res 'ps-js::expression)) |
| 674 | res)) |
| 675 | |
| 676 | (defun compile-to-symbol (form) |
| 677 | "Compiles the given Parenscript form and guarantees a symbolic result. This |
| 678 | also guarantees that the symbol has an associated script-package." |
| 679 | (let ((res (compile-script-form form))) |
| 680 | (when (typep res 'ps-js::js-variable) |
| 681 | (setf res (ps-js::value res))) |
| 682 | (assert (symbolp res) () |
| 683 | "~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) |
| 684 | (when *enable-package-system* |
| 685 | (assert (symbol-script-package res) () |
| 686 | "The symbol ~A::~A has no associated script package." |
| 687 | (if (symbol-package res) (package-name (symbol-package res)) "ANONYMOUS-PACKAGE") |
| 688 | res)) |
| 689 | res)) |
| 690 | |
| 691 | (defun compile-to-statement (form) |
| 692 | "Compiles the given Parenscript form and guarantees the result is a statement." |
| 693 | (let ((res (compile-script-form form))) |
| 694 | (assert (typep res 'ps-js::statement)) |
| 695 | res)) |
| 696 | |
| 697 | (defun compile-to-block (form &key (indent "")) |
| 698 | "Compiles the given Parenscript form and guarantees the result is of type SCRIPT-BODY" |
| 699 | (let ((res (compile-to-statement form))) |
| 700 | (if (typep res 'ps-js::js-block) |
| 701 | (progn (setf (ps-js::block-indent res) indent) |
| 702 | res) |
| 703 | (make-instance 'ps-js::js-block |
| 704 | :indent indent |
| 705 | :statements (list res))))) |