src/ps-macrology.lisp

   1 (in-package :parenscript)
   2
   3 ;;;; The macrology of the Parenscript language.  Special forms and macros.
   4
   5 ;;; parenscript gensyms
   6 (defvar *gen-script-name-counter* 0)
   7
   8 (defun gen-script-name-string (&key (prefix "_js_"))
   9   "Generates a unique valid javascript identifier ()"
  10   (concatenate 'string
  11                prefix (princ-to-string (incf *gen-script-name-counter*))))
  12
  13 (defun gen-script-name (&key (prefix "_ps_"))
  14   "Generate a new javascript identifier."
  15   (intern (gen-script-name-string :prefix prefix)
  16           (find-package :js)))
  17
  18 (defmacro gen-ps-name (&rest args)
  19   `(gen-script-name ,@args))
  20
  21 (defmacro with-unique-ps-names (symbols &body body)
  22   "Evaluate BODY with the variables on SYMBOLS bound to new javascript identifiers.
  23
  24 Each element of SYMBOLS is either a symbol or a list of (symbol
  25 prefix)."
  26   `(let* ,(mapcar (lambda (symbol)
  27                     (destructuring-bind (symbol &optional prefix)
  28                         (if (consp symbol)
  29                             symbol
  30                             (list symbol))
  31                       (if prefix
  32                           `(,symbol (gen-script-name :prefix ,prefix))
  33                           `(,symbol (gen-script-name)))))
  34                   symbols)
  35      ,@body))
  36
  37 (defvar *var-counter* 0)
  38
  39 (defun script-gensym (&optional (name "js"))
  40   (intern (format nil "tmp-~A-~A" name (incf *var-counter*)) #.*package*))
  41
  42 ;;; array literals
  43 (defscriptmacro list (&rest values)
  44   `(array ,@values))
  45
  46 (defscriptmacro make-array (&rest inits)
  47   `(new (*array ,@inits)))
  48
  49 ;;; eval-when
  50 (define-script-special-form eval-when (&rest args)
  51   "(eval-when form-language? (situation*) form*)
  52
  53 The given forms are evaluated only during the given SITUATION in the specified
  54 FORM-LANGUAGE (either :lisp or :parenscript, def, defaulting to :lisp during
  55 -toplevel and :parenscript during :execute). The accepted SITUATIONS are :execute,
  56 :scan-toplevel. :scan-toplevel is the phase of compilation when function definitions
  57 and the like are being added to the compilation environment. :execute is the phase when
  58 the code is being evaluated by a Javascript engine."
  59   (multiple-value-bind (body-language situations subforms)
  60       (process-eval-when-args args)
  61 ;    (format t "~A~%~A~%"
  62 ;          (and (compiler-in-situation-p *compilation-environment* :compile-toplevel)
  63 ;               (find :compile-toplevel situations))
  64 ;          (compiler-in-situation-p *compilation-environment*  :execute)
  65 ;           (find :execute situations))
  66     (cond
  67       ((and (compiler-in-situation-p *compilation-environment* :compile-toplevel)
  68             (find :compile-toplevel situations))
  69        (error "Should never be processing eval-when :COMPILE-TOPLEVEL forms from here."))
  70
  71       ((and (compiler-in-situation-p *compilation-environment*  :execute)
  72             (find :execute situations))
  73        (when (eql body-language :parenscript)
  74          (let ((form `(progn ,@subforms)))
  75 ;          (format t "Form: ~A~%" form)
  76            (compile-to-statement form)))))))
  77
  78 ;;; script packages
  79 (defscriptmacro defpackage (name &rest options)
  80   "Defines a Parenscript package."
  81   (labels ((opt-name (opt) (if (listp opt) (car opt) opt)))
  82   (let ((nicknames nil) (lisp-package nil) (secondary-lisp-packages nil)
  83         (exports nil) (used-packages nil) (documentation nil))
  84     (dolist (opt options)
  85       (case (opt-name opt)
  86         (:lisp-package (setf lisp-package (second opt)))
  87         (:nicknames (setf nicknames (rest opt)))
  88         (:secondary-lisp-packages secondary-lisp-packages t)
  89         (:export (setf exports (rest opt)))
  90         (:use (setf used-packages (rest opt)))
  91         (:documentation (setf documentation (second opt)))
  92         (t (error "Unknown option in DEFPACKAGE: ~A" (opt-name opt)))))
  93 ;    (format t "Exports: ~A~%" exports)
  94     (create-script-package
  95      *compilation-environment*
  96      :name name
  97      :nicknames nicknames
  98      :secondary-lisp-packages secondary-lisp-packages
  99      :used-packages used-packages
 100      :lisp-package lisp-package
 101      :exports exports
 102      :documentation documentation)))
 103   `(progn))
 104
 105 (defscriptmacro in-package (package-designator)
 106   "Changes the current script package in the parenscript compilation environment.  This mostly
 107 affects the reader and how it interns non-prefixed symbols"
 108   (let ((script-package
 109          (find-script-package package-designator *compilation-environment*)))
 110     (when (null script-package)
 111       (error "~A does not designate any script package.  Available script package: ~A"
 112              package-designator
 113              (mapcar #'script-package-name (comp-env-script-packages *compilation-environment*))))
 114     (setf (comp-env-current-package *compilation-environment*)
 115           script-package)
 116     `(progn)))
 117
 118 (defscriptmacro case (value &rest clauses)
 119   (labels ((make-clause (val body more)
 120              (cond ((listp val)
 121                     (append (mapcar #'list (butlast val))
 122                             (make-clause (first (last val)) body more)))
 123                    ((member val '(t otherwise))
 124                     (make-clause 'default body more))
 125                    (more `((,val ,@body break)))
 126                    (t `((,val ,@body))))))
 127     `(switch ,value ,@(mapcon #'(lambda (x)
 128                                   (make-clause (car (first x))
 129                                                (cdr (first x))
 130                                                (rest x)))
 131                               clauses))))
 132
 133 ;;; let
 134 (define-script-special-form let (decls &rest body)
 135   (let ((defvars (mapcar #'(lambda (decl)
 136                              (if (atom decl)
 137                                  (make-instance 'ps-js::js-defvar
 138                                        :names (list (compile-to-symbol decl))
 139                                        :value nil)
 140                                  (let ((name (first decl))
 141                                        (value (second decl)))
 142                                    (make-instance 'ps-js::js-defvar
 143                                                   :names (list (compile-to-symbol name))
 144                                                   :value (compile-to-expression value)))))
 145                          decls)))
 146     (make-instance 'ps-js::js-sub-block
 147                    :indent "  "
 148                    :statements (nconc defvars
 149                                  (mapcar #'compile-to-statement body)))))
 150
 151 ;;; iteration
 152 (defscriptmacro dotimes (iter &rest body)
 153   (let ((var (first iter))
 154         (times (second iter)))
 155   `(do ((,var 0 (1+ ,var)))
 156        ((>= ,var ,times))
 157      ,@body)))
 158
 159 (defscriptmacro dolist (i-array &rest body)
 160   (let ((var (first i-array))
 161         (array (second i-array))
 162         (arrvar (script-gensym "arr"))
 163         (idx (script-gensym "i")))
 164     `(let ((,arrvar ,array))
 165       (do ((,idx 0 (1+ ,idx)))
 166           ((>= ,idx (slot-value ,arrvar 'length)))
 167         (let ((,var (aref ,arrvar ,idx)))
 168           ,@body)))))
 169
 170 ;;; macros
 171 (defmacro with-temp-macro-environment ((var) &body body)
 172   `(let* ((,var (make-macro-env-dictionary))
 173           (*script-macro-env* (cons ,var *script-macro-env*)))
 174     ,@body))
 175
 176 (define-script-special-form macrolet (macros &body body)
 177   (with-temp-macro-environment (macro-env-dict)
 178     (dolist (macro macros)
 179       (destructuring-bind (name arglist &body body)
 180           macro
 181         (setf (get-macro-spec name macro-env-dict)
 182               (cons nil (let ((args (gensym "ps-macrolet-args-")))
 183                           (compile nil `(lambda (&rest ,args)
 184                                          (destructuring-bind ,arglist
 185                                              ,args
 186                                            ,@body))))))))
 187     (compile-script-form `(progn ,@body))))
 188
 189 (define-script-special-form symbol-macrolet (symbol-macros &body body)
 190   (with-temp-macro-environment (macro-env-dict)
 191     (dolist (macro symbol-macros)
 192       (destructuring-bind (name &body expansion)
 193           macro
 194         (setf (get-macro-spec name macro-env-dict)
 195               (cons t (compile nil `(lambda () ,@expansion))))))
 196     (compile-script-form `(progn ,@body))))
 197
 198 (defscriptmacro defmacro (name args &body body)
 199   `(lisp (defscriptmacro ,name ,args ,@body) nil))
 200
 201 (defscriptmacro lisp (&body forms)
 202   "Evaluates the given forms in Common Lisp at ParenScript
 203 macro-expansion time. The value of the last form is treated as a
 204 ParenScript expression and is inserted into the generated Javascript
 205 \(use nil for no-op)."
 206   (eval (cons 'progn forms)))
 207
 208
 209 (defscriptmacro rebind (variables expression)
 210   "Creates a new js lexical environment and copies the given
 211   variable(s) there.  Executes the body in the new environment. This
 212   has the same effect as a new (let () ...) form in lisp but works on
 213   the js side for js closures."
 214   (unless (listp variables)
 215     (setf variables (list variables)))
 216   `((lambda ()
 217       (let ((new-context (new *object)))
 218         ,@(loop for variable in variables
 219                 do (setf variable (symbol-to-js variable))
 220                 collect `(setf (slot-value new-context ,variable) (slot-value this ,variable)))
 221         (with new-context
 222               (return ,expression))))))