src/compiler.lisp

   1 ;;; compiler.lisp ---
   2
   3 ;; Copyright (C) 2012, 2013 David Vazquez
   4 ;; Copyright (C) 2012 Raimon Grau
   5
   6 ;; JSCL is free software: you can redistribute it and/or
   7 ;; modify it under the terms of the GNU General Public License as
   8 ;; published by the Free Software Foundation, either version 3 of the
   9 ;; License, or (at your option) any later version.
  10 ;;
  11 ;; JSCL is distributed in the hope that it will be useful, but
  12 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  14 ;; General Public License for more details.
  15 ;;
  16 ;; You should have received a copy of the GNU General Public License
  17 ;; along with JSCL.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 ;;;; Compiler
  20
  21 (/debug "loading compiler.lisp!")
  22
  23 (define-js-macro selfcall (&body body)
  24   `(call (function () ,@body)))
  25
  26 (define-js-macro bool (expr)
  27   `(if ,expr ,(convert t) ,(convert nil)))
  28
  29 (define-js-macro method-call (x method &rest args)
  30   `(call (get ,x ,method) ,@args))
  31
  32 ;;; Translate the Lisp code to Javascript. It will compile the special
  33 ;;; forms. Some primitive functions are compiled as special forms
  34 ;;; too. The respective real functions are defined in the target (see
  35 ;;; the beginning of this file) as well as some primitive functions.
  36
  37 (defun interleave (list element &optional after-last-p)
  38   (unless (null list)
  39     (with-collect
  40       (collect (car list))
  41       (dolist (x (cdr list))
  42         (collect element)
  43         (collect x))
  44       (when after-last-p
  45         (collect element)))))
  46
  47 ;;; Like CODE, but prefix each line with four spaces. Two versions
  48 ;;; of this function are available, because the Ecmalisp version is
  49 ;;; very slow and bootstraping was annoying.
  50
  51 ;;; A Form can return a multiple values object calling VALUES, like
  52 ;;; values(arg1, arg2, ...). It will work in any context, as well as
  53 ;;; returning an individual object. However, if the special variable
  54 ;;; `*multiple-value-p*' is NIL, is granted that only the primary
  55 ;;; value will be used, so we can optimize to avoid the VALUES
  56 ;;; function call.
  57 (defvar *multiple-value-p* nil)
  58
  59 ;;; Environment
  60
  61 (def!struct binding
  62   name
  63   type
  64   value
  65   declarations)
  66
  67 (def!struct lexenv
  68   variable
  69   function
  70   block
  71   gotag)
  72
  73 (defun lookup-in-lexenv (name lexenv namespace)
  74   (find name (ecase namespace
  75                 (variable (lexenv-variable lexenv))
  76                 (function (lexenv-function lexenv))
  77                 (block    (lexenv-block    lexenv))
  78                 (gotag    (lexenv-gotag    lexenv)))
  79         :key #'binding-name))
  80
  81 (defun push-to-lexenv (binding lexenv namespace)
  82   (ecase namespace
  83     (variable (push binding (lexenv-variable lexenv)))
  84     (function (push binding (lexenv-function lexenv)))
  85     (block    (push binding (lexenv-block    lexenv)))
  86     (gotag    (push binding (lexenv-gotag    lexenv)))))
  87
  88 (defun extend-lexenv (bindings lexenv namespace)
  89   (let ((env (copy-lexenv lexenv)))
  90     (dolist (binding (reverse bindings) env)
  91       (push-to-lexenv binding env namespace))))
  92
  93
  94 (defvar *environment* (make-lexenv))
  95 (defvar *variable-counter* 0)
  96
  97 (defun gvarname (symbol)
  98   (declare (ignore symbol))
  99   (incf *variable-counter*)
 100   (make-symbol (concat "v" (integer-to-string *variable-counter*))))
 101
 102 (defun translate-variable (symbol)
 103   (awhen (lookup-in-lexenv symbol *environment* 'variable)
 104     (binding-value it)))
 105
 106 (defun extend-local-env (args)
 107   (let ((new (copy-lexenv *environment*)))
 108     (dolist (symbol args new)
 109       (let ((b (make-binding :name symbol :type 'variable :value (gvarname symbol))))
 110         (push-to-lexenv b new 'variable)))))
 111
 112 ;;; Toplevel compilations
 113 (defvar *toplevel-compilations* nil)
 114
 115 (defun toplevel-compilation (string)
 116   (push string *toplevel-compilations*))
 117
 118 (defun get-toplevel-compilations ()
 119   (reverse *toplevel-compilations*))
 120
 121 (defun %compile-defmacro (name lambda)
 122   (toplevel-compilation (convert `',name))
 123   (let ((binding (make-binding :name name :type 'macro :value lambda)))
 124     (push-to-lexenv binding  *environment* 'function))
 125   name)
 126
 127 (defun global-binding (name type namespace)
 128   (or (lookup-in-lexenv name *environment* namespace)
 129       (let ((b (make-binding :name name :type type :value nil)))
 130         (push-to-lexenv b *environment* namespace)
 131         b)))
 132
 133 (defun claimp (symbol namespace claim)
 134   (let ((b (lookup-in-lexenv symbol *environment* namespace)))
 135     (and b (member claim (binding-declarations b)))))
 136
 137 (defun !proclaim (decl)
 138   (case (car decl)
 139     (special
 140      (dolist (name (cdr decl))
 141        (let ((b (global-binding name 'variable 'variable)))
 142          (push 'special (binding-declarations b)))))
 143     (notinline
 144      (dolist (name (cdr decl))
 145        (let ((b (global-binding name 'function 'function)))
 146          (push 'notinline (binding-declarations b)))))
 147     (constant
 148      (dolist (name (cdr decl))
 149        (let ((b (global-binding name 'variable 'variable)))
 150          (push 'constant (binding-declarations b)))))))
 151
 152 #+jscl
 153 (fset 'proclaim #'!proclaim)
 154
 155 (defun %define-symbol-macro (name expansion)
 156   (let ((b (make-binding :name name :type 'macro :value expansion)))
 157     (push-to-lexenv b *environment* 'variable)
 158     name))
 159
 160 #+jscl
 161 (defmacro define-symbol-macro (name expansion)
 162   `(%define-symbol-macro ',name ',expansion))
 163
 164
 165 ;;; Special forms
 166
 167 (defvar *compilations* nil)
 168
 169 (defmacro define-compilation (name args &body body)
 170   ;; Creates a new primitive `name' with parameters args and
 171   ;; @body. The body can access to the local environment through the
 172   ;; variable *ENVIRONMENT*.
 173   `(push (list ',name (lambda ,args (block ,name ,@body)))
 174          *compilations*))
 175
 176 (define-compilation if (condition true &optional false)
 177   `(if (!== ,(convert condition) ,(convert nil))
 178        ,(convert true *multiple-value-p*)
 179        ,(convert false *multiple-value-p*)))
 180
 181 (defvar *ll-keywords* '(&optional &rest &key))
 182
 183 (defun list-until-keyword (list)
 184   (if (or (null list) (member (car list) *ll-keywords*))
 185       nil
 186       (cons (car list) (list-until-keyword (cdr list)))))
 187
 188 (defun ll-section (keyword ll)
 189   (list-until-keyword (cdr (member keyword ll))))
 190
 191 (defun ll-required-arguments (ll)
 192   (list-until-keyword ll))
 193
 194 (defun ll-optional-arguments-canonical (ll)
 195   (mapcar #'ensure-list (ll-section '&optional ll)))
 196
 197 (defun ll-optional-arguments (ll)
 198   (mapcar #'car (ll-optional-arguments-canonical ll)))
 199
 200 (defun ll-rest-argument (ll)
 201   (let ((rest (ll-section '&rest ll)))
 202     (when (cdr rest)
 203       (error "Bad lambda-list `~S'." ll))
 204     (car rest)))
 205
 206 (defun ll-keyword-arguments-canonical (ll)
 207   (flet ((canonicalize (keyarg)
 208            ;; Build a canonical keyword argument descriptor, filling
 209            ;; the optional fields. The result is a list of the form
 210            ;; ((keyword-name var) init-form svar).
 211            (let ((arg (ensure-list keyarg)))
 212              (cons (if (listp (car arg))
 213                        (car arg)
 214                        (list (intern (symbol-name (car arg)) "KEYWORD") (car arg)))
 215                    (cdr arg)))))
 216     (mapcar #'canonicalize (ll-section '&key ll))))
 217
 218 (defun ll-keyword-arguments (ll)
 219   (mapcar (lambda (keyarg) (second (first keyarg)))
 220           (ll-keyword-arguments-canonical ll)))
 221
 222 (defun ll-svars (lambda-list)
 223   (let ((args
 224          (append
 225           (ll-keyword-arguments-canonical lambda-list)
 226           (ll-optional-arguments-canonical lambda-list))))
 227     (remove nil (mapcar #'third args))))
 228
 229 (defun lambda-name/docstring-wrapper (name docstring code)
 230   (if (or name docstring)
 231       `(selfcall
 232         (var (func ,code))
 233         ,(when name `(= (get func "fname") ,name))
 234         ,(when docstring `(= (get func "docstring") ,docstring))
 235         (return func))
 236       code))
 237
 238 (defun lambda-check-argument-count
 239     (n-required-arguments n-optional-arguments rest-p)
 240   ;; Note: Remember that we assume that the number of arguments of a
 241   ;; call is at least 1 (the values argument).
 242   (let ((min n-required-arguments)
 243         (max (if rest-p 'n/a (+ n-required-arguments n-optional-arguments))))
 244     (block nil
 245       ;; Special case: a positive exact number of arguments.
 246       (when (and (< 0 min) (eql min max))
 247         (return `(call |checkArgs| |nargs| ,min)))
 248       ;; General case:
 249       `(progn
 250          ,(when (< 0 min)     `(call |checkArgsAtLeast| |nargs| ,min))
 251          ,(when (numberp max) `(call |checkArgsAtMost|  |nargs| ,max))))))
 252
 253 (defun compile-lambda-optional (ll)
 254   (let* ((optional-arguments (ll-optional-arguments-canonical ll))
 255          (n-required-arguments (length (ll-required-arguments ll)))
 256          (n-optional-arguments (length optional-arguments)))
 257     (when optional-arguments
 258       `(switch |nargs|
 259                ,@(with-collect
 260                   (dotimes (idx n-optional-arguments)
 261                     (let ((arg (nth idx optional-arguments)))
 262                       (collect `(case ,(+ idx n-required-arguments)))
 263                       (collect `(= ,(translate-variable (car arg))
 264                                    ,(convert (cadr arg))))
 265                       (collect (when (third arg)
 266                                  `(= ,(translate-variable (third arg))
 267                                      ,(convert nil))))))
 268                   (collect 'default)
 269                   (collect '(break)))))))
 270
 271 (defun compile-lambda-rest (ll)
 272   (let ((n-required-arguments (length (ll-required-arguments ll)))
 273         (n-optional-arguments (length (ll-optional-arguments ll)))
 274         (rest-argument (ll-rest-argument ll)))
 275     (when rest-argument
 276       (let ((js!rest (translate-variable rest-argument)))
 277         `(progn
 278            (var (,js!rest ,(convert nil)))
 279            (var i)
 280            (for ((= i (- |nargs| 1))
 281                  (>= i ,(+ n-required-arguments n-optional-arguments))
 282                  (post-- i))
 283                 (= ,js!rest (object "car" (property |arguments| (+ i 2))
 284                                     "cdr" ,js!rest))))))))
 285
 286 (defun compile-lambda-parse-keywords (ll)
 287   (let ((n-required-arguments
 288          (length (ll-required-arguments ll)))
 289         (n-optional-arguments
 290          (length (ll-optional-arguments ll)))
 291         (keyword-arguments
 292          (ll-keyword-arguments-canonical ll)))
 293     `(progn
 294        ;; Declare variables
 295        ,@(with-collect
 296           (dolist (keyword-argument keyword-arguments)
 297             (destructuring-bind ((keyword-name var) &optional initform svar)
 298                 keyword-argument
 299               (declare (ignore keyword-name initform))
 300               (collect `(var ,(translate-variable var)))
 301               (when svar
 302                 (collect
 303                     `(var (,(translate-variable svar)
 304                             ,(convert nil))))))))
 305
 306        ;; Parse keywords
 307        ,(flet ((parse-keyword (keyarg)
 308                 (destructuring-bind ((keyword-name var) &optional initform svar) keyarg
 309                   ;; ((keyword-name var) init-form svar)
 310                   `(progn
 311                      (for ((= i ,(+ n-required-arguments n-optional-arguments))
 312                            (< i |nargs|)
 313                            (+= i 2))
 314                           ;; ....
 315                           (if (=== (property |arguments| (+ i 2))
 316                                    ,(convert keyword-name))
 317                               (progn
 318                                 (= ,(translate-variable var)
 319                                    (property |arguments| (+ i 3)))
 320                                 ,(when svar `(= ,(translate-variable svar)
 321                                                 ,(convert t)))
 322                                 (break))))
 323                      (if (== i |nargs|)
 324                          (= ,(translate-variable var) ,(convert initform)))))))
 325          (when keyword-arguments
 326            `(progn
 327               (var i)
 328               ,@(mapcar #'parse-keyword keyword-arguments))))
 329
 330        ;; Check for unknown keywords
 331        ,(when keyword-arguments
 332          `(progn
 333             (var (start ,(+ n-required-arguments n-optional-arguments)))
 334             (if (== (% (- |nargs| start) 2) 1)
 335                 (throw "Odd number of keyword arguments."))
 336             (for ((= i start) (< i |nargs|) (+= i 2))
 337                  (if (and ,@(mapcar (lambda (keyword-argument)
 338                                  (destructuring-bind ((keyword-name var) &optional initform svar)
 339                                      keyword-argument
 340                                    (declare (ignore var initform svar))
 341                                    `(!== (property |arguments| (+ i 2)) ,(convert keyword-name))))
 342                                keyword-arguments))
 343                      (throw (+ "Unknown keyword argument "
 344                                (call |xstring|
 345                                      (property
 346                                       (property |arguments| (+ i 2))
 347                                       "name")))))))))))
 348
 349 (defun parse-lambda-list (ll)
 350   (values (ll-required-arguments ll)
 351           (ll-optional-arguments ll)
 352           (ll-keyword-arguments  ll)
 353           (ll-rest-argument      ll)))
 354
 355 ;;; Process BODY for declarations and/or docstrings. Return as
 356 ;;; multiple values the BODY without docstrings or declarations, the
 357 ;;; list of declaration forms and the docstring.
 358 (defun parse-body (body &key declarations docstring)
 359   (let ((value-declarations)
 360         (value-docstring))
 361     ;; Parse declarations
 362     (when declarations
 363       (do* ((rest body (cdr rest))
 364             (form (car rest) (car rest)))
 365            ((or (atom form) (not (eq (car form) 'declare)))
 366             (setf body rest))
 367         (push form value-declarations)))
 368     ;; Parse docstring
 369     (when (and docstring
 370                (stringp (car body))
 371                (not (null (cdr body))))
 372       (setq value-docstring (car body))
 373       (setq body (cdr body)))
 374     (values body value-declarations value-docstring)))
 375
 376 ;;; Compile a lambda function with lambda list LL and body BODY. If
 377 ;;; NAME is given, it should be a constant string and it will become
 378 ;;; the name of the function. If BLOCK is non-NIL, a named block is
 379 ;;; created around the body. NOTE: No block (even anonymous) is
 380 ;;; created if BLOCk is NIL.
 381 (defun compile-lambda (ll body &key name block)
 382   (multiple-value-bind (required-arguments
 383                         optional-arguments
 384                         keyword-arguments
 385                         rest-argument)
 386       (parse-lambda-list ll)
 387     (multiple-value-bind (body decls documentation)
 388         (parse-body body :declarations t :docstring t)
 389       (declare (ignore decls))
 390       (let ((n-required-arguments (length required-arguments))
 391             (n-optional-arguments (length optional-arguments))
 392             (*environment* (extend-local-env
 393                             (append (ensure-list rest-argument)
 394                                     required-arguments
 395                                     optional-arguments
 396                                     keyword-arguments
 397                                     (ll-svars ll)))))
 398         (lambda-name/docstring-wrapper name documentation
 399          `(function (|values| |nargs| ,@(mapcar (lambda (x)
 400                                                   (translate-variable x))
 401                                                 (append required-arguments optional-arguments)))
 402                      ;; Check number of arguments
 403                     ,(lambda-check-argument-count n-required-arguments
 404                                                   n-optional-arguments
 405                                                   (or rest-argument keyword-arguments))
 406                     ,(compile-lambda-optional ll)
 407                     ,(compile-lambda-rest ll)
 408                     ,(compile-lambda-parse-keywords ll)
 409
 410                     ,(let ((*multiple-value-p* t))
 411                           (if block
 412                               (convert-block `((block ,block ,@body)) t)
 413                               (convert-block body t)))))))))
 414
 415
 416 (defun setq-pair (var val)
 417   (let ((b (lookup-in-lexenv var *environment* 'variable)))
 418     (cond
 419       ((and b
 420             (eq (binding-type b) 'variable)
 421             (not (member 'special (binding-declarations b)))
 422             (not (member 'constant (binding-declarations b))))
 423        `(= ,(binding-value b) ,(convert val)))
 424       ((and b (eq (binding-type b) 'macro))
 425        (convert `(setf ,var ,val)))
 426       (t
 427        (convert `(set ',var ,val))))))
 428
 429
 430 (define-compilation setq (&rest pairs)
 431   (let ((result nil))
 432     (when (null pairs)
 433       (return-from setq (convert nil)))
 434     (while t
 435       (cond
 436         ((null pairs)
 437          (return))
 438         ((null (cdr pairs))
 439          (error "Odd pairs in SETQ"))
 440         (t
 441          (push `,(setq-pair (car pairs) (cadr pairs)) result)
 442          (setq pairs (cddr pairs)))))
 443     `(progn ,@(reverse result))))
 444
 445
 446 ;;; Compilation of literals an object dumping
 447
 448 ;;; BOOTSTRAP MAGIC: We record the macro definitions as lists during
 449 ;;; the bootstrap. Once everything is compiled, we want to dump the
 450 ;;; whole global environment to the output file to reproduce it in the
 451 ;;; run-time. However, the environment must contain expander functions
 452 ;;; rather than lists. We do not know how to dump function objects
 453 ;;; itself, so we mark the list definitions with this object and the
 454 ;;; compiler will be called when this object has to be dumped.
 455 ;;; Backquote/unquote does a similar magic, but this use is exclusive.
 456 ;;;
 457 ;;; Indeed, perhaps to compile the object other macros need to be
 458 ;;; evaluated. For this reason we define a valid macro-function for
 459 ;;; this symbol.
 460 (defvar *magic-unquote-marker* (gensym "MAGIC-UNQUOTE"))
 461
 462 #-jscl
 463 (setf (macro-function *magic-unquote-marker*)
 464       (lambda (form &optional environment)
 465         (declare (ignore environment))
 466         (second form)))
 467
 468 (defvar *literal-table* nil)
 469 (defvar *literal-counter* 0)
 470
 471 (defun genlit ()
 472   (incf *literal-counter*)
 473   (make-symbol (concat "l" (integer-to-string *literal-counter*))))
 474
 475 (defun dump-symbol (symbol)
 476   #-jscl
 477   (let ((package (symbol-package symbol)))
 478     (if (eq package (find-package "KEYWORD"))
 479         `(new (call |Symbol| ,(dump-string (symbol-name symbol)) ,(dump-string (package-name package))))
 480         `(new (call |Symbol| ,(dump-string (symbol-name symbol))))))
 481   #+jscl
 482   (let ((package (symbol-package symbol)))
 483     (if (null package)
 484         `(new (call |Symbol| ,(dump-string (symbol-name symbol))))
 485         (convert `(intern ,(symbol-name symbol) ,(package-name package))))))
 486
 487 (defun dump-cons (cons)
 488   (let ((head (butlast cons))
 489         (tail (last cons)))
 490     `(call |QIList|
 491            ,@(mapcar (lambda (x) (literal x t)) head)
 492            ,(literal (car tail) t)
 493            ,(literal (cdr tail) t))))
 494
 495 (defun dump-array (array)
 496   (let ((elements (vector-to-list array)))
 497     (list-to-vector (mapcar #'literal elements))))
 498
 499 (defun dump-string (string)
 500   `(call |make_lisp_string| ,string))
 501
 502 (defun literal (sexp &optional recursive)
 503   (cond
 504     ((integerp sexp) sexp)
 505     ((floatp sexp) sexp)
 506     ((characterp sexp) (string sexp))
 507     (t
 508      (or (cdr (assoc sexp *literal-table* :test #'eql))
 509          (let ((dumped (typecase sexp
 510                          (symbol (dump-symbol sexp))
 511                          (string (dump-string sexp))
 512                          (cons
 513                           ;; BOOTSTRAP MAGIC: See the root file
 514                           ;; jscl.lisp and the function
 515                           ;; `dump-global-environment' for futher
 516                           ;; information.
 517                           (if (eq (car sexp) *magic-unquote-marker*)
 518                               (convert (second sexp))
 519                               (dump-cons sexp)))
 520                          (array (dump-array sexp)))))
 521            (if (and recursive (not (symbolp sexp)))
 522                dumped
 523                (let ((jsvar (genlit)))
 524                  (push (cons sexp jsvar) *literal-table*)
 525                  (toplevel-compilation `(var (,jsvar ,dumped)))
 526                  (when (keywordp sexp)
 527                    (toplevel-compilation `(= ,(get jsvar "value") ,jsvar)))
 528                  jsvar)))))))
 529
 530
 531 (define-compilation quote (sexp)
 532   (literal sexp))
 533
 534 (define-compilation %while (pred &rest body)
 535   `(selfcall
 536     (while (!== ,(convert pred) ,(convert nil))
 537       ,(convert-block body))
 538     (return ,(convert nil))))
 539
 540 (define-compilation function (x)
 541   (cond
 542     ((and (listp x) (eq (car x) 'lambda))
 543      (compile-lambda (cadr x) (cddr x)))
 544     ((and (listp x) (eq (car x) 'named-lambda))
 545      (destructuring-bind (name ll &rest body) (cdr x)
 546        (compile-lambda ll body
 547                        :name (symbol-name name)
 548                        :block name)))
 549     ((symbolp x)
 550      (let ((b (lookup-in-lexenv x *environment* 'function)))
 551        (if b
 552            (binding-value b)
 553            (convert `(symbol-function ',x)))))))
 554
 555 (defun make-function-binding (fname)
 556   (make-binding :name fname :type 'function :value (gvarname fname)))
 557
 558 (defun compile-function-definition (list)
 559   (compile-lambda (car list) (cdr list)))
 560
 561 (defun translate-function (name)
 562   (let ((b (lookup-in-lexenv name *environment* 'function)))
 563     (and b (binding-value b))))
 564
 565 (define-compilation flet (definitions &rest body)
 566   (let* ((fnames (mapcar #'car definitions))
 567          (cfuncs (mapcar (lambda (def)
 568                            (compile-lambda (cadr def)
 569                                            `((block ,(car def)
 570                                                ,@(cddr def)))))
 571                          definitions))
 572          (*environment*
 573           (extend-lexenv (mapcar #'make-function-binding fnames)
 574                          *environment*
 575                          'function)))
 576     `(call (function ,(mapcar #'translate-function fnames)
 577                 ,(convert-block body t))
 578            ,@cfuncs)))
 579
 580 (define-compilation labels (definitions &rest body)
 581   (let* ((fnames (mapcar #'car definitions))
 582          (*environment*
 583           (extend-lexenv (mapcar #'make-function-binding fnames)
 584                          *environment*
 585                          'function)))
 586     `(selfcall
 587       ,@(mapcar (lambda (func)
 588                   `(var (,(translate-function (car func))
 589                           ,(compile-lambda (cadr func)
 590                                            `((block ,(car func) ,@(cddr func)))))))
 591                 definitions)
 592       ,(convert-block body t))))
 593
 594
 595 (defvar *compiling-file* nil)
 596 (define-compilation eval-when-compile (&rest body)
 597   (if *compiling-file*
 598       (progn
 599         (eval (cons 'progn body))
 600         (convert 0))
 601       (convert `(progn ,@body))))
 602
 603 (defmacro define-transformation (name args form)
 604   `(define-compilation ,name ,args
 605      (convert ,form)))
 606
 607 (define-compilation progn (&rest body)
 608   (if (null (cdr body))
 609       (convert (car body) *multiple-value-p*)
 610       `(progn
 611          ,@(append (mapcar #'convert (butlast body))
 612                    (list (convert (car (last body)) t))))))
 613
 614 (define-compilation macrolet (definitions &rest body)
 615   (let ((*environment* (copy-lexenv *environment*)))
 616     (dolist (def definitions)
 617       (destructuring-bind (name lambda-list &body body) def
 618         (let ((binding (make-binding :name name :type 'macro :value
 619                                      (let ((g!form (gensym)))
 620                                        `(lambda (,g!form)
 621                                           (destructuring-bind ,lambda-list ,g!form
 622                                             ,@body))))))
 623           (push-to-lexenv binding  *environment* 'function))))
 624     (convert `(progn ,@body) *multiple-value-p*)))
 625
 626
 627 (defun special-variable-p (x)
 628   (and (claimp x 'variable 'special) t))
 629
 630 ;;; Wrap CODE to restore the symbol values of the dynamic
 631 ;;; bindings. BINDINGS is a list of pairs of the form
 632 ;;; (SYMBOL . PLACE),  where PLACE is a Javascript variable
 633 ;;; name to initialize the symbol value and where to stored
 634 ;;; the old value.
 635 (defun let-binding-wrapper (bindings body)
 636   (when (null bindings)
 637     (return-from let-binding-wrapper body))
 638   `(progn
 639      (try (var tmp)
 640           ,@(with-collect
 641              (dolist (b bindings)
 642                (let ((s (convert `',(car b))))
 643                  (collect `(= tmp (get ,s "value")))
 644                  (collect `(= (get ,s "value") ,(cdr b)))
 645                  (collect `(= ,(cdr b) tmp)))))
 646           ,body)
 647      (finally
 648       ,@(with-collect
 649          (dolist (b bindings)
 650            (let ((s (convert `(quote ,(car b)))))
 651              (collect `(= (get ,s "value") ,(cdr b)))))))))
 652
 653 (define-compilation let (bindings &rest body)
 654   (let* ((bindings (mapcar #'ensure-list bindings))
 655          (variables (mapcar #'first bindings))
 656          (cvalues (mapcar #'convert (mapcar #'second bindings)))
 657          (*environment* (extend-local-env (remove-if #'special-variable-p variables)))
 658          (dynamic-bindings))
 659     `(call (function ,(mapcar (lambda (x)
 660                                 (if (special-variable-p x)
 661                                     (let ((v (gvarname x)))
 662                                       (push (cons x v) dynamic-bindings)
 663                                       v)
 664                                     (translate-variable x)))
 665                               variables)
 666                      ,(let ((body (convert-block body t t)))
 667                            `,(let-binding-wrapper dynamic-bindings body)))
 668            ,@cvalues)))
 669
 670
 671 ;;; Return the code to initialize BINDING, and push it extending the
 672 ;;; current lexical environment if the variable is not special.
 673 (defun let*-initialize-value (binding)
 674   (let ((var (first binding))
 675         (value (second binding)))
 676     (if (special-variable-p var)
 677         (convert `(setq ,var ,value))
 678         (let* ((v (gvarname var))
 679                (b (make-binding :name var :type 'variable :value v)))
 680           (prog1 `(var (,v ,(convert value)))
 681             (push-to-lexenv b *environment* 'variable))))))
 682
 683 ;;; Wrap BODY to restore the symbol values of SYMBOLS after body. It
 684 ;;; DOES NOT generate code to initialize the value of the symbols,
 685 ;;; unlike let-binding-wrapper.
 686 (defun let*-binding-wrapper (symbols body)
 687   (when (null symbols)
 688     (return-from let*-binding-wrapper body))
 689   (let ((store (mapcar (lambda (s) (cons s (gvarname s)))
 690                        (remove-if-not #'special-variable-p symbols))))
 691     `(progn
 692        (try
 693         ,@(mapcar (lambda (b)
 694                     (let ((s (convert `(quote ,(car b)))))
 695                       `(var (,(cdr b) (get ,s "value")))))
 696                   store)
 697         ,body)
 698        (finally
 699         ,@(mapcar (lambda (b)
 700                     (let ((s (convert `(quote ,(car b)))))
 701                       `(= (get ,s "value") ,(cdr b))))
 702                   store)))))
 703
 704 (define-compilation let* (bindings &rest body)
 705   (let ((bindings (mapcar #'ensure-list bindings))
 706         (*environment* (copy-lexenv *environment*)))
 707     (let ((specials (remove-if-not #'special-variable-p (mapcar #'first bindings)))
 708           (body `(progn
 709                    ,@(mapcar #'let*-initialize-value bindings)
 710                    ,(convert-block body t t))))
 711       `(selfcall ,(let*-binding-wrapper specials body)))))
 712
 713
 714 (define-compilation block (name &rest body)
 715   ;; We use Javascript exceptions to implement non local control
 716   ;; transfer. Exceptions has dynamic scoping, so we use a uniquely
 717   ;; generated object to identify the block. The instance of a empty
 718   ;; array is used to distinguish between nested dynamic Javascript
 719   ;; exceptions. See https://github.com/davazp/jscl/issues/64 for
 720   ;; futher details.
 721   (let* ((idvar (gvarname name))
 722          (b (make-binding :name name :type 'block :value idvar)))
 723     (when *multiple-value-p*
 724       (push 'multiple-value (binding-declarations b)))
 725     (let* ((*environment* (extend-lexenv (list b) *environment* 'block))
 726            (cbody (convert-block body t)))
 727       (if (member 'used (binding-declarations b))
 728           `(selfcall
 729             (try
 730              (var (,idvar #()))
 731              ,cbody)
 732             (catch (cf)
 733               (if (and (== (get cf "type") "block")
 734                        (== (get cf "id") ,idvar))
 735                   ,(if *multiple-value-p*
 736                        `(return (method-call |values| "apply" this (call |forcemv| (get cf "values"))))
 737                        `(return (get cf "values")))
 738                   (throw cf))))
 739           ;; TODO: is selfcall necessary here?
 740           `(selfcall ,cbody)))))
 741
 742 (define-compilation return-from (name &optional value)
 743   (let* ((b (lookup-in-lexenv name *environment* 'block))
 744          (multiple-value-p (member 'multiple-value (binding-declarations b))))
 745     (when (null b)
 746       (error "Return from unknown block `~S'." (symbol-name name)))
 747     (push 'used (binding-declarations b))
 748     ;; The binding value is the name of a variable, whose value is the
 749     ;; unique identifier of the block as exception. We can't use the
 750     ;; variable name itself, because it could not to be unique, so we
 751     ;; capture it in a closure.
 752     `(selfcall
 753       ,(when multiple-value-p `(var (|values| |mv|)))
 754       (throw
 755           (object
 756            "type" "block"
 757            "id" ,(binding-value b)
 758            "values" ,(convert value multiple-value-p)
 759            "message" ,(concat "Return from unknown block '" (symbol-name name) "'."))))))
 760
 761 (define-compilation catch (id &rest body)
 762   `(selfcall
 763     (var (|id| ,(convert id)))
 764     (try
 765      ,(convert-block body t))
 766     (catch (|cf|)
 767       (if (and (== (get |cf| "type") "catch")
 768                (== (get |cf| "id") |id|))
 769           ,(if *multiple-value-p*
 770                `(return (method-call |values| "apply" this (call |forcemv| (get |cf| "values"))))
 771                `(return (method-call |pv|     "apply" this (call |forcemv| (get |cf| "values")))))
 772           (throw |cf|)))))
 773
 774 (define-compilation throw (id value)
 775   `(selfcall
 776     (var (|values| |mv|))
 777     (throw (object
 778             |type| "catch"
 779             |id| ,(convert id)
 780             |values| ,(convert value t)
 781             |message| "Throw uncatched."))))
 782
 783 (defun go-tag-p (x)
 784   (or (integerp x) (symbolp x)))
 785
 786 (defun declare-tagbody-tags (tbidx body)
 787   (let* ((go-tag-counter 0)
 788          (bindings
 789           (mapcar (lambda (label)
 790                     (let ((tagidx (incf go-tag-counter)))
 791                       (make-binding :name label :type 'gotag :value (list tbidx tagidx))))
 792                   (remove-if-not #'go-tag-p body))))
 793     (extend-lexenv bindings *environment* 'gotag)))
 794
 795 (define-compilation tagbody (&rest body)
 796   ;; Ignore the tagbody if it does not contain any go-tag. We do this
 797   ;; because 1) it is easy and 2) many built-in forms expand to a
 798   ;; implicit tagbody, so we save some space.
 799   (unless (some #'go-tag-p body)
 800     (return-from tagbody (convert `(progn ,@body nil))))
 801   ;; The translation assumes the first form in BODY is a label
 802   (unless (go-tag-p (car body))
 803     (push (gensym "START") body))
 804   ;; Tagbody compilation
 805   (let ((branch (gvarname 'branch))
 806         (tbidx (gvarname 'tbidx)))
 807     (let ((*environment* (declare-tagbody-tags tbidx body))
 808           initag)
 809       (let ((b (lookup-in-lexenv (first body) *environment* 'gotag)))
 810         (setq initag (second (binding-value b))))
 811       `(selfcall
 812         ;; TAGBODY branch to take
 813         (var (,branch ,initag))
 814         (var (,tbidx #()))
 815         (label tbloop
 816                (while true
 817                  (try
 818                   (switch ,branch
 819                           ,@(with-collect
 820                              (collect `(case ,initag))
 821                              (dolist (form (cdr body))
 822                                (if (go-tag-p form)
 823                                    (let ((b (lookup-in-lexenv form *environment* 'gotag)))
 824                                      (collect `(case ,(second (binding-value b)))))
 825                                    (collect (convert form)))))
 826                           default
 827                           (break tbloop)))
 828                  (catch (jump)
 829                    (if (and (== (get jump "type") "tagbody")
 830                             (== (get jump "id") ,tbidx))
 831                        (= ,branch (get jump "label"))
 832                        (throw jump)))))
 833         (return ,(convert nil))))))
 834
 835 (define-compilation go (label)
 836   (let ((b (lookup-in-lexenv label *environment* 'gotag))
 837         (n (cond
 838              ((symbolp label) (symbol-name label))
 839              ((integerp label) (integer-to-string label)))))
 840     (when (null b)
 841       (error "Unknown tag `~S'" label))
 842     `(selfcall
 843       (throw
 844           (object
 845            "type" "tagbody"
 846            "id" ,(first (binding-value b))
 847            "label" ,(second (binding-value b))
 848            "message" ,(concat "Attempt to GO to non-existing tag " n))))))
 849
 850 (define-compilation unwind-protect (form &rest clean-up)
 851   `(selfcall
 852     (var (|ret| ,(convert nil)))
 853     (try
 854      (= |ret| ,(convert form)))
 855     (finally
 856      ,(convert-block clean-up))
 857     (return |ret|)))
 858
 859 (define-compilation multiple-value-call (func-form &rest forms)
 860   `(selfcall
 861     (var (func ,(convert func-form)))
 862     (var (args ,(vector (if *multiple-value-p* '|values| '|pv|) 0)))
 863     (return
 864       (selfcall
 865        (var (|values| |mv|))
 866        (var vs)
 867        (progn
 868          ,@(with-collect
 869             (dolist (form forms)
 870               (collect `(= vs ,(convert form t)))
 871               (collect `(if (and (=== (typeof vs) "object")
 872                                  (in "multiple-value" vs))
 873                             (= args (method-call args "concat" vs))
 874                             (method-call args "push" vs))))))
 875        (= (property args 1) (- (property args "length") 2))
 876        (return (method-call func "apply" |window| args))))))
 877
 878 (define-compilation multiple-value-prog1 (first-form &rest forms)
 879   `(selfcall
 880     (var (args ,(convert first-form *multiple-value-p*)))
 881     (progn ,@(mapcar #'convert forms))
 882     (return args)))
 883
 884 (define-transformation backquote (form)
 885   (bq-completely-process form))
 886
 887
 888 ;;; Primitives
 889
 890 (defvar *builtins* nil)
 891
 892 (defmacro define-raw-builtin (name args &body body)
 893   ;; Creates a new primitive function `name' with parameters args and
 894   ;; @body. The body can access to the local environment through the
 895   ;; variable *ENVIRONMENT*.
 896   `(push (list ',name (lambda ,args (block ,name ,@body)))
 897          *builtins*))
 898
 899 (defmacro define-builtin (name args &body body)
 900   `(define-raw-builtin ,name ,args
 901      (let ,(mapcar (lambda (arg) `(,arg (convert ,arg))) args)
 902        ,@body)))
 903
 904 ;;; VARIABLE-ARITY compiles variable arity operations. ARGS stands for
 905 ;;; a variable which holds a list of forms. It will compile them and
 906 ;;; store the result in some Javascript variables. BODY is evaluated
 907 ;;; with ARGS bound to the list of these variables to generate the
 908 ;;; code which performs the transformation on these variables.
 909 (defun variable-arity-call (args function)
 910   (unless (consp args)
 911     (error "ARGS must be a non-empty list"))
 912   (let ((counter 0)
 913         (fargs '())
 914         (prelude '()))
 915     (dolist (x args)
 916       (if (or (floatp x) (numberp x))
 917           (push x fargs)
 918           (let ((v (make-symbol (concat "x" (integer-to-string (incf counter))))))
 919             (push v fargs)
 920             (push `(var (,v ,(convert x)))
 921                   prelude)
 922             (push `(if (!= (typeof ,v) "number")
 923                        (throw "Not a number!"))
 924                   prelude))))
 925     `(selfcall
 926       (progn ,@(reverse prelude))
 927       ,(funcall function (reverse fargs)))))
 928
 929
 930 (defmacro variable-arity (args &body body)
 931   (unless (symbolp args)
 932     (error "`~S' is not a symbol." args))
 933   `(variable-arity-call ,args (lambda (,args) `(return  ,,@body))))
 934
 935 (define-raw-builtin + (&rest numbers)
 936   (if (null numbers)
 937       0
 938       (variable-arity numbers
 939         `(+ ,@numbers))))
 940
 941 (define-raw-builtin - (x &rest others)
 942   (let ((args (cons x others)))
 943     (variable-arity args `(- ,@args))))
 944
 945 (define-raw-builtin * (&rest numbers)
 946   (if (null numbers)
 947       1
 948       (variable-arity numbers `(* ,@numbers))))
 949
 950 (define-raw-builtin / (x &rest others)
 951   (let ((args (cons x others)))
 952     (variable-arity args
 953       (if (null others)
 954           `(/ 1 ,(car args))
 955           (reduce (lambda (x y) `(/ ,x ,y))
 956                   args)))))
 957
 958 (define-builtin mod (x y)
 959   `(% ,x ,y))
 960
 961
 962 (defun comparison-conjuntion (vars op)
 963   (cond
 964     ((null (cdr vars))
 965      'true)
 966     ((null (cddr vars))
 967      `(,op ,(car vars) ,(cadr vars)))
 968     (t
 969      `(and (,op ,(car vars) ,(cadr vars))
 970            ,(comparison-conjuntion (cdr vars) op)))))
 971
 972 (defmacro define-builtin-comparison (op sym)
 973   `(define-raw-builtin ,op (x &rest args)
 974      (let ((args (cons x args)))
 975        (variable-arity args
 976          `(bool ,(comparison-conjuntion args ',sym))))))
 977
 978 (define-builtin-comparison > >)
 979 (define-builtin-comparison < <)
 980 (define-builtin-comparison >= >=)
 981 (define-builtin-comparison <= <=)
 982 (define-builtin-comparison = ==)
 983 (define-builtin-comparison /= !=)
 984
 985 (define-builtin numberp (x)
 986   `(bool (== (typeof ,x) "number")))
 987
 988 (define-builtin floor (x)
 989   `(method-call |Math| "floor" ,x))
 990
 991 (define-builtin expt (x y)
 992   `(method-call |Math| "pow" ,x ,y))
 993
 994 (define-builtin float-to-string (x)
 995   `(call |make_lisp_string| (method-call ,x |toString|)))
 996
 997 (define-builtin cons (x y)
 998   `(object "car" ,x "cdr" ,y))
 999
1000 (define-builtin consp (x)
1001   `(selfcall
1002     (var (tmp ,x))
1003     (return (bool (and (== (typeof tmp) "object")
1004                        (in "car" tmp))))))
1005
1006 (define-builtin car (x)
1007   `(selfcall
1008     (var (tmp ,x))
1009     (return (if (=== tmp ,(convert nil))
1010                 ,(convert nil)
1011                 (get tmp "car")))))
1012
1013 (define-builtin cdr (x)
1014   `(selfcall
1015     (var (tmp ,x))
1016     (return (if (=== tmp ,(convert nil))
1017                 ,(convert nil)
1018                 (get tmp "cdr")))))
1019
1020 (define-builtin rplaca (x new)
1021   `(= (get ,x "car") ,new))
1022
1023 (define-builtin rplacd (x new)
1024   `(= (get ,x "cdr") ,new))
1025
1026 (define-builtin symbolp (x)
1027   `(bool (instanceof ,x |Symbol|)))
1028
1029 (define-builtin make-symbol (name)
1030   `(new (call |Symbol| ,name)))
1031
1032 (define-builtin symbol-name (x)
1033   `(get ,x "name"))
1034
1035 (define-builtin set (symbol value)
1036   `(= (get ,symbol "value") ,value))
1037
1038 (define-builtin fset (symbol value)
1039   `(= (get ,symbol "fvalue") ,value))
1040
1041 (define-builtin boundp (x)
1042   `(bool (!== (get ,x "value") undefined)))
1043
1044 (define-builtin fboundp (x)
1045   `(bool (!== (get ,x "fvalue") undefined)))
1046
1047 (define-builtin symbol-value (x)
1048   `(selfcall
1049     (var (symbol ,x)
1050          (value (get symbol "value")))
1051     (if (=== value undefined)
1052         (throw (+ "Variable `" (call |xstring| (get symbol "name")) "' is unbound.")))
1053     (return value)))
1054
1055 (define-builtin symbol-function (x)
1056   `(selfcall
1057     (var (symbol ,x)
1058          (func (get symbol "fvalue")))
1059     (if (=== func undefined)
1060         (throw (+ "Function `" (call |xstring| (get symbol "name")) "' is undefined.")))
1061     (return func)))
1062
1063 (define-builtin symbol-plist (x)
1064   `(or (get ,x "plist") ,(convert nil)))
1065
1066 (define-builtin lambda-code (x)
1067   `(call |make_lisp_string| (method-call ,x "toString")))
1068
1069 (define-builtin eq (x y)
1070   `(bool (=== ,x ,y)))
1071
1072 (define-builtin char-code (x)
1073   `(call |char_to_codepoint| ,x))
1074
1075 (define-builtin code-char (x)
1076   `(call |char_from_codepoint| ,x))
1077
1078 (define-builtin characterp (x)
1079   `(selfcall
1080     (var (x ,x))
1081     (return (bool
1082              (and (== (typeof x) "string")
1083                   (or (== (get x "length") 1)
1084                       (== (get x "length") 2)))))))
1085
1086 (define-builtin char-upcase (x)
1087   `(call |safe_char_upcase| ,x))
1088
1089 (define-builtin char-downcase (x)
1090   `(call |safe_char_downcase| ,x))
1091
1092 (define-builtin stringp (x)
1093   `(selfcall
1094     (var (x ,x))
1095     (return (bool
1096              (and (and (===(typeof x) "object")
1097                        (in "length" x))
1098                   (== (get x "stringp") 1))))))
1099
1100 (define-raw-builtin funcall (func &rest args)
1101   `(selfcall
1102     (var (f ,(convert func)))
1103     (return (call (if (=== (typeof f) "function")
1104                       f
1105                       (get f "fvalue"))
1106                   ,@(list* (if *multiple-value-p* '|values| '|pv|)
1107                            (length args)
1108                            (mapcar #'convert args))))))
1109
1110 (define-raw-builtin apply (func &rest args)
1111   (if (null args)
1112       (convert func)
1113       (let ((args (butlast args))
1114             (last (car (last args))))
1115         `(selfcall
1116            (var (f ,(convert func)))
1117            (var (args ,(list-to-vector
1118                         (list* (if *multiple-value-p* '|values| '|pv|)
1119                                (length args)
1120                                (mapcar #'convert args)))))
1121            (var (tail ,(convert last)))
1122            (while (!= tail ,(convert nil))
1123              (method-call args "push" (get tail "car"))
1124              (post++ (property args 1))
1125              (= tail (get tail "cdr")))
1126            (return (method-call (if (=== (typeof f) "function")
1127                                     f
1128                                     (get f "fvalue"))
1129                                 "apply"
1130                                 this
1131                                 args))))))
1132
1133 (define-builtin js-eval (string)
1134   (if *multiple-value-p*
1135       `(selfcall
1136         (var (v (call |globalEval| (call |xstring| ,string))))
1137         (return (method-call |values| "apply" this (call |forcemv| v))))
1138       `(call |globalEval| (call |xstring| ,string))))
1139
1140 (define-builtin %throw (string)
1141   `(selfcall (throw ,string)))
1142
1143 (define-builtin functionp (x)
1144   `(bool (=== (typeof ,x) "function")))
1145
1146 (define-builtin %write-string (x)
1147   `(method-call |lisp| "write" ,x))
1148
1149 (define-builtin /debug (x)
1150   `(method-call |console| "log" (call |xstring| ,x)))
1151
1152
1153 ;;; Storage vectors. They are used to implement arrays and (in the
1154 ;;; future) structures.
1155
1156 (define-builtin storage-vector-p (x)
1157   `(selfcall
1158     (var (x ,x))
1159     (return (bool (and (=== (typeof x) "object") (in "length" x))))))
1160
1161 (define-builtin make-storage-vector (n)
1162   `(selfcall
1163     (var (r #()))
1164     (= (get r "length") ,n)
1165     (return r)))
1166
1167 (define-builtin storage-vector-size (x)
1168   `(get ,x "length"))
1169
1170 (define-builtin resize-storage-vector (vector new-size)
1171   `(= (get ,vector "length") ,new-size))
1172
1173 (define-builtin storage-vector-ref (vector n)
1174   `(selfcall
1175     (var (x (property ,vector ,n)))
1176     (if (=== x undefined) (throw "Out of range."))
1177     (return x)))
1178
1179 (define-builtin storage-vector-set (vector n value)
1180   `(selfcall
1181     (var (x ,vector))
1182     (var (i ,n))
1183     (if (or (< i 0) (>= i (get x "length")))
1184         (throw "Out of range."))
1185     (return (= (property x i) ,value))))
1186
1187 (define-builtin concatenate-storage-vector (sv1 sv2)
1188   `(selfcall
1189      (var (sv1 ,sv1))
1190      (var (r (method-call sv1 "concat" ,sv2)))
1191      (= (get r "type") (get sv1 "type"))
1192      (= (get r "stringp") (get sv1 "stringp"))
1193      (return r)))
1194
1195 (define-builtin get-internal-real-time ()
1196   `(method-call (new (call |Date|)) "getTime"))
1197
1198 (define-builtin values-array (array)
1199   (if *multiple-value-p*
1200       `(method-call |values| "apply" this ,array)
1201       `(method-call |pv| "apply" this ,array)))
1202
1203 (define-raw-builtin values (&rest args)
1204   (if *multiple-value-p*
1205       `(call |values| ,@(mapcar #'convert args))
1206       `(call |pv| ,@(mapcar #'convert args))))
1207
1208 ;;; Javascript FFI
1209
1210 (define-builtin new ()
1211   '(object))
1212
1213 (define-raw-builtin oget* (object key &rest keys)
1214   `(selfcall
1215     (progn
1216       (var (tmp (property ,(convert object) (call |xstring| ,(convert key)))))
1217       ,@(mapcar (lambda (key)
1218                   `(progn
1219                      (if (=== tmp undefined) (return ,(convert nil)))
1220                      (= tmp (property tmp (call |xstring| ,(convert key))))))
1221                 keys))
1222     (return (if (=== tmp undefined) ,(convert nil) tmp))))
1223
1224 (define-raw-builtin oset* (value object key &rest keys)
1225   (let ((keys (cons key keys)))
1226     `(selfcall
1227       (progn
1228         (var (obj ,(convert object)))
1229         ,@(mapcar (lambda (key)
1230                     `(progn
1231                        (= obj (property obj (call |xstring| ,(convert key))))
1232                        (if (=== object undefined)
1233                            (throw "Impossible to set object property."))))
1234                   (butlast keys))
1235         (var (tmp
1236               (= (property obj (call |xstring| ,(convert (car (last keys)))))
1237                  ,(convert value))))
1238         (return (if (=== tmp undefined)
1239                     ,(convert nil)
1240                     tmp))))))
1241
1242 (define-raw-builtin oget (object key &rest keys)
1243   `(call |js_to_lisp| ,(convert `(oget* ,object ,key ,@keys))))
1244
1245 (define-raw-builtin oset (value object key &rest keys)
1246   (convert `(oset* (lisp-to-js ,value) ,object ,key ,@keys)))
1247
1248 (define-builtin objectp (x)
1249   `(bool (=== (typeof ,x) "object")))
1250
1251 (define-builtin lisp-to-js (x) `(call |lisp_to_js| ,x))
1252 (define-builtin js-to-lisp (x) `(call |js_to_lisp| ,x))
1253
1254
1255 (define-builtin in (key object)
1256   `(bool (in (call |xstring| ,key) ,object)))
1257
1258 (define-builtin map-for-in (function object)
1259   `(selfcall
1260     (var (f ,function)
1261          (g (if (=== (typeof f) "function") f (get f "fvalue")))
1262          (o ,object))
1263     (for-in (key o)
1264             (call g ,(if *multiple-value-p* '|values| '|pv|) 1 (get o "key")))
1265     (return ,(convert nil))))
1266
1267 (define-compilation %js-vref (var)
1268   `(call |js_to_lisp| ,(make-symbol var)))
1269
1270 (define-compilation %js-vset (var val)
1271   `(= ,(make-symbol var) (call |lisp_to_js| ,(convert val))))
1272
1273 (define-setf-expander %js-vref (var)
1274   (let ((new-value (gensym)))
1275     (unless (stringp var)
1276       (error "`~S' is not a string." var))
1277     (values nil
1278             (list var)
1279             (list new-value)
1280             `(%js-vset ,var ,new-value)
1281             `(%js-vref ,var))))
1282
1283
1284 #-jscl
1285 (defvar *macroexpander-cache*
1286   (make-hash-table :test #'eq))
1287
1288 (defun !macro-function (symbol)
1289   (unless (symbolp symbol)
1290     (error "`~S' is not a symbol." symbol))
1291   (let ((b (lookup-in-lexenv symbol *environment* 'function)))
1292     (if (and b (eq (binding-type b) 'macro))
1293         (let ((expander (binding-value b)))
1294           (cond
1295             #-jscl
1296             ((gethash b *macroexpander-cache*)
1297              (setq expander (gethash b *macroexpander-cache*)))
1298             ((listp expander)
1299              (let ((compiled (eval expander)))
1300                ;; The list representation are useful while
1301                ;; bootstrapping, as we can dump the definition of the
1302                ;; macros easily, but they are slow because we have to
1303                ;; evaluate them and compile them now and again. So, let
1304                ;; us replace the list representation version of the
1305                ;; function with the compiled one.
1306                ;;
1307                #+jscl (setf (binding-value b) compiled)
1308                #-jscl (setf (gethash b *macroexpander-cache*) compiled)
1309                (setq expander compiled))))
1310           expander)
1311         nil)))
1312
1313 (defun !macroexpand-1 (form)
1314   (cond
1315     ((symbolp form)
1316      (let ((b (lookup-in-lexenv form *environment* 'variable)))
1317        (if (and b (eq (binding-type b) 'macro))
1318            (values (binding-value b) t)
1319            (values form nil))))
1320     ((and (consp form) (symbolp (car form)))
1321      (let ((macrofun (!macro-function (car form))))
1322        (if macrofun
1323            (values (funcall macrofun (cdr form)) t)
1324            (values form nil))))
1325     (t
1326      (values form nil))))
1327
1328 (defun compile-funcall (function args)
1329   (let* ((arglist (list* (if *multiple-value-p* '|values| '|pv|)
1330                          (length args)
1331                          (mapcar #'convert args))))
1332     (unless (or (symbolp function)
1333                 (and (consp function)
1334                      (member (car function) '(lambda oget))))
1335       (error "Bad function designator `~S'" function))
1336     (cond
1337       ((translate-function function)
1338        `(call ,(translate-function function) ,@arglist))
1339       ((and (symbolp function)
1340             #+jscl (eq (symbol-package function) (find-package "COMMON-LISP"))
1341             #-jscl t)
1342        `(method-call ,(convert `',function) "fvalue" ,@arglist))
1343       #+jscl((symbolp function)
1344              `(call ,(convert `#',function) ,@arglist))
1345       ((and (consp function) (eq (car function) 'lambda))
1346        `(call ,(convert `#',function) ,@arglist))
1347       ((and (consp function) (eq (car function) 'oget))
1348        `(call ,(convert function) ,@arglist))
1349       (t
1350        (error "Bad function descriptor")))))
1351
1352 (defun convert-block (sexps &optional return-last-p decls-allowed-p)
1353   (multiple-value-bind (sexps decls)
1354       (parse-body sexps :declarations decls-allowed-p)
1355     (declare (ignore decls))
1356     (if return-last-p
1357         `(progn
1358            ,@(mapcar #'convert (butlast sexps))
1359            (return ,(convert (car (last sexps)) *multiple-value-p*)))
1360         `(progn ,@(mapcar #'convert sexps)))))
1361
1362 (defun convert* (sexp &optional multiple-value-p)
1363   (multiple-value-bind (sexp expandedp) (!macroexpand-1 sexp)
1364     (when expandedp
1365       (return-from convert* (convert sexp multiple-value-p)))
1366     ;; The expression has been macroexpanded. Now compile it!
1367     (let ((*multiple-value-p* multiple-value-p))
1368       (cond
1369         ((symbolp sexp)
1370          (let ((b (lookup-in-lexenv sexp *environment* 'variable)))
1371            (cond
1372              ((and b (not (member 'special (binding-declarations b))))
1373               (binding-value b))
1374              ((or (keywordp sexp)
1375                   (and b (member 'constant (binding-declarations b))))
1376               `(get ,(convert `',sexp) "value"))
1377              (t
1378               (convert `(symbol-value ',sexp))))))
1379         ((or (integerp sexp) (floatp sexp) (characterp sexp) (stringp sexp) (arrayp sexp))
1380          (literal sexp))
1381         ((listp sexp)
1382          (let ((name (car sexp))
1383                (args (cdr sexp)))
1384            (cond
1385              ;; Special forms
1386              ((assoc name *compilations*)
1387               (let ((comp (second (assoc name *compilations*))))
1388                 (apply comp args)))
1389              ;; Built-in functions
1390              ((and (assoc name *builtins*)
1391                    (not (claimp name 'function 'notinline)))
1392               (let ((comp (second (assoc name *builtins*))))
1393                 (apply comp args)))
1394              (t
1395               (compile-funcall name args)))))
1396         (t
1397          (error "How should I compile `~S'?" sexp))))))
1398
1399 (defun convert (sexp &optional multiple-value-p)
1400   (convert* sexp multiple-value-p))
1401
1402
1403 (defvar *compile-print-toplevels* nil)
1404
1405 (defun truncate-string (string &optional (width 60))
1406   (let ((n (or (position #\newline string)
1407                (min width (length string)))))
1408     (subseq string 0 n)))
1409
1410 (defun convert-toplevel (sexp &optional multiple-value-p)
1411   (let ((*toplevel-compilations* nil))
1412     (cond
1413       ;; Non-empty toplevel progn
1414       ((and (consp sexp)
1415             (eq (car sexp) 'progn)
1416             (cdr sexp))
1417        `(progn
1418           ,@(mapcar (lambda (s) (convert-toplevel s t))
1419                     (cdr sexp))))
1420       (t
1421        (when *compile-print-toplevels*
1422          (let ((form-string (prin1-to-string sexp)))
1423            (format t "Compiling ~a..." (truncate-string form-string))))
1424        (let ((code (convert sexp multiple-value-p)))
1425          `(progn
1426             ,@(get-toplevel-compilations)
1427             ,code))))))
1428
1429 (defun compile-toplevel (sexp &optional multiple-value-p)
1430   (with-output-to-string (*standard-output*)
1431     (js (convert-toplevel sexp multiple-value-p))))