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