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