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