src/compiler.lisp

   1 ;;; compiler.lisp ---
   2
   3 ;; copyright (C) 2012, 2013 David Vazquez
   4 ;; Copyright (C) 2012 Raimon Grau
   5
   6 ;; This program 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 ;; This program 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 this program.  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."))))
  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 #+common-lisp
  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 ;; A very simple defstruct built on lists. It supports just slot with
  91 ;; an optional default initform, and it will create a constructor,
  92 ;; predicate and accessors for you.
  93 (defmacro def!struct (name &rest slots)
  94   (unless (symbolp name)
  95     (error "It is not a full defstruct implementation."))
  96   (let* ((name-string (symbol-name name))
  97          (slot-descriptions
  98           (mapcar (lambda (sd)
  99                     (cond
 100                       ((symbolp sd)
 101                        (list sd))
 102                       ((and (listp sd) (car sd) (cddr sd))
 103                        sd)
 104                       (t
 105                        (error "Bad slot accessor."))))
 106                   slots))
 107          (predicate (intern (concat name-string "-P"))))
 108     `(progn
 109        ;; Constructor
 110        (defun ,(intern (concat "MAKE-" name-string)) (&key ,@slot-descriptions)
 111          (list ',name ,@(mapcar #'car slot-descriptions)))
 112        ;; Predicate
 113        (defun ,predicate (x)
 114          (and (consp x) (eq (car x) ',name)))
 115        ;; Copier
 116        (defun ,(intern (concat "COPY-" name-string)) (x)
 117          (copy-list x))
 118        ;; Slot accessors
 119        ,@(with-collect
 120           (let ((index 1))
 121             (dolist (slot slot-descriptions)
 122               (let* ((name (car slot))
 123                      (accessor-name (intern (concat name-string "-" (string name)))))
 124                 (collect
 125                     `(defun ,accessor-name (x)
 126                        (unless (,predicate x)
 127                          (error ,(concat "The object is not a type " name-string)))
 128                        (nth ,index x)))
 129                 ;; TODO: Implement this with a higher level
 130                 ;; abstraction like defsetf or (defun (setf ..))
 131                 (collect
 132                     `(define-setf-expander ,accessor-name (x)
 133                        (let ((object (gensym))
 134                              (new-value (gensym)))
 135                          (values (list object)
 136                                  (list x)
 137                                  (list new-value)
 138                                  `(progn
 139                                     (rplaca (nthcdr ,',index ,object) ,new-value)
 140                                     ,new-value)
 141                                  `(,',accessor-name ,object)))))
 142                 (incf index)))))
 143        ',name)))
 144
 145
 146 ;;; Environment
 147
 148 (def!struct binding
 149   name
 150   type
 151   value
 152   declarations)
 153
 154 (def!struct lexenv
 155   variable
 156   function
 157   block
 158   gotag)
 159
 160 (defun lookup-in-lexenv (name lexenv namespace)
 161   (find name (ecase namespace
 162                 (variable (lexenv-variable lexenv))
 163                 (function (lexenv-function lexenv))
 164                 (block    (lexenv-block    lexenv))
 165                 (gotag    (lexenv-gotag    lexenv)))
 166         :key #'binding-name))
 167
 168 (defun push-to-lexenv (binding lexenv namespace)
 169   (ecase namespace
 170     (variable (push binding (lexenv-variable lexenv)))
 171     (function (push binding (lexenv-function lexenv)))
 172     (block    (push binding (lexenv-block    lexenv)))
 173     (gotag    (push binding (lexenv-gotag    lexenv)))))
 174
 175 (defun extend-lexenv (bindings lexenv namespace)
 176   (let ((env (copy-lexenv lexenv)))
 177     (dolist (binding (reverse bindings) env)
 178       (push-to-lexenv binding env namespace))))
 179
 180
 181 (defvar *environment* (make-lexenv))
 182
 183 (defvar *variable-counter* 0)
 184
 185 (defun gvarname (symbol)
 186   (code "v" (incf *variable-counter*)))
 187
 188 (defun translate-variable (symbol)
 189   (awhen (lookup-in-lexenv symbol *environment* 'variable)
 190     (binding-value it)))
 191
 192 (defun extend-local-env (args)
 193   (let ((new (copy-lexenv *environment*)))
 194     (dolist (symbol args new)
 195       (let ((b (make-binding :name symbol :type 'variable :value (gvarname symbol))))
 196         (push-to-lexenv b new 'variable)))))
 197
 198 ;;; Toplevel compilations
 199 (defvar *toplevel-compilations* nil)
 200
 201 (defun toplevel-compilation (string)
 202   (push string *toplevel-compilations*))
 203
 204 (defun null-or-empty-p (x)
 205   (zerop (length x)))
 206
 207 (defun get-toplevel-compilations ()
 208   (reverse (remove-if #'null-or-empty-p *toplevel-compilations*)))
 209
 210 (defun %compile-defmacro (name lambda)
 211   (toplevel-compilation (ls-compile `',name))
 212   (let ((binding (make-binding :name name :type 'macro :value lambda)))
 213     (push-to-lexenv binding  *environment* 'function))
 214   name)
 215
 216 (defun global-binding (name type namespace)
 217   (or (lookup-in-lexenv name *environment* namespace)
 218       (let ((b (make-binding :name name :type type :value nil)))
 219         (push-to-lexenv b *environment* namespace)
 220         b)))
 221
 222 (defun claimp (symbol namespace claim)
 223   (let ((b (lookup-in-lexenv symbol *environment* namespace)))
 224     (and b (member claim (binding-declarations b)))))
 225
 226 (defun !proclaim (decl)
 227   (case (car decl)
 228     (special
 229      (dolist (name (cdr decl))
 230        (let ((b (global-binding name 'variable 'variable)))
 231          (push 'special (binding-declarations b)))))
 232     (notinline
 233      (dolist (name (cdr decl))
 234        (let ((b (global-binding name 'function 'function)))
 235          (push 'notinline (binding-declarations b)))))
 236     (constant
 237      (dolist (name (cdr decl))
 238        (let ((b (global-binding name 'variable 'variable)))
 239          (push 'constant (binding-declarations b)))))))
 240
 241 #+jscl
 242 (fset 'proclaim #'!proclaim)
 243
 244 (defun %define-symbol-macro (name expansion)
 245   (let ((b (make-binding :name name :type 'macro :value expansion)))
 246     (push-to-lexenv b *environment* 'variable)
 247     name))
 248
 249 #+jscl
 250 (defmacro define-symbol-macro (name expansion)
 251   `(%define-symbol-macro ',name ',expansion))
 252
 253
 254 ;;; Special forms
 255
 256 (defvar *compilations* nil)
 257
 258 (defmacro define-compilation (name args &body body)
 259   ;; Creates a new primitive `name' with parameters args and
 260   ;; @body. The body can access to the local environment through the
 261   ;; variable *ENVIRONMENT*.
 262   `(push (list ',name (lambda ,args (block ,name ,@body)))
 263          *compilations*))
 264
 265 (define-compilation if (condition true false)
 266   (code "(" (ls-compile condition) " !== " (ls-compile nil)
 267         " ? " (ls-compile true *multiple-value-p*)
 268         " : " (ls-compile false *multiple-value-p*)
 269         ")"))
 270
 271 (defvar *ll-keywords* '(&optional &rest &key))
 272
 273 (defun list-until-keyword (list)
 274   (if (or (null list) (member (car list) *ll-keywords*))
 275       nil
 276       (cons (car list) (list-until-keyword (cdr list)))))
 277
 278 (defun ll-section (keyword ll)
 279   (list-until-keyword (cdr (member keyword ll))))
 280
 281 (defun ll-required-arguments (ll)
 282   (list-until-keyword ll))
 283
 284 (defun ll-optional-arguments-canonical (ll)
 285   (mapcar #'ensure-list (ll-section '&optional ll)))
 286
 287 (defun ll-optional-arguments (ll)
 288   (mapcar #'car (ll-optional-arguments-canonical ll)))
 289
 290 (defun ll-rest-argument (ll)
 291   (let ((rest (ll-section '&rest ll)))
 292     (when (cdr rest)
 293       (error "Bad lambda-list"))
 294     (car rest)))
 295
 296 (defun ll-keyword-arguments-canonical (ll)
 297   (flet ((canonicalize (keyarg)
 298            ;; Build a canonical keyword argument descriptor, filling
 299            ;; the optional fields. The result is a list of the form
 300            ;; ((keyword-name var) init-form).
 301            (let ((arg (ensure-list keyarg)))
 302              (cons (if (listp (car arg))
 303                        (car arg)
 304                        (list (intern (symbol-name (car arg)) "KEYWORD") (car arg)))
 305                    (cdr arg)))))
 306     (mapcar #'canonicalize (ll-section '&key ll))))
 307
 308 (defun ll-keyword-arguments (ll)
 309   (mapcar (lambda (keyarg) (second (first keyarg)))
 310           (ll-keyword-arguments-canonical ll)))
 311
 312 (defun ll-svars (lambda-list)
 313   (let ((args
 314          (append
 315           (ll-keyword-arguments-canonical lambda-list)
 316           (ll-optional-arguments-canonical lambda-list))))
 317     (remove nil (mapcar #'third args))))
 318
 319 (defun lambda-name/docstring-wrapper (name docstring &rest strs)
 320   (if (or name docstring)
 321       (js!selfcall
 322         "var func = " (join strs) ";" *newline*
 323         (when name
 324           (code "func.fname = '" (escape-string name) "';" *newline*))
 325         (when docstring
 326           (code "func.docstring = '" (escape-string docstring) "';" *newline*))
 327         "return func;" *newline*)
 328       (apply #'code strs)))
 329
 330 (defun lambda-check-argument-count
 331     (n-required-arguments n-optional-arguments rest-p)
 332   ;; Note: Remember that we assume that the number of arguments of a
 333   ;; call is at least 1 (the values argument).
 334   (let ((min (1+ n-required-arguments))
 335         (max (if rest-p 'n/a (+ 1 n-required-arguments n-optional-arguments))))
 336     (block nil
 337       ;; Special case: a positive exact number of arguments.
 338       (when (and (< 1 min) (eql min max))
 339         (return (code "checkArgs(arguments, " min ");" *newline*)))
 340       ;; General case:
 341       (code
 342        (when (< 1 min)
 343          (code "checkArgsAtLeast(arguments, " min ");" *newline*))
 344        (when (numberp max)
 345          (code "checkArgsAtMost(arguments, " max ");" *newline*))))))
 346
 347 (defun compile-lambda-optional (ll)
 348   (let* ((optional-arguments (ll-optional-arguments-canonical ll))
 349          (n-required-arguments (length (ll-required-arguments ll)))
 350          (n-optional-arguments (length optional-arguments)))
 351     (when optional-arguments
 352       (code (mapconcat (lambda (arg)
 353                          (code "var " (translate-variable (first arg)) "; " *newline*
 354                                (when (third arg)
 355                                  (code "var " (translate-variable (third arg))
 356                                        " = " (ls-compile t)
 357                                        "; " *newline*))))
 358                        optional-arguments)
 359             "switch(arguments.length-1){" *newline*
 360             (let ((cases nil)
 361                   (idx 0))
 362               (progn
 363                 (while (< idx n-optional-arguments)
 364                   (let ((arg (nth idx optional-arguments)))
 365                     (push (code "case " (+ idx n-required-arguments) ":" *newline*
 366                                 (indent (translate-variable (car arg))
 367                                         "="
 368                                         (ls-compile (cadr arg)) ";" *newline*)
 369                                 (when (third arg)
 370                                   (indent (translate-variable (third arg))
 371                                           "="
 372                                           (ls-compile nil)
 373                                           ";" *newline*)))
 374                           cases)
 375                     (incf idx)))
 376                 (push (code "default: break;" *newline*) cases)
 377                 (join (reverse cases))))
 378             "}" *newline*))))
 379
 380 (defun compile-lambda-rest (ll)
 381   (let ((n-required-arguments (length (ll-required-arguments ll)))
 382         (n-optional-arguments (length (ll-optional-arguments ll)))
 383         (rest-argument (ll-rest-argument ll)))
 384     (when rest-argument
 385       (let ((js!rest (translate-variable rest-argument)))
 386         (code "var " js!rest "= " (ls-compile nil) ";" *newline*
 387               "for (var i = arguments.length-1; i>="
 388               (+ 1 n-required-arguments n-optional-arguments)
 389               "; i--)" *newline*
 390               (indent js!rest " = {car: arguments[i], cdr: ") js!rest "};"
 391               *newline*)))))
 392
 393 (defun compile-lambda-parse-keywords (ll)
 394   (let ((n-required-arguments
 395          (length (ll-required-arguments ll)))
 396         (n-optional-arguments
 397          (length (ll-optional-arguments ll)))
 398         (keyword-arguments
 399          (ll-keyword-arguments-canonical ll)))
 400     (code
 401      ;; Declare variables
 402      (mapconcat (lambda (arg)
 403                   (let ((var (second (car arg))))
 404                     (code "var " (translate-variable var) "; " *newline*
 405                           (when (third arg)
 406                             (code "var " (translate-variable (third arg))
 407                                   " = " (ls-compile nil)
 408                                   ";" *newline*)))))
 409                 keyword-arguments)
 410      ;; Parse keywords
 411      (flet ((parse-keyword (keyarg)
 412               ;; ((keyword-name var) init-form)
 413               (code "for (i=" (+ 1 n-required-arguments n-optional-arguments)
 414                     "; i<arguments.length; i+=2){" *newline*
 415                     (indent
 416                      "if (arguments[i] === " (ls-compile (caar keyarg)) "){" *newline*
 417                      (indent (translate-variable (cadr (car keyarg)))
 418                              " = arguments[i+1];"
 419                              *newline*
 420                              (let ((svar (third keyarg)))
 421                                (when svar
 422                                  (code (translate-variable svar) " = " (ls-compile t) ";" *newline*)))
 423                              "break;" *newline*)
 424                      "}" *newline*)
 425                     "}" *newline*
 426                     ;; Default value
 427                     "if (i == arguments.length){" *newline*
 428                     (indent (translate-variable (cadr (car keyarg))) " = " (ls-compile (cadr keyarg)) ";" *newline*)
 429                     "}" *newline*)))
 430        (when keyword-arguments
 431          (code "var i;" *newline*
 432                (mapconcat #'parse-keyword keyword-arguments))))
 433      ;; Check for unknown keywords
 434      (when keyword-arguments
 435        (code "for (i=" (+ 1 n-required-arguments n-optional-arguments)
 436              "; i<arguments.length; i+=2){" *newline*
 437              (indent "if ("
 438                      (join (mapcar (lambda (x)
 439                                      (concat "arguments[i] !== " (ls-compile (caar x))))
 440                                    keyword-arguments)
 441                            " && ")
 442                      ")" *newline*
 443                      (indent
 444                       "throw 'Unknown keyword argument ' + arguments[i].name;" *newline*))
 445              "}" *newline*)))))
 446
 447 (defun parse-lambda-list (ll)
 448   (values (ll-required-arguments ll)
 449           (ll-optional-arguments ll)
 450           (ll-keyword-arguments  ll)
 451           (ll-rest-argument      ll)))
 452
 453 ;;; Process BODY for declarations and/or docstrings. Return as
 454 ;;; multiple values the BODY without docstrings or declarations, the
 455 ;;; list of declaration forms and the docstring.
 456 (defun parse-body (body &key declarations docstring)
 457   (let ((value-declarations)
 458         (value-docstring))
 459     ;; Parse declarations
 460     (when declarations
 461       (do* ((rest body (cdr rest))
 462             (form (car rest) (car rest)))
 463            ((or (atom form) (not (eq (car form) 'declare)))
 464             (setf body rest))
 465         (push form value-declarations)))
 466     ;; Parse docstring
 467     (when (and docstring
 468                (stringp (car body))
 469                (not (null (cdr body))))
 470       (setq value-docstring (car body))
 471       (setq body (cdr body)))
 472     (values body value-declarations value-docstring)))
 473
 474 ;;; Compile a lambda function with lambda list LL and body BODY. If
 475 ;;; NAME is given, it should be a constant string and it will become
 476 ;;; the name of the function. If BLOCK is non-NIL, a named block is
 477 ;;; created around the body. NOTE: No block (even anonymous) is
 478 ;;; created if BLOCk is NIL.
 479 (defun compile-lambda (ll body &key name block)
 480   (multiple-value-bind (required-arguments
 481                         optional-arguments
 482                         keyword-arguments
 483                         rest-argument)
 484       (parse-lambda-list ll)
 485     (multiple-value-bind (body decls documentation)
 486         (parse-body body :declarations t :docstring t)
 487       (declare (ignore decls))
 488       (let ((n-required-arguments (length required-arguments))
 489             (n-optional-arguments (length optional-arguments))
 490             (*environment* (extend-local-env
 491                             (append (ensure-list rest-argument)
 492                                     required-arguments
 493                                     optional-arguments
 494                                     keyword-arguments
 495                                     (ll-svars ll)))))
 496         (lambda-name/docstring-wrapper name documentation
 497          "(function ("
 498          (join (cons "values"
 499                      (mapcar #'translate-variable
 500                              (append required-arguments optional-arguments)))
 501                ",")
 502          "){" *newline*
 503          (indent
 504           ;; Check number of arguments
 505           (lambda-check-argument-count n-required-arguments
 506                                        n-optional-arguments
 507                                        (or rest-argument keyword-arguments))
 508                                         (compile-lambda-optional ll)
 509                                         (compile-lambda-rest ll)
 510                                         (compile-lambda-parse-keywords ll)
 511                                         (let ((*multiple-value-p* t))
 512                                           (if block
 513                                               (ls-compile-block `((block ,block ,@body)) t)
 514                                               (ls-compile-block body t))))
 515          "})")))))
 516
 517
 518 (defun setq-pair (var val)
 519   (let ((b (lookup-in-lexenv var *environment* 'variable)))
 520     (cond
 521       ((and b
 522             (eq (binding-type b) 'variable)
 523             (not (member 'special (binding-declarations b)))
 524             (not (member 'constant (binding-declarations b))))
 525        (code (binding-value b) " = " (ls-compile val)))
 526       ((and b (eq (binding-type b) 'macro))
 527        (ls-compile `(setf ,var ,val)))
 528       (t
 529        (ls-compile `(set ',var ,val))))))
 530
 531
 532 (define-compilation setq (&rest pairs)
 533   (let ((result ""))
 534     (while t
 535       (cond
 536         ((null pairs) (return))
 537         ((null (cdr pairs))
 538          (error "Odd paris in SETQ"))
 539         (t
 540          (concatf result
 541            (concat (setq-pair (car pairs) (cadr pairs))
 542                    (if (null (cddr pairs)) "" ", ")))
 543          (setq pairs (cddr pairs)))))
 544     (code "(" result ")")))
 545
 546
 547 ;;; Literals
 548 (defun escape-string (string)
 549   (let ((output "")
 550         (index 0)
 551         (size (length string)))
 552     (while (< index size)
 553       (let ((ch (char string index)))
 554         (when (or (char= ch #\") (char= ch #\\))
 555           (setq output (concat output "\\")))
 556         (when (or (char= ch #\newline))
 557           (setq output (concat output "\\"))
 558           (setq ch #\n))
 559         (setq output (concat output (string ch))))
 560       (incf index))
 561     output))
 562
 563
 564 (defvar *literal-table* nil)
 565 (defvar *literal-counter* 0)
 566
 567 (defun genlit ()
 568   (code "l" (incf *literal-counter*)))
 569
 570 (defun dump-symbol (symbol)
 571   #+common-lisp
 572   (let ((package (symbol-package symbol)))
 573     (if (eq package (find-package "KEYWORD"))
 574         (code "{name: \"" (escape-string (symbol-name symbol))
 575               "\", 'package': '" (package-name package) "'}")
 576         (code "{name: \"" (escape-string (symbol-name symbol)) "\"}")))
 577   #+jscl
 578   (let ((package (symbol-package symbol)))
 579     (if (null package)
 580         (code "{name: \"" (escape-string (symbol-name symbol)) "\"}")
 581         (ls-compile `(intern ,(symbol-name symbol) ,(package-name package))))))
 582
 583 (defun dump-cons (cons)
 584   (let ((head (butlast cons))
 585         (tail (last cons)))
 586     (code "QIList("
 587           (join-trailing (mapcar (lambda (x) (literal x t)) head) ",")
 588           (literal (car tail) t)
 589           ","
 590           (literal (cdr tail) t)
 591           ")")))
 592
 593 (defun dump-array (array)
 594   (let ((elements (vector-to-list array)))
 595     (concat "[" (join (mapcar #'literal elements) ", ") "]")))
 596
 597 (defun literal (sexp &optional recursive)
 598   (cond
 599     ((integerp sexp) (integer-to-string sexp))
 600     ((floatp sexp) (float-to-string sexp))
 601     ((stringp sexp) (code "\"" (escape-string sexp) "\""))
 602     (t
 603      (or (cdr (assoc sexp *literal-table*))
 604          (let ((dumped (typecase sexp
 605                          (symbol (dump-symbol sexp))
 606                          (cons (dump-cons sexp))
 607                          (array (dump-array sexp)))))
 608            (if (and recursive (not (symbolp sexp)))
 609                dumped
 610                (let ((jsvar (genlit)))
 611                  (push (cons sexp jsvar) *literal-table*)
 612                  (toplevel-compilation (code "var " jsvar " = " dumped))
 613                  jsvar)))))))
 614
 615 (define-compilation quote (sexp)
 616   (literal sexp))
 617
 618 (define-compilation %while (pred &rest body)
 619   (js!selfcall
 620     "while(" (ls-compile pred) " !== " (ls-compile nil) "){" *newline*
 621     (indent (ls-compile-block body))
 622     "}"
 623     "return " (ls-compile nil) ";" *newline*))
 624
 625 (define-compilation function (x)
 626   (cond
 627     ((and (listp x) (eq (car x) 'lambda))
 628      (compile-lambda (cadr x) (cddr x)))
 629     ((and (listp x) (eq (car x) 'named-lambda))
 630      ;; TODO: destructuring-bind now! Do error checking manually is
 631      ;; very annoying.
 632      (let ((name (cadr x))
 633            (ll (caddr x))
 634            (body (cdddr x)))
 635        (compile-lambda ll body
 636                        :name (symbol-name name)
 637                        :block name)))
 638     ((symbolp x)
 639      (let ((b (lookup-in-lexenv x *environment* 'function)))
 640        (if b
 641            (binding-value b)
 642            (ls-compile `(symbol-function ',x)))))))
 643
 644
 645 (defun make-function-binding (fname)
 646   (make-binding :name fname :type 'function :value (gvarname fname)))
 647
 648 (defun compile-function-definition (list)
 649   (compile-lambda (car list) (cdr list)))
 650
 651 (defun translate-function (name)
 652   (let ((b (lookup-in-lexenv name *environment* 'function)))
 653     (and b (binding-value b))))
 654
 655 (define-compilation flet (definitions &rest body)
 656   (let* ((fnames (mapcar #'car definitions))
 657          (fbody  (mapcar #'cdr definitions))
 658          (cfuncs (mapcar #'compile-function-definition fbody))
 659          (*environment*
 660           (extend-lexenv (mapcar #'make-function-binding fnames)
 661                          *environment*
 662                          'function)))
 663     (code "(function("
 664           (join (mapcar #'translate-function fnames) ",")
 665           "){" *newline*
 666           (let ((body (ls-compile-block body t)))
 667             (indent body))
 668           "})(" (join cfuncs ",") ")")))
 669
 670 (define-compilation labels (definitions &rest body)
 671   (let* ((fnames (mapcar #'car definitions))
 672          (*environment*
 673           (extend-lexenv (mapcar #'make-function-binding fnames)
 674                          *environment*
 675                          'function)))
 676     (js!selfcall
 677       (mapconcat (lambda (func)
 678                    (code "var " (translate-function (car func))
 679                          " = " (compile-lambda (cadr func) (cddr func))
 680                          ";" *newline*))
 681                  definitions)
 682       (ls-compile-block body t))))
 683
 684
 685 (defvar *compiling-file* nil)
 686 (define-compilation eval-when-compile (&rest body)
 687   (if *compiling-file*
 688       (progn
 689         (eval (cons 'progn body))
 690         nil)
 691       (ls-compile `(progn ,@body))))
 692
 693 (defmacro define-transformation (name args form)
 694   `(define-compilation ,name ,args
 695      (ls-compile ,form)))
 696
 697 (define-compilation progn (&rest body)
 698   (if (null (cdr body))
 699       (ls-compile (car body) *multiple-value-p*)
 700       (js!selfcall (ls-compile-block body t))))
 701
 702 (defun special-variable-p (x)
 703   (and (claimp x 'variable 'special) t))
 704
 705 ;;; Wrap CODE to restore the symbol values of the dynamic
 706 ;;; bindings. BINDINGS is a list of pairs of the form
 707 ;;; (SYMBOL . PLACE),  where PLACE is a Javascript variable
 708 ;;; name to initialize the symbol value and where to stored
 709 ;;; the old value.
 710 (defun let-binding-wrapper (bindings body)
 711   (when (null bindings)
 712     (return-from let-binding-wrapper body))
 713   (code
 714    "try {" *newline*
 715    (indent "var tmp;" *newline*
 716            (mapconcat
 717             (lambda (b)
 718               (let ((s (ls-compile `(quote ,(car b)))))
 719                 (code "tmp = " s ".value;" *newline*
 720                       s ".value = " (cdr b) ";" *newline*
 721                       (cdr b) " = tmp;" *newline*)))
 722             bindings)
 723            body *newline*)
 724    "}" *newline*
 725    "finally {"  *newline*
 726    (indent
 727     (mapconcat (lambda (b)
 728                  (let ((s (ls-compile `(quote ,(car b)))))
 729                    (code s ".value" " = " (cdr b) ";" *newline*)))
 730                bindings))
 731    "}" *newline*))
 732
 733 (define-compilation let (bindings &rest body)
 734   (let* ((bindings (mapcar #'ensure-list bindings))
 735          (variables (mapcar #'first bindings))
 736          (cvalues (mapcar #'ls-compile (mapcar #'second bindings)))
 737          (*environment* (extend-local-env (remove-if #'special-variable-p variables)))
 738          (dynamic-bindings))
 739     (code "(function("
 740           (join (mapcar (lambda (x)
 741                           (if (special-variable-p x)
 742                               (let ((v (gvarname x)))
 743                                 (push (cons x v) dynamic-bindings)
 744                                 v)
 745                               (translate-variable x)))
 746                         variables)
 747                 ",")
 748           "){" *newline*
 749           (let ((body (ls-compile-block body t)))
 750             (indent (let-binding-wrapper dynamic-bindings body)))
 751           "})(" (join cvalues ",") ")")))
 752
 753
 754 ;;; Return the code to initialize BINDING, and push it extending the
 755 ;;; current lexical environment if the variable is not special.
 756 (defun let*-initialize-value (binding)
 757   (let ((var (first binding))
 758         (value (second binding)))
 759     (if (special-variable-p var)
 760         (code (ls-compile `(setq ,var ,value)) ";" *newline*)
 761         (let* ((v (gvarname var))
 762                (b (make-binding :name var :type 'variable :value v)))
 763           (prog1 (code "var " v " = " (ls-compile value) ";" *newline*)
 764             (push-to-lexenv b *environment* 'variable))))))
 765
 766 ;;; Wrap BODY to restore the symbol values of SYMBOLS after body. It
 767 ;;; DOES NOT generate code to initialize the value of the symbols,
 768 ;;; unlike let-binding-wrapper.
 769 (defun let*-binding-wrapper (symbols body)
 770   (when (null symbols)
 771     (return-from let*-binding-wrapper body))
 772   (let ((store (mapcar (lambda (s) (cons s (gvarname s)))
 773                        (remove-if-not #'special-variable-p symbols))))
 774     (code
 775      "try {" *newline*
 776      (indent
 777       (mapconcat (lambda (b)
 778                    (let ((s (ls-compile `(quote ,(car b)))))
 779                      (code "var " (cdr b) " = " s ".value;" *newline*)))
 780                  store)
 781       body)
 782      "}" *newline*
 783      "finally {" *newline*
 784      (indent
 785       (mapconcat (lambda (b)
 786                    (let ((s (ls-compile `(quote ,(car b)))))
 787                      (code s ".value" " = " (cdr b) ";" *newline*)))
 788                  store))
 789      "}" *newline*)))
 790
 791 (define-compilation let* (bindings &rest body)
 792   (let ((bindings (mapcar #'ensure-list bindings))
 793         (*environment* (copy-lexenv *environment*)))
 794     (js!selfcall
 795       (let ((specials (remove-if-not #'special-variable-p (mapcar #'first bindings)))
 796             (body (concat (mapconcat #'let*-initialize-value bindings)
 797                           (ls-compile-block body t))))
 798         (let*-binding-wrapper specials body)))))
 799
 800
 801 (defvar *block-counter* 0)
 802
 803 (define-compilation block (name &rest body)
 804   (let* ((tr (incf *block-counter*))
 805          (b (make-binding :name name :type 'block :value tr)))
 806     (when *multiple-value-p*
 807       (push 'multiple-value (binding-declarations b)))
 808     (let* ((*environment* (extend-lexenv (list b) *environment* 'block))
 809            (cbody (ls-compile-block body t)))
 810       (if (member 'used (binding-declarations b))
 811           (js!selfcall
 812             "try {" *newline*
 813             (indent cbody)
 814             "}" *newline*
 815             "catch (cf){" *newline*
 816             "    if (cf.type == 'block' && cf.id == " tr ")" *newline*
 817             (if *multiple-value-p*
 818                 "        return values.apply(this, forcemv(cf.values));"
 819                 "        return cf.values;")
 820             *newline*
 821             "    else" *newline*
 822             "        throw cf;" *newline*
 823             "}" *newline*)
 824           (js!selfcall cbody)))))
 825
 826 (define-compilation return-from (name &optional value)
 827   (let* ((b (lookup-in-lexenv name *environment* 'block))
 828          (multiple-value-p (member 'multiple-value (binding-declarations b))))
 829     (when (null b)
 830       (error (concat "Unknown block `" (symbol-name name) "'.")))
 831     (push 'used (binding-declarations b))
 832     (js!selfcall
 833       (when multiple-value-p (code "var values = mv;" *newline*))
 834       "throw ({"
 835       "type: 'block', "
 836       "id: " (binding-value b) ", "
 837       "values: " (ls-compile value multiple-value-p) ", "
 838       "message: 'Return from unknown block " (symbol-name name) ".'"
 839       "})")))
 840
 841 (define-compilation catch (id &rest body)
 842   (js!selfcall
 843     "var id = " (ls-compile id) ";" *newline*
 844     "try {" *newline*
 845     (indent (ls-compile-block body t)) *newline*
 846     "}" *newline*
 847     "catch (cf){" *newline*
 848     "    if (cf.type == 'catch' && cf.id == id)" *newline*
 849     (if *multiple-value-p*
 850         "        return values.apply(this, forcemv(cf.values));"
 851         "        return pv.apply(this, forcemv(cf.values));")
 852     *newline*
 853     "    else" *newline*
 854     "        throw cf;" *newline*
 855     "}" *newline*))
 856
 857 (define-compilation throw (id value)
 858   (js!selfcall
 859     "var values = mv;" *newline*
 860     "throw ({"
 861     "type: 'catch', "
 862     "id: " (ls-compile id) ", "
 863     "values: " (ls-compile value t) ", "
 864     "message: 'Throw uncatched.'"
 865     "})"))
 866
 867
 868 (defvar *tagbody-counter* 0)
 869 (defvar *go-tag-counter* 0)
 870
 871 (defun go-tag-p (x)
 872   (or (integerp x) (symbolp x)))
 873
 874 (defun declare-tagbody-tags (tbidx body)
 875   (let ((bindings
 876          (mapcar (lambda (label)
 877                    (let ((tagidx (integer-to-string (incf *go-tag-counter*))))
 878                      (make-binding :name label :type 'gotag :value (list tbidx tagidx))))
 879                  (remove-if-not #'go-tag-p body))))
 880     (extend-lexenv bindings *environment* 'gotag)))
 881
 882 (define-compilation tagbody (&rest body)
 883   ;; Ignore the tagbody if it does not contain any go-tag. We do this
 884   ;; because 1) it is easy and 2) many built-in forms expand to a
 885   ;; implicit tagbody, so we save some space.
 886   (unless (some #'go-tag-p body)
 887     (return-from tagbody (ls-compile `(progn ,@body nil))))
 888   ;; The translation assumes the first form in BODY is a label
 889   (unless (go-tag-p (car body))
 890     (push (gensym "START") body))
 891   ;; Tagbody compilation
 892   (let ((tbidx *tagbody-counter*))
 893     (let ((*environment* (declare-tagbody-tags tbidx body))
 894           initag)
 895       (let ((b (lookup-in-lexenv (first body) *environment* 'gotag)))
 896         (setq initag (second (binding-value b))))
 897       (js!selfcall
 898         "var tagbody_" tbidx " = " initag ";" *newline*
 899         "tbloop:" *newline*
 900         "while (true) {" *newline*
 901         (indent "try {" *newline*
 902                 (indent (let ((content ""))
 903                           (code "switch(tagbody_" tbidx "){" *newline*
 904                                 "case " initag ":" *newline*
 905                                 (dolist (form (cdr body) content)
 906                                   (concatf content
 907                                     (if (not (go-tag-p form))
 908                                         (indent (ls-compile form) ";" *newline*)
 909                                         (let ((b (lookup-in-lexenv form *environment* 'gotag)))
 910                                           (code "case " (second (binding-value b)) ":" *newline*)))))
 911                                 "default:" *newline*
 912                                 "    break tbloop;" *newline*
 913                                 "}" *newline*)))
 914                 "}" *newline*
 915                 "catch (jump) {" *newline*
 916                 "    if (jump.type == 'tagbody' && jump.id == " tbidx ")" *newline*
 917                 "        tagbody_" tbidx " = jump.label;" *newline*
 918                 "    else" *newline*
 919                 "        throw(jump);" *newline*
 920                 "}" *newline*)
 921         "}" *newline*
 922         "return " (ls-compile nil) ";" *newline*))))
 923
 924 (define-compilation go (label)
 925   (let ((b (lookup-in-lexenv label *environment* 'gotag))
 926         (n (cond
 927              ((symbolp label) (symbol-name label))
 928              ((integerp label) (integer-to-string label)))))
 929     (when (null b)
 930       (error (concat "Unknown tag `" n "'.")))
 931     (js!selfcall
 932       "throw ({"
 933       "type: 'tagbody', "
 934       "id: " (first (binding-value b)) ", "
 935       "label: " (second (binding-value b)) ", "
 936       "message: 'Attempt to GO to non-existing tag " n "'"
 937       "})" *newline*)))
 938
 939 (define-compilation unwind-protect (form &rest clean-up)
 940   (js!selfcall
 941     "var ret = " (ls-compile nil) ";" *newline*
 942     "try {" *newline*
 943     (indent "ret = " (ls-compile form) ";" *newline*)
 944     "} finally {" *newline*
 945     (indent (ls-compile-block clean-up))
 946     "}" *newline*
 947     "return ret;" *newline*))
 948
 949 (define-compilation multiple-value-call (func-form &rest forms)
 950   (js!selfcall
 951     "var func = " (ls-compile func-form) ";" *newline*
 952     "var args = [" (if *multiple-value-p* "values" "pv") "];" *newline*
 953     "return "
 954     (js!selfcall
 955       "var values = mv;" *newline*
 956       "var vs;" *newline*
 957       (mapconcat (lambda (form)
 958                    (code "vs = " (ls-compile form t) ";" *newline*
 959                          "if (typeof vs === 'object' && 'multiple-value' in vs)" *newline*
 960                          (indent "args = args.concat(vs);" *newline*)
 961                          "else" *newline*
 962                          (indent "args.push(vs);" *newline*)))
 963                  forms)
 964       "return func.apply(window, args);" *newline*) ";" *newline*))
 965
 966 (define-compilation multiple-value-prog1 (first-form &rest forms)
 967   (js!selfcall
 968     "var args = " (ls-compile first-form *multiple-value-p*) ";" *newline*
 969     (ls-compile-block forms)
 970     "return args;" *newline*))
 971
 972
 973 ;;; Javascript FFI
 974
 975 (define-compilation %js-vref (var) var)
 976
 977 (define-compilation %js-vset (var val)
 978   (code "(" var " = " (ls-compile val) ")"))
 979
 980 (define-setf-expander %js-vref (var)
 981   (let ((new-value (gensym)))
 982     (unless (stringp var)
 983       (error "a string was expected"))
 984     (values nil
 985             (list var)
 986             (list new-value)
 987             `(%js-vset ,var ,new-value)
 988             `(%js-vref ,var))))
 989
 990
 991 ;;; Backquote implementation.
 992 ;;;
 993 ;;;    Author: Guy L. Steele Jr.     Date: 27 December 1985
 994 ;;;    Tested under Symbolics Common Lisp and Lucid Common Lisp.
 995 ;;;    This software is in the public domain.
 996
 997 ;;;    The following are unique tokens used during processing.
 998 ;;;    They need not be symbols; they need not even be atoms.
 999 (defvar *comma* 'unquote)
1000 (defvar *comma-atsign* 'unquote-splicing)
1001
1002 (defvar *bq-list* (make-symbol "BQ-LIST"))
1003 (defvar *bq-append* (make-symbol "BQ-APPEND"))
1004 (defvar *bq-list** (make-symbol "BQ-LIST*"))
1005 (defvar *bq-nconc* (make-symbol "BQ-NCONC"))
1006 (defvar *bq-clobberable* (make-symbol "BQ-CLOBBERABLE"))
1007 (defvar *bq-quote* (make-symbol "BQ-QUOTE"))
1008 (defvar *bq-quote-nil* (list *bq-quote* nil))
1009
1010 ;;; BACKQUOTE is an ordinary macro (not a read-macro) that processes
1011 ;;; the expression foo, looking for occurrences of #:COMMA,
1012 ;;; #:COMMA-ATSIGN, and #:COMMA-DOT.  It constructs code in strict
1013 ;;; accordance with the rules on pages 349-350 of the first edition
1014 ;;; (pages 528-529 of this second edition).  It then optionally
1015 ;;; applies a code simplifier.
1016
1017 ;;; If the value of *BQ-SIMPLIFY* is non-NIL, then BACKQUOTE
1018 ;;; processing applies the code simplifier.  If the value is NIL,
1019 ;;; then the code resulting from BACKQUOTE is exactly that
1020 ;;; specified by the official rules.
1021 (defparameter *bq-simplify* t)
1022
1023 (defmacro backquote (x)
1024   (bq-completely-process x))
1025
1026 ;;; Backquote processing proceeds in three stages:
1027 ;;;
1028 ;;; (1) BQ-PROCESS applies the rules to remove occurrences of
1029 ;;; #:COMMA, #:COMMA-ATSIGN, and #:COMMA-DOT corresponding to
1030 ;;; this level of BACKQUOTE.  (It also causes embedded calls to
1031 ;;; BACKQUOTE to be expanded so that nesting is properly handled.)
1032 ;;; Code is produced that is expressed in terms of functions
1033 ;;; #:BQ-LIST, #:BQ-APPEND, and #:BQ-CLOBBERABLE.  This is done
1034 ;;; so that the simplifier will simplify only list construction
1035 ;;; functions actually generated by BACKQUOTE and will not involve
1036 ;;; any user code in the simplification.  #:BQ-LIST means LIST,
1037 ;;; #:BQ-APPEND means APPEND, and #:BQ-CLOBBERABLE means IDENTITY
1038 ;;; but indicates places where "%." was used and where NCONC may
1039 ;;; therefore be introduced by the simplifier for efficiency.
1040 ;;;
1041 ;;; (2) BQ-SIMPLIFY, if used, rewrites the code produced by
1042 ;;; BQ-PROCESS to produce equivalent but faster code.  The
1043 ;;; additional functions #:BQ-LIST* and #:BQ-NCONC may be
1044 ;;; introduced into the code.
1045 ;;;
1046 ;;; (3) BQ-REMOVE-TOKENS goes through the code and replaces
1047 ;;; #:BQ-LIST with LIST, #:BQ-APPEND with APPEND, and so on.
1048 ;;; #:BQ-CLOBBERABLE is simply eliminated (a call to it being
1049 ;;; replaced by its argument).  #:BQ-LIST* is replaced by either
1050 ;;; LIST* or CONS (the latter is used in the two-argument case,
1051 ;;; purely to make the resulting code a tad more readable).
1052
1053 (defun bq-completely-process (x)
1054   (let ((raw-result (bq-process x)))
1055     (bq-remove-tokens (if *bq-simplify*
1056                           (bq-simplify raw-result)
1057                           raw-result))))
1058
1059 (defun bq-process (x)
1060   (cond ((atom x)
1061          (list *bq-quote* x))
1062         ((eq (car x) 'backquote)
1063          (bq-process (bq-completely-process (cadr x))))
1064         ((eq (car x) *comma*) (cadr x))
1065         ((eq (car x) *comma-atsign*)
1066          ;; (error ",@~S after `" (cadr x))
1067          (error "ill-formed"))
1068         ;; ((eq (car x) *comma-dot*)
1069         ;;  ;; (error ",.~S after `" (cadr x))
1070         ;;  (error "ill-formed"))
1071         (t (do ((p x (cdr p))
1072                 (q '() (cons (bracket (car p)) q)))
1073                ((atom p)
1074                 (cons *bq-append*
1075                       (nreconc q (list (list *bq-quote* p)))))
1076              (when (eq (car p) *comma*)
1077                (unless (null (cddr p))
1078                  ;; (error "Malformed ,~S" p)
1079                  (error "Malformed"))
1080                (return (cons *bq-append*
1081                              (nreconc q (list (cadr p))))))
1082              (when (eq (car p) *comma-atsign*)
1083                ;; (error "Dotted ,@~S" p)
1084                (error "Dotted"))
1085              ;; (when (eq (car p) *comma-dot*)
1086              ;;   ;; (error "Dotted ,.~S" p)
1087              ;;   (error "Dotted"))
1088              ))))
1089
1090 ;;; This implements the bracket operator of the formal rules.
1091 (defun bracket (x)
1092   (cond ((atom x)
1093          (list *bq-list* (bq-process x)))
1094         ((eq (car x) *comma*)
1095          (list *bq-list* (cadr x)))
1096         ((eq (car x) *comma-atsign*)
1097          (cadr x))
1098         ;; ((eq (car x) *comma-dot*)
1099         ;;  (list *bq-clobberable* (cadr x)))
1100         (t (list *bq-list* (bq-process x)))))
1101
1102 ;;; This auxiliary function is like MAPCAR but has two extra
1103 ;;; purposes: (1) it handles dotted lists; (2) it tries to make
1104 ;;; the result share with the argument x as much as possible.
1105 (defun maptree (fn x)
1106   (if (atom x)
1107       (funcall fn x)
1108       (let ((a (funcall fn (car x)))
1109             (d (maptree fn (cdr x))))
1110         (if (and (eql a (car x)) (eql d (cdr x)))
1111             x
1112             (cons a d)))))
1113
1114 ;;; This predicate is true of a form that when read looked
1115 ;;; like %@foo or %.foo.
1116 (defun bq-splicing-frob (x)
1117   (and (consp x)
1118        (or (eq (car x) *comma-atsign*)
1119            ;; (eq (car x) *comma-dot*)
1120            )))
1121
1122 ;;; This predicate is true of a form that when read
1123 ;;; looked like %@foo or %.foo or just plain %foo.
1124 (defun bq-frob (x)
1125   (and (consp x)
1126        (or (eq (car x) *comma*)
1127            (eq (car x) *comma-atsign*)
1128            ;; (eq (car x) *comma-dot*)
1129            )))
1130
1131 ;;; The simplifier essentially looks for calls to #:BQ-APPEND and
1132 ;;; tries to simplify them.  The arguments to #:BQ-APPEND are
1133 ;;; processed from right to left, building up a replacement form.
1134 ;;; At each step a number of special cases are handled that,
1135 ;;; loosely speaking, look like this:
1136 ;;;
1137 ;;;  (APPEND (LIST a b c) foo) => (LIST* a b c foo)
1138 ;;;       provided a, b, c are not splicing frobs
1139 ;;;  (APPEND (LIST* a b c) foo) => (LIST* a b (APPEND c foo))
1140 ;;;       provided a, b, c are not splicing frobs
1141 ;;;  (APPEND (QUOTE (x)) foo) => (LIST* (QUOTE x) foo)
1142 ;;;  (APPEND (CLOBBERABLE x) foo) => (NCONC x foo)
1143 (defun bq-simplify (x)
1144   (if (atom x)
1145       x
1146       (let ((x (if (eq (car x) *bq-quote*)
1147                    x
1148                    (maptree #'bq-simplify x))))
1149         (if (not (eq (car x) *bq-append*))
1150             x
1151             (bq-simplify-args x)))))
1152
1153 (defun bq-simplify-args (x)
1154   (do ((args (reverse (cdr x)) (cdr args))
1155        (result
1156          nil
1157          (cond ((atom (car args))
1158                 (bq-attach-append *bq-append* (car args) result))
1159                ((and (eq (caar args) *bq-list*)
1160                      (notany #'bq-splicing-frob (cdar args)))
1161                 (bq-attach-conses (cdar args) result))
1162                ((and (eq (caar args) *bq-list**)
1163                      (notany #'bq-splicing-frob (cdar args)))
1164                 (bq-attach-conses
1165                   (reverse (cdr (reverse (cdar args))))
1166                   (bq-attach-append *bq-append*
1167                                     (car (last (car args)))
1168                                     result)))
1169                ((and (eq (caar args) *bq-quote*)
1170                      (consp (cadar args))
1171                      (not (bq-frob (cadar args)))
1172                      (null (cddar args)))
1173                 (bq-attach-conses (list (list *bq-quote*
1174                                               (caadar args)))
1175                                   result))
1176                ((eq (caar args) *bq-clobberable*)
1177                 (bq-attach-append *bq-nconc* (cadar args) result))
1178                (t (bq-attach-append *bq-append*
1179                                     (car args)
1180                                     result)))))
1181       ((null args) result)))
1182
1183 (defun null-or-quoted (x)
1184   (or (null x) (and (consp x) (eq (car x) *bq-quote*))))
1185
1186 ;;; When BQ-ATTACH-APPEND is called, the OP should be #:BQ-APPEND
1187 ;;; or #:BQ-NCONC.  This produces a form (op item result) but
1188 ;;; some simplifications are done on the fly:
1189 ;;;
1190 ;;;  (op '(a b c) '(d e f g)) => '(a b c d e f g)
1191 ;;;  (op item 'nil) => item, provided item is not a splicable frob
1192 ;;;  (op item 'nil) => (op item), if item is a splicable frob
1193 ;;;  (op item (op a b c)) => (op item a b c)
1194 (defun bq-attach-append (op item result)
1195   (cond ((and (null-or-quoted item) (null-or-quoted result))
1196          (list *bq-quote* (append (cadr item) (cadr result))))
1197         ((or (null result) (equal result *bq-quote-nil*))
1198          (if (bq-splicing-frob item) (list op item) item))
1199         ((and (consp result) (eq (car result) op))
1200          (list* (car result) item (cdr result)))
1201         (t (list op item result))))
1202
1203 ;;; The effect of BQ-ATTACH-CONSES is to produce a form as if by
1204 ;;; `(LIST* ,@items ,result) but some simplifications are done
1205 ;;; on the fly.
1206 ;;;
1207 ;;;  (LIST* 'a 'b 'c 'd) => '(a b c . d)
1208 ;;;  (LIST* a b c 'nil) => (LIST a b c)
1209 ;;;  (LIST* a b c (LIST* d e f g)) => (LIST* a b c d e f g)
1210 ;;;  (LIST* a b c (LIST d e f g)) => (LIST a b c d e f g)
1211 (defun bq-attach-conses (items result)
1212   (cond ((and (every #'null-or-quoted items)
1213               (null-or-quoted result))
1214          (list *bq-quote*
1215                (append (mapcar #'cadr items) (cadr result))))
1216         ((or (null result) (equal result *bq-quote-nil*))
1217          (cons *bq-list* items))
1218         ((and (consp result)
1219               (or (eq (car result) *bq-list*)
1220                   (eq (car result) *bq-list**)))
1221          (cons (car result) (append items (cdr result))))
1222         (t (cons *bq-list** (append items (list result))))))
1223
1224 ;;; Removes funny tokens and changes (#:BQ-LIST* a b) into
1225 ;;; (CONS a b) instead of (LIST* a b), purely for readability.
1226 (defun bq-remove-tokens (x)
1227   (cond ((eq x *bq-list*) 'list)
1228         ((eq x *bq-append*) 'append)
1229         ((eq x *bq-nconc*) 'nconc)
1230         ((eq x *bq-list**) 'list*)
1231         ((eq x *bq-quote*) 'quote)
1232         ((atom x) x)
1233         ((eq (car x) *bq-clobberable*)
1234          (bq-remove-tokens (cadr x)))
1235         ((and (eq (car x) *bq-list**)
1236               (consp (cddr x))
1237               (null (cdddr x)))
1238          (cons 'cons (maptree #'bq-remove-tokens (cdr x))))
1239         (t (maptree #'bq-remove-tokens x))))
1240
1241 (define-transformation backquote (form)
1242   (bq-completely-process form))
1243
1244
1245 ;;; Primitives
1246
1247 (defvar *builtins* nil)
1248
1249 (defmacro define-raw-builtin (name args &body body)
1250   ;; Creates a new primitive function `name' with parameters args and
1251   ;; @body. The body can access to the local environment through the
1252   ;; variable *ENVIRONMENT*.
1253   `(push (list ',name (lambda ,args (block ,name ,@body)))
1254          *builtins*))
1255
1256 (defmacro define-builtin (name args &body body)
1257   `(define-raw-builtin ,name ,args
1258      (let ,(mapcar (lambda (arg) `(,arg (ls-compile ,arg))) args)
1259        ,@body)))
1260
1261 ;;; DECLS is a list of (JSVARNAME TYPE LISPFORM) declarations.
1262 (defmacro type-check (decls &body body)
1263   `(js!selfcall
1264      ,@(mapcar (lambda (decl)
1265                  `(code "var " ,(first decl) " = " ,(third decl) ";" *newline*))
1266                decls)
1267      ,@(mapcar (lambda (decl)
1268                  `(code "if (typeof " ,(first decl) " != '" ,(second decl) "')" *newline*
1269                         (indent "throw 'The value ' + "
1270                                 ,(first decl)
1271                                 " + ' is not a type "
1272                                 ,(second decl)
1273                                 ".';"
1274                                 *newline*)))
1275                decls)
1276      (code "return " (progn ,@body) ";" *newline*)))
1277
1278 ;;; VARIABLE-ARITY compiles variable arity operations. ARGS stands for
1279 ;;; a variable which holds a list of forms. It will compile them and
1280 ;;; store the result in some Javascript variables. BODY is evaluated
1281 ;;; with ARGS bound to the list of these variables to generate the
1282 ;;; code which performs the transformation on these variables.
1283
1284 (defun variable-arity-call (args function)
1285   (unless (consp args)
1286     (error "ARGS must be a non-empty list"))
1287   (let ((counter 0)
1288         (fargs '())
1289         (prelude ""))
1290     (dolist (x args)
1291       (cond
1292         ((floatp x) (push (float-to-string x) fargs))
1293         ((numberp x) (push (integer-to-string x) fargs))
1294         (t (let ((v (code "x" (incf counter))))
1295              (push v fargs)
1296              (concatf prelude
1297                (code "var " v " = " (ls-compile x) ";" *newline*
1298                      "if (typeof " v " !== 'number') throw 'Not a number!';"
1299                      *newline*))))))
1300     (js!selfcall prelude (funcall function (reverse fargs)))))
1301
1302
1303 (defmacro variable-arity (args &body body)
1304   (unless (symbolp args)
1305     (error "Bad usage of VARIABLE-ARITY, you must pass a symbol"))
1306   `(variable-arity-call ,args
1307                         (lambda (,args)
1308                           (code "return " ,@body ";" *newline*))))
1309
1310 (defun num-op-num (x op y)
1311   (type-check (("x" "number" x) ("y" "number" y))
1312     (code "x" op "y")))
1313
1314 (define-raw-builtin + (&rest numbers)
1315   (if (null numbers)
1316       "0"
1317       (variable-arity numbers
1318         (join numbers "+"))))
1319
1320 (define-raw-builtin - (x &rest others)
1321   (let ((args (cons x others)))
1322     (variable-arity args
1323       (if (null others)
1324           (concat "-" (car args))
1325           (join args "-")))))
1326
1327 (define-raw-builtin * (&rest numbers)
1328   (if (null numbers)
1329       "1"
1330       (variable-arity numbers
1331         (join numbers "*"))))
1332
1333 (define-raw-builtin / (x &rest others)
1334   (let ((args (cons x others)))
1335     (variable-arity args
1336       (if (null others)
1337           (concat "1 /" (car args))
1338           (join args "/")))))
1339
1340 (define-builtin mod (x y) (num-op-num x "%" y))
1341
1342
1343 (defun comparison-conjuntion (vars op)
1344   (cond
1345     ((null (cdr vars))
1346      "true")
1347     ((null (cddr vars))
1348      (concat (car vars) op (cadr vars)))
1349     (t
1350      (concat (car vars) op (cadr vars)
1351              " && "
1352              (comparison-conjuntion (cdr vars) op)))))
1353
1354 (defmacro define-builtin-comparison (op sym)
1355   `(define-raw-builtin ,op (x &rest args)
1356      (let ((args (cons x args)))
1357        (variable-arity args
1358          (js!bool (comparison-conjuntion args ,sym))))))
1359
1360 (define-builtin-comparison > ">")
1361 (define-builtin-comparison < "<")
1362 (define-builtin-comparison >= ">=")
1363 (define-builtin-comparison <= "<=")
1364 (define-builtin-comparison = "==")
1365
1366 (define-builtin numberp (x)
1367   (js!bool (code "(typeof (" x ") == \"number\")")))
1368
1369 (define-builtin floor (x)
1370   (type-check (("x" "number" x))
1371     "Math.floor(x)"))
1372
1373 (define-builtin expt (x y)
1374   (type-check (("x" "number" x)
1375                ("y" "number" y))
1376     "Math.pow(x, y)"))
1377
1378 (define-builtin float-to-string (x)
1379   (type-check (("x" "number" x))
1380     "x.toString()"))
1381
1382 (define-builtin cons (x y)
1383   (code "({car: " x ", cdr: " y "})"))
1384
1385 (define-builtin consp (x)
1386   (js!bool
1387    (js!selfcall
1388      "var tmp = " x ";" *newline*
1389      "return (typeof tmp == 'object' && 'car' in tmp);" *newline*)))
1390
1391 (define-builtin car (x)
1392   (js!selfcall
1393     "var tmp = " x ";" *newline*
1394     "return tmp === " (ls-compile nil)
1395     "? " (ls-compile nil)
1396     ": tmp.car;" *newline*))
1397
1398 (define-builtin cdr (x)
1399   (js!selfcall
1400     "var tmp = " x ";" *newline*
1401     "return tmp === " (ls-compile nil) "? "
1402     (ls-compile nil)
1403     ": tmp.cdr;" *newline*))
1404
1405 (define-builtin rplaca (x new)
1406   (type-check (("x" "object" x))
1407     (code "(x.car = " new ", x)")))
1408
1409 (define-builtin rplacd (x new)
1410   (type-check (("x" "object" x))
1411     (code "(x.cdr = " new ", x)")))
1412
1413 (define-builtin symbolp (x)
1414   (js!bool
1415    (js!selfcall
1416      "var tmp = " x ";" *newline*
1417      "return (typeof tmp == 'object' && 'name' in tmp);" *newline*)))
1418
1419 (define-builtin make-symbol (name)
1420   (type-check (("name" "string" name))
1421     "({name: name})"))
1422
1423 (define-builtin symbol-name (x)
1424   (code "(" x ").name"))
1425
1426 (define-builtin set (symbol value)
1427   (code "(" symbol ").value = " value))
1428
1429 (define-builtin fset (symbol value)
1430   (code "(" symbol ").fvalue = " value))
1431
1432 (define-builtin boundp (x)
1433   (js!bool (code "(" x ".value !== undefined)")))
1434
1435 (define-builtin symbol-value (x)
1436   (js!selfcall
1437     "var symbol = " x ";" *newline*
1438     "var value = symbol.value;" *newline*
1439     "if (value === undefined) throw \"Variable `\" + symbol.name + \"' is unbound.\";" *newline*
1440     "return value;" *newline*))
1441
1442 (define-builtin symbol-function (x)
1443   (js!selfcall
1444     "var symbol = " x ";" *newline*
1445     "var func = symbol.fvalue;" *newline*
1446     "if (func === undefined) throw \"Function `\" + symbol.name + \"' is undefined.\";" *newline*
1447     "return func;" *newline*))
1448
1449 (define-builtin symbol-plist (x)
1450   (code "((" x ").plist || " (ls-compile nil) ")"))
1451
1452 (define-builtin lambda-code (x)
1453   (code "(" x ").toString()"))
1454
1455 (define-builtin eq    (x y) (js!bool (code "(" x " === " y ")")))
1456
1457 (define-builtin char-to-string (x)
1458   (type-check (("x" "number" x))
1459     "String.fromCharCode(x)"))
1460
1461 (define-builtin stringp (x)
1462   (js!bool (code "(typeof(" x ") == \"string\")")))
1463
1464 (define-builtin string-upcase (x)
1465   (type-check (("x" "string" x))
1466     "x.toUpperCase()"))
1467
1468 (define-builtin string-length (x)
1469   (type-check (("x" "string" x))
1470     "x.length"))
1471
1472 (define-raw-builtin slice (string a &optional b)
1473   (js!selfcall
1474     "var str = " (ls-compile string) ";" *newline*
1475     "var a = " (ls-compile a) ";" *newline*
1476     "var b;" *newline*
1477     (when b (code "b = " (ls-compile b) ";" *newline*))
1478     "return str.slice(a,b);" *newline*))
1479
1480 (define-builtin char (string index)
1481   (type-check (("string" "string" string)
1482                ("index" "number" index))
1483     "string.charCodeAt(index)"))
1484
1485 (define-builtin concat-two (string1 string2)
1486   (type-check (("string1" "string" string1)
1487                ("string2" "string" string2))
1488     "string1.concat(string2)"))
1489
1490 (define-raw-builtin funcall (func &rest args)
1491   (js!selfcall
1492     "var f = " (ls-compile func) ";" *newline*
1493     "return (typeof f === 'function'? f: f.fvalue)("
1494     (join (cons (if *multiple-value-p* "values" "pv")
1495                 (mapcar #'ls-compile args))
1496           ", ")
1497     ")"))
1498
1499 (define-raw-builtin apply (func &rest args)
1500   (if (null args)
1501       (code "(" (ls-compile func) ")()")
1502       (let ((args (butlast args))
1503             (last (car (last args))))
1504         (js!selfcall
1505           "var f = " (ls-compile func) ";" *newline*
1506           "var args = [" (join (cons (if *multiple-value-p* "values" "pv")
1507                                      (mapcar #'ls-compile args))
1508                                ", ")
1509           "];" *newline*
1510           "var tail = (" (ls-compile last) ");" *newline*
1511           "while (tail != " (ls-compile nil) "){" *newline*
1512           "    args.push(tail.car);" *newline*
1513           "    tail = tail.cdr;" *newline*
1514           "}" *newline*
1515           "return (typeof f === 'function'? f : f.fvalue).apply(this, args);" *newline*))))
1516
1517 (define-builtin js-eval (string)
1518   (type-check (("string" "string" string))
1519     (if *multiple-value-p*
1520         (js!selfcall
1521           "var v = globalEval(string);" *newline*
1522           "if (typeof v !== 'object' || !('multiple-value' in v)){" *newline*
1523           (indent "v = [v];" *newline*
1524                   "v['multiple-value'] = true;" *newline*)
1525           "}" *newline*
1526           "return values.apply(this, v);" *newline*)
1527         "globalEval(string)")))
1528
1529 (define-builtin error (string)
1530   (js!selfcall "throw " string ";" *newline*))
1531
1532 (define-builtin new () "{}")
1533
1534 (define-builtin objectp (x)
1535   (js!bool (code "(typeof (" x ") === 'object')")))
1536
1537 (define-builtin oget (object key)
1538   (js!selfcall
1539     "var tmp = " "(" object ")[" key "];" *newline*
1540     "return tmp == undefined? " (ls-compile nil) ": tmp ;" *newline*))
1541
1542 (define-builtin oset (object key value)
1543   (code "((" object ")[" key "] = " value ")"))
1544
1545 (define-builtin in (key object)
1546   (js!bool (code "((" key ") in (" object "))")))
1547
1548 (define-builtin functionp (x)
1549   (js!bool (code "(typeof " x " == 'function')")))
1550
1551 (define-builtin write-string (x)
1552   (type-check (("x" "string" x))
1553     "lisp.write(x)"))
1554
1555 (define-builtin make-array (n)
1556   (js!selfcall
1557     "var r = [];" *newline*
1558     "for (var i = 0; i < " n "; i++)" *newline*
1559     (indent "r.push(" (ls-compile nil) ");" *newline*)
1560     "return r;" *newline*))
1561
1562 (define-builtin arrayp (x)
1563   (js!bool
1564    (js!selfcall
1565      "var x = " x ";" *newline*
1566      "return typeof x === 'object' && 'length' in x;")))
1567
1568 (define-builtin aref (array n)
1569   (js!selfcall
1570     "var x = " "(" array ")[" n "];" *newline*
1571     "if (x === undefined) throw 'Out of range';" *newline*
1572     "return x;" *newline*))
1573
1574 (define-builtin aset (array n value)
1575   (js!selfcall
1576     "var x = " array ";" *newline*
1577     "var i = " n ";" *newline*
1578     "if (i < 0 || i >= x.length) throw 'Out of range';" *newline*
1579     "return x[i] = " value ";" *newline*))
1580
1581 (define-builtin get-internal-real-time ()
1582   "(new Date()).getTime()")
1583
1584 (define-builtin values-array (array)
1585   (if *multiple-value-p*
1586       (code "values.apply(this, " array ")")
1587       (code "pv.apply(this, " array ")")))
1588
1589 (define-raw-builtin values (&rest args)
1590   (if *multiple-value-p*
1591       (code "values(" (join (mapcar #'ls-compile args) ", ") ")")
1592       (code "pv(" (join (mapcar #'ls-compile args) ", ") ")")))
1593
1594 ;; Receives the JS function as first argument as a literal string. The
1595 ;; second argument is compiled and should evaluate to a vector of
1596 ;; values to apply to the the function. The result returned.
1597 (define-builtin %js-call (fun args)
1598   (code fun ".apply(this, " args ")"))
1599
1600 (defun macro (x)
1601   (and (symbolp x)
1602        (let ((b (lookup-in-lexenv x *environment* 'function)))
1603          (if (and b (eq (binding-type b) 'macro))
1604              b
1605              nil))))
1606
1607 #+common-lisp
1608 (defvar *macroexpander-cache*
1609   (make-hash-table :test #'eq))
1610
1611 (defun ls-macroexpand-1 (form)
1612   (cond
1613     ((symbolp form)
1614      (let ((b (lookup-in-lexenv form *environment* 'variable)))
1615        (if (and b (eq (binding-type b) 'macro))
1616            (values (binding-value b) t)
1617            (values form nil))))
1618     ((consp form)
1619      (let ((macro-binding (macro (car form))))
1620        (if macro-binding
1621            (let ((expander (binding-value macro-binding)))
1622              (cond
1623                #+common-lisp
1624                ((gethash macro-binding *macroexpander-cache*)
1625                 (setq expander (gethash macro-binding *macroexpander-cache*)))
1626                ((listp expander)
1627                 (let ((compiled (eval expander)))
1628                   ;; The list representation are useful while
1629                   ;; bootstrapping, as we can dump the definition of the
1630                   ;; macros easily, but they are slow because we have to
1631                   ;; evaluate them and compile them now and again. So, let
1632                   ;; us replace the list representation version of the
1633                   ;; function with the compiled one.
1634                   ;;
1635                   #+jscl (setf (binding-value macro-binding) compiled)
1636                   #+common-lisp (setf (gethash macro-binding *macroexpander-cache*) compiled)
1637                   (setq expander compiled))))
1638              (values (apply expander (cdr form)) t))
1639            (values form nil))))
1640     (t
1641      (values form nil))))
1642
1643 (defun compile-funcall (function args)
1644   (let* ((values-funcs (if *multiple-value-p* "values" "pv"))
1645          (arglist (concat "(" (join (cons values-funcs (mapcar #'ls-compile args)) ", ") ")")))
1646     (unless (or (symbolp function)
1647                 (and (consp function)
1648                      (eq (car function) 'lambda)))
1649       (error "Bad function"))
1650     (cond
1651       ((translate-function function)
1652        (concat (translate-function function) arglist))
1653       ((and (symbolp function)
1654             #+jscl (eq (symbol-package function) (find-package "COMMON-LISP"))
1655             #+common-lisp t)
1656        (code (ls-compile `',function) ".fvalue" arglist))
1657       (t
1658        (code (ls-compile `#',function) arglist)))))
1659
1660 (defun ls-compile-block (sexps &optional return-last-p)
1661   (if return-last-p
1662       (code (ls-compile-block (butlast sexps))
1663             "return " (ls-compile (car (last sexps)) *multiple-value-p*) ";")
1664       (join-trailing
1665        (remove-if #'null-or-empty-p (mapcar #'ls-compile sexps))
1666        (concat ";" *newline*))))
1667
1668 (defun ls-compile (sexp &optional multiple-value-p)
1669   (multiple-value-bind (sexp expandedp) (ls-macroexpand-1 sexp)
1670     (when expandedp
1671       (return-from ls-compile (ls-compile sexp multiple-value-p)))
1672     ;; The expression has been macroexpanded. Now compile it!
1673     (let ((*multiple-value-p* multiple-value-p))
1674       (cond
1675         ((symbolp sexp)
1676          (let ((b (lookup-in-lexenv sexp *environment* 'variable)))
1677            (cond
1678              ((and b (not (member 'special (binding-declarations b))))
1679               (binding-value b))
1680              ((or (keywordp sexp)
1681                   (and b (member 'constant (binding-declarations b))))
1682               (code (ls-compile `',sexp) ".value"))
1683              (t
1684               (ls-compile `(symbol-value ',sexp))))))
1685         ((integerp sexp) (integer-to-string sexp))
1686         ((floatp sexp) (float-to-string sexp))
1687         ((stringp sexp) (code "\"" (escape-string sexp) "\""))
1688         ((arrayp sexp) (literal sexp))
1689         ((listp sexp)
1690          (let ((name (car sexp))
1691                (args (cdr sexp)))
1692            (cond
1693              ;; Special forms
1694              ((assoc name *compilations*)
1695               (let ((comp (second (assoc name *compilations*))))
1696                 (apply comp args)))
1697              ;; Built-in functions
1698              ((and (assoc name *builtins*)
1699                    (not (claimp name 'function 'notinline)))
1700               (let ((comp (second (assoc name *builtins*))))
1701                 (apply comp args)))
1702              (t
1703               (compile-funcall name args)))))
1704         (t
1705          (error (concat "How should I compile " (prin1-to-string sexp) "?")))))))
1706
1707
1708 (defvar *compile-print-toplevels* nil)
1709
1710 (defun truncate-string (string &optional (width 60))
1711   (let ((n (or (position #\newline string)
1712                (min width (length string)))))
1713     (subseq string 0 n)))
1714
1715 (defun ls-compile-toplevel (sexp &optional multiple-value-p)
1716   (let ((*toplevel-compilations* nil))
1717     (cond
1718       ((and (consp sexp) (eq (car sexp) 'progn))
1719        (let ((subs (mapcar (lambda (s)
1720                              (ls-compile-toplevel s t))
1721                            (cdr sexp))))
1722          (join (remove-if #'null-or-empty-p subs))))
1723       (t
1724        (when *compile-print-toplevels*
1725          (let ((form-string (prin1-to-string sexp)))
1726            (write-string "Compiling ")
1727            (write-string (truncate-string form-string))
1728            (write-line "...")))
1729
1730        (let ((code (ls-compile sexp multiple-value-p)))
1731          (code (join-trailing (get-toplevel-compilations)
1732                               (code ";" *newline*))
1733                (when code
1734                  (code code ";" *newline*))))))))