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