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