lispstrack.lisp

   1 ;;; lispstrack.lisp ---
   2
   3 ;; Copyright (C) 2012 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 ;;; This code is executed when lispstrack compiles this file
  20 ;;; itself. The compiler provides compilation of some special forms,
  21 ;;; as well as funcalls and macroexpansion, but no functions. So, we
  22 ;;; define the Lisp world from scratch. This code has to define enough
  23 ;;; language to the compiler to be able to run.
  24 #+lispstrack
  25 (progn
  26  (eval-when-compile
  27    (%compile-defmacro 'defmacro
  28                       '(lambda (name args &rest body)
  29                         `(eval-when-compile
  30                            (%compile-defmacro ',name '(lambda ,args ,@body))))))
  31
  32  (defmacro %defvar (name value)
  33    `(progn
  34       (eval-when-compile
  35         (%compile-defvar ',name))
  36       (setq ,name ,value)))
  37
  38   (defmacro defvar (name &optional value)
  39     `(%defvar ,name ,value))
  40
  41  (defmacro %defun (name args &rest body)
  42    `(progn
  43       (eval-when-compile
  44         (%compile-defun ',name))
  45       (fsetq ,name (lambda ,args ,@body))))
  46
  47   (defmacro defun (name args &rest body)
  48     `(%defun ,name ,args ,@body))
  49
  50  (defvar *package* (new))
  51
  52  (defvar nil (make-symbol "NIL"))
  53  (set *package* "NIL" nil)
  54
  55  (defvar t (make-symbol "T"))
  56  (set *package* "T" t)
  57
  58  (defun internp (name)
  59    (in name *package*))
  60
  61  (defun intern (name)
  62    (if (internp name)
  63        (get *package* name)
  64        (set *package* name (make-symbol name))))
  65
  66  (defun find-symbol (name)
  67    (get *package* name))
  68
  69  ;; Basic functions
  70  (defun = (x y) (= x y))
  71  (defun + (x y) (+ x y))
  72  (defun - (x y) (- x y))
  73  (defun * (x y) (* x y))
  74  (defun / (x y) (/ x y))
  75  (defun 1+ (x) (+ x 1))
  76  (defun 1- (x) (- x 1))
  77  (defun zerop (x) (= x 0))
  78  (defun truncate (x y) (floor (/ x y)))
  79
  80  (defun eql (x y) (eq x y))
  81
  82  (defun not (x) (if x nil t))
  83
  84  (defun cons (x y ) (cons x y))
  85  (defun consp (x) (consp x))
  86  (defun car (x) (car x))
  87  (defun cdr (x) (cdr x))
  88  (defun caar (x) (car (car x)))
  89  (defun cadr (x) (car (cdr x)))
  90  (defun cdar (x) (cdr (car x)))
  91  (defun cddr (x) (cdr (cdr x)))
  92  (defun caddr (x) (car (cdr (cdr x))))
  93  (defun cdddr (x) (cdr (cdr (cdr x))))
  94  (defun cadddr (x) (car (cdr (cdr (cdr x)))))
  95  (defun first (x) (car x))
  96  (defun second (x) (cadr x))
  97  (defun third (x) (caddr x))
  98  (defun fourth (x) (cadddr x))
  99
 100  (defun list (&rest args) args)
 101  (defun atom (x)
 102    (not (consp x)))
 103
 104  ;; Basic macros
 105
 106   (defmacro incf (x &optional (delta 1))
 107     `(setq ,x (+ ,x ,delta)))
 108
 109   (defmacro decf (x &optional (delta 1))
 110     `(setq ,x (- ,x ,delta)))
 111
 112  (defmacro push (x place)
 113    `(setq ,place (cons ,x ,place)))
 114
 115  (defmacro when (condition &rest body)
 116    `(if ,condition (progn ,@body) nil))
 117
 118  (defmacro unless (condition &rest body)
 119    `(if ,condition nil (progn ,@body)))
 120
 121  (defmacro dolist (iter &rest body)
 122    (let ((var (first iter))
 123          (g!list (make-symbol "LIST")))
 124      `(let ((,g!list ,(second iter))
 125             (,var nil))
 126         (while ,g!list
 127           (setq ,var (car ,g!list))
 128           ,@body
 129           (setq ,g!list (cdr ,g!list))))))
 130
 131  (defmacro cond (&rest clausules)
 132    (if (null clausules)
 133        nil
 134        (if (eq (caar clausules) t)
 135            `(progn ,@(cdar clausules))
 136            `(if ,(caar clausules)
 137                 (progn ,@(cdar clausules))
 138                 (cond ,@(cdr clausules))))))
 139
 140  (defmacro case (form &rest clausules)
 141    (let ((!form (make-symbol "FORM")))
 142      `(let ((,!form ,form))
 143         (cond
 144           ,@(mapcar (lambda (clausule)
 145                       (if (eq (car clausule) t)
 146                           clausule
 147                           `((eql ,!form ,(car clausule))
 148                             ,@(cdr clausule))))
 149                     clausules)))))
 150
 151   (defmacro ecase (form &rest clausules)
 152     `(case ,form
 153        ,@(append
 154           clausules
 155           `((t
 156              (error "ECASE expression failed."))))))
 157
 158   (defmacro and (&rest forms)
 159     (cond
 160       ((null forms)
 161        t)
 162       ((null (cdr forms))
 163        (car forms))
 164       (t
 165        `(if ,(car forms)
 166             (and ,@(cdr forms))
 167             nil))))
 168
 169   (defmacro or (&rest forms)
 170     (cond
 171       ((null forms)
 172        nil)
 173       ((null (cdr forms))
 174        (car forms))
 175       (t
 176        (let ((g (make-symbol "VAR")))
 177          `(let ((,g ,(car forms)))
 178             (if ,g ,g (or ,@(cdr forms))))))))
 179
 180     (defmacro prog1 (form &rest body)
 181       (let ((value (make-symbol "VALUE")))
 182         `(let ((,value ,form))
 183            ,@body
 184            ,value))))
 185
 186 ;;; This couple of helper functions will be defined in both Common
 187 ;;; Lisp and in Lispstrack.
 188 (defun ensure-list (x)
 189   (if (listp x)
 190       x
 191       (list x)))
 192
 193 (defun !reduce (func list initial)
 194   (if (null list)
 195       initial
 196       (!reduce func
 197                (cdr list)
 198                (funcall func initial (car list)))))
 199
 200 ;;; Go on growing the Lisp language in Lispstrack, with more high
 201 ;;; level utilities as well as correct versions of other
 202 ;;; constructions.
 203 #+lispstrack
 204 (progn
 205   (defmacro defun (name args &rest body)
 206     `(progn
 207        (%defun ,name ,args ,@body)
 208        ',name))
 209
 210   (defmacro defvar (name &optional value)
 211     `(progn
 212        (%defvar ,name ,value)
 213        ',name))
 214
 215   (defun append-two (list1 list2)
 216     (if (null list1)
 217         list2
 218         (cons (car list1)
 219               (append (cdr list1) list2))))
 220
 221   (defun append (&rest lists)
 222     (!reduce #'append-two lists '()))
 223
 224   (defun reverse-aux (list acc)
 225     (if (null list)
 226         acc
 227         (reverse-aux (cdr list) (cons (car list) acc))))
 228
 229   (defun reverse (list)
 230     (reverse-aux list '()))
 231
 232   (defun list-length (list)
 233     (let ((l 0))
 234       (while (not (null list))
 235         (incf l)
 236         (setq list (cdr list)))
 237       l))
 238
 239   (defun length (seq)
 240     (if (stringp seq)
 241         (string-length seq)
 242         (list-length seq)))
 243
 244   (defun concat-two (s1 s2)
 245     (concat-two s1 s2))
 246
 247   (defun mapcar (func list)
 248     (if (null list)
 249         '()
 250         (cons (funcall func (car list))
 251               (mapcar func (cdr list)))))
 252
 253   (defun code-char (x) x)
 254   (defun char-code (x) x)
 255   (defun char= (x y) (= x y))
 256
 257   (defun <= (x y) (or (< x y) (= x y)))
 258   (defun >= (x y) (not (< x y)))
 259
 260   (defun integerp (x)
 261     (and (numberp x) (= (floor x) x)))
 262
 263   (defun plusp (x) (< 0 x))
 264   (defun minusp (x) (< x 0))
 265
 266   (defun listp (x)
 267     (or (consp x) (null x)))
 268
 269   (defun nth (n list)
 270     (cond
 271       ((null list) list)
 272       ((zerop n) (car list))
 273       (t (nth (1- n) (cdr list)))))
 274
 275   (defun last (x)
 276     (if (null (cdr x))
 277         x
 278         (last (cdr x))))
 279
 280   (defun butlast (x)
 281     (if (null (cdr x))
 282         nil
 283         (cons (car x) (butlast (cdr x)))))
 284
 285   (defun member (x list)
 286     (cond
 287       ((null list)
 288        nil)
 289       ((eql x (car list))
 290        list)
 291       (t
 292        (member x (cdr list)))))
 293
 294   (defun remove (x list)
 295     (cond
 296       ((null list)
 297        nil)
 298       ((eql x (car list))
 299        (remove x (cdr list)))
 300       (t
 301        (cons (car list) (remove x (cdr list))))))
 302
 303   (defun remove-if (func list)
 304     (cond
 305       ((null list)
 306        nil)
 307       ((funcall func (car list))
 308        (remove-if func (cdr list)))
 309       (t
 310        (cons (car list) (remove-if func (cdr list))))))
 311
 312   (defun remove-if-not (func list)
 313     (cond
 314       ((null list)
 315        nil)
 316       ((funcall func (car list))
 317        (cons (car list) (remove-if-not func (cdr list))))
 318       (t
 319        (remove-if-not func (cdr list)))))
 320
 321   (defun digit-char-p (x)
 322     (if (and (<= #\0 x) (<= x #\9))
 323         (- x #\0)
 324         nil))
 325
 326   (defun subseq (seq a &optional b)
 327     (cond
 328      ((stringp seq)
 329       (if b
 330           (slice seq a b)
 331           (slice seq a)))
 332      (t
 333       (error "Unsupported argument."))))
 334
 335   (defun parse-integer (string)
 336     (let ((value 0)
 337           (index 0)
 338           (size (length string)))
 339       (while (< index size)
 340         (setq value (+ (* value 10) (digit-char-p (char string index))))
 341         (incf index))
 342       value))
 343
 344   (defun every (function seq)
 345     ;; string
 346     (let ((ret t)
 347           (index 0)
 348           (size (length seq)))
 349       (while (and ret (< index size))
 350         (unless (funcall function (char seq index))
 351           (setq ret nil))
 352         (incf index))
 353       ret))
 354
 355   (defun assoc (x alist)
 356     (cond
 357       ((null alist)
 358        nil)
 359       ((eql x (caar alist))
 360        (car alist))
 361       (t
 362        (assoc x (cdr alist)))))
 363
 364   (defun string= (s1 s2)
 365     (equal s1 s2)))
 366
 367
 368 ;;; The compiler offers some primitives and special forms which are
 369 ;;; not found in Common Lisp, for instance, while. So, we grow Common
 370 ;;; Lisp a bit to it can execute the rest of the file.
 371 #+common-lisp
 372 (progn
 373   (defmacro while (condition &body body)
 374     `(do ()
 375          ((not ,condition))
 376        ,@body))
 377
 378   (defmacro eval-when-compile (&body body)
 379     `(eval-when (:compile-toplevel :load-toplevel :execute)
 380        ,@body))
 381
 382   (defun concat-two (s1 s2)
 383     (concatenate 'string s1 s2))
 384
 385   (defun setcar (cons new)
 386     (setf (car cons) new))
 387   (defun setcdr (cons new)
 388     (setf (cdr cons) new)))
 389
 390
 391 ;;; At this point, no matter if Common Lisp or lispstrack is compiling
 392 ;;; from here, this code will compile on both. We define some helper
 393 ;;; functions now for string manipulation and so on. They will be
 394 ;;; useful in the compiler, mostly.
 395
 396 (defvar *newline* (string (code-char 10)))
 397
 398 (defun concat (&rest strs)
 399   (!reduce #'concat-two strs ""))
 400
 401 ;;; Concatenate a list of strings, with a separator
 402 (defun join (list &optional (separator ""))
 403   (cond
 404     ((null list)
 405      "")
 406     ((null (cdr list))
 407      (car list))
 408     (t
 409      (concat (car list)
 410              separator
 411              (join (cdr list) separator)))))
 412
 413 (defun join-trailing (list &optional (separator ""))
 414   (if (null list)
 415       ""
 416       (concat (car list) separator (join-trailing (cdr list) separator))))
 417
 418 (defun integer-to-string (x)
 419   (cond
 420     ((zerop x)
 421      "0")
 422     ((minusp x)
 423      (concat "-" (integer-to-string (- 0 x))))
 424     (t
 425      (let ((digits nil))
 426        (while (not (zerop x))
 427          (push (mod x 10) digits)
 428          (setq x (truncate x 10)))
 429        (join (mapcar (lambda (d) (string (char "0123456789" d)))
 430                      digits))))))
 431
 432 (defun print-to-string (form)
 433   (cond
 434     ((symbolp form) (symbol-name form))
 435     ((integerp form) (integer-to-string form))
 436     ((stringp form) (concat "\"" (escape-string form) "\""))
 437     ((functionp form) (concat "#<FUNCTION>"))
 438     ((listp form)
 439      (concat "("
 440              (join (mapcar #'print-to-string form)
 441                    " ")
 442              ")"))))
 443
 444 ;;;; Reader
 445
 446 ;;; The Lisp reader, parse strings and return Lisp objects. The main
 447 ;;; entry points are `ls-read' and `ls-read-from-string'.
 448
 449 (defun make-string-stream (string)
 450   (cons string 0))
 451
 452 (defun %peek-char (stream)
 453   (and (< (cdr stream) (length (car stream)))
 454        (char (car stream) (cdr stream))))
 455
 456 (defun %read-char (stream)
 457   (and (< (cdr stream) (length (car stream)))
 458        (prog1 (char (car stream) (cdr stream))
 459          (setcdr stream (1+ (cdr stream))))))
 460
 461 (defun whitespacep (ch)
 462   (or (char= ch #\space) (char= ch #\newline) (char= ch #\tab)))
 463
 464 (defun skip-whitespaces (stream)
 465   (let (ch)
 466     (setq ch (%peek-char stream))
 467     (while (and ch (whitespacep ch))
 468       (%read-char stream)
 469       (setq ch (%peek-char stream)))))
 470
 471 (defun terminalp (ch)
 472   (or (null ch) (whitespacep ch) (char= #\) ch) (char= #\( ch)))
 473
 474 (defun read-until (stream func)
 475   (let ((string "")
 476         (ch))
 477     (setq ch (%peek-char stream))
 478     (while (not (funcall func ch))
 479       (setq string (concat string (string ch)))
 480       (%read-char stream)
 481       (setq ch (%peek-char stream)))
 482     string))
 483
 484 (defun skip-whitespaces-and-comments (stream)
 485   (let (ch)
 486     (skip-whitespaces stream)
 487     (setq ch (%peek-char stream))
 488     (while (and ch (char= ch #\;))
 489       (read-until stream (lambda (x) (char= x #\newline)))
 490       (skip-whitespaces stream)
 491       (setq ch (%peek-char stream)))))
 492
 493 (defun %read-list (stream)
 494   (skip-whitespaces-and-comments stream)
 495   (let ((ch (%peek-char stream)))
 496     (cond
 497       ((null ch)
 498        (error "Unspected EOF"))
 499       ((char= ch #\))
 500        (%read-char stream)
 501        nil)
 502       ((char= ch #\.)
 503        (%read-char stream)
 504        (prog1 (ls-read stream)
 505          (skip-whitespaces-and-comments stream)
 506          (unless (char= (%read-char stream) #\))
 507            (error "')' was expected."))))
 508       (t
 509        (cons (ls-read stream) (%read-list stream))))))
 510
 511 (defun read-string (stream)
 512   (let ((string "")
 513         (ch nil))
 514     (setq ch (%read-char stream))
 515     (while (not (eql ch #\"))
 516       (when (null ch)
 517         (error "Unexpected EOF"))
 518       (when (eql ch #\\)
 519         (setq ch (%read-char stream)))
 520       (setq string (concat string (string ch)))
 521       (setq ch (%read-char stream)))
 522     string))
 523
 524 (defun read-sharp (stream)
 525   (%read-char stream)
 526   (ecase (%read-char stream)
 527     (#\'
 528      (list 'function (ls-read stream)))
 529     (#\\
 530      (let ((cname
 531             (concat (string (%read-char stream))
 532                     (read-until stream #'terminalp))))
 533        (cond
 534          ((string= cname "space") (char-code #\space))
 535          ((string= cname "tab") (char-code #\tab))
 536          ((string= cname "newline") (char-code #\newline))
 537          (t (char-code (char cname 0))))))
 538     (#\+
 539      (let ((feature (read-until stream #'terminalp)))
 540        (cond
 541          ((string= feature "common-lisp")
 542           (ls-read stream)              ;ignore
 543           (ls-read stream))
 544          ((string= feature "lispstrack")
 545           (ls-read stream))
 546          (t
 547           (error "Unknown reader form.")))))))
 548
 549 (defvar *eof* (make-symbol "EOF"))
 550 (defun ls-read (stream)
 551   (skip-whitespaces-and-comments stream)
 552   (let ((ch (%peek-char stream)))
 553     (cond
 554       ((null ch)
 555        *eof*)
 556       ((char= ch #\()
 557        (%read-char stream)
 558        (%read-list stream))
 559       ((char= ch #\')
 560        (%read-char stream)
 561        (list 'quote (ls-read stream)))
 562       ((char= ch #\`)
 563        (%read-char stream)
 564        (list 'backquote (ls-read stream)))
 565       ((char= ch #\")
 566        (%read-char stream)
 567        (read-string stream))
 568       ((char= ch #\,)
 569        (%read-char stream)
 570        (if (eql (%peek-char stream) #\@)
 571            (progn (%read-char stream) (list 'unquote-splicing (ls-read stream)))
 572            (list 'unquote (ls-read stream))))
 573       ((char= ch #\#)
 574        (read-sharp stream))
 575       (t
 576        (let ((string (read-until stream #'terminalp)))
 577          (if (every #'digit-char-p string)
 578              (parse-integer string)
 579              (intern (string-upcase string))))))))
 580
 581 (defun ls-read-from-string (string)
 582   (ls-read (make-string-stream string)))
 583
 584
 585 ;;;; Compiler
 586
 587 ;;; Translate the Lisp code to Javascript. It will compile the special
 588 ;;; forms. Some primitive functions are compiled as special forms
 589 ;;; too. The respective real functions are defined in the target (see
 590 ;;; the beginning of this file) as well as some primitive functions.
 591
 592 (defvar *compilation-unit-checks* '())
 593
 594 (defvar *env* '())
 595 (defvar *fenv* '())
 596
 597 (defun make-binding (name type js declared)
 598   (list name type js declared))
 599
 600 (defun binding-name (b) (first b))
 601 (defun binding-type (b) (second b))
 602 (defun binding-translation (b) (third b))
 603 (defun binding-declared (b)
 604   (and b (fourth b)))
 605 (defun mark-binding-as-declared (b)
 606   (setcar (cdddr b) t))
 607
 608 (defvar *variable-counter* 0)
 609 (defun gvarname (symbol)
 610   (concat "v" (integer-to-string (incf *variable-counter*))))
 611
 612 (defun lookup-variable (symbol env)
 613   (or (assoc symbol env)
 614       (assoc symbol *env*)
 615       (let ((name (symbol-name symbol))
 616             (binding (make-binding symbol 'variable (gvarname symbol) nil)))
 617         (push binding *env*)
 618         (push (lambda ()
 619                 (unless (binding-declared (assoc symbol *env*))
 620                   (error (concat "Undefined variable `" name "'"))))
 621               *compilation-unit-checks*)
 622         binding)))
 623
 624 (defun lookup-variable-translation (symbol env)
 625   (binding-translation (lookup-variable symbol env)))
 626
 627 (defun extend-local-env (args env)
 628   (append (mapcar (lambda (symbol)
 629                     (make-binding symbol 'variable (gvarname symbol) t))
 630                   args)
 631           env))
 632
 633 (defvar *function-counter* 0)
 634 (defun lookup-function (symbol env)
 635   (or (assoc symbol env)
 636       (assoc symbol *fenv*)
 637       (let ((name (symbol-name symbol))
 638             (binding
 639              (make-binding symbol
 640                            'function
 641                            (concat "f" (integer-to-string (incf *function-counter*)))
 642                            nil)))
 643         (push binding *fenv*)
 644         (push (lambda ()
 645                 (unless (binding-declared (assoc symbol *fenv*))
 646                   (error (concat "Undefined function `" name "'"))))
 647               *compilation-unit-checks*)
 648         binding)))
 649
 650 (defun lookup-function-translation (symbol env)
 651   (binding-translation (lookup-function symbol env)))
 652
 653 (defvar *toplevel-compilations* nil)
 654
 655 (defun %compile-defvar (name)
 656   (let ((b (lookup-variable name *env*)))
 657     (mark-binding-as-declared b)
 658     (push (concat "var " (binding-translation b)) *toplevel-compilations*)))
 659
 660 (defun %compile-defun (name)
 661   (let ((b (lookup-function name *env*)))
 662     (mark-binding-as-declared b)
 663     (push (concat "var " (binding-translation b)) *toplevel-compilations*)))
 664
 665 (defun %compile-defmacro (name lambda)
 666   (push (make-binding name 'macro lambda t) *fenv*))
 667
 668 (defvar *compilations* nil)
 669
 670 (defun ls-compile-block (sexps env fenv)
 671   (join-trailing
 672    (remove-if (lambda (x)
 673                 (or (null x)
 674                     (and (stringp x)
 675                          (zerop (length x)))))
 676               (mapcar (lambda (x) (ls-compile x env fenv))  sexps))
 677    (concat ";" *newline*)))
 678
 679 (defmacro define-compilation (name args &rest body)
 680   ;; Creates a new primitive `name' with parameters args and
 681   ;; @body. The body can access to the local environment through the
 682   ;; variable ENV.
 683   `(push (list ',name (lambda (env fenv ,@args) ,@body))
 684          *compilations*))
 685
 686 (define-compilation if (condition true false)
 687   (concat "("
 688           (ls-compile condition env fenv) " !== " (ls-compile nil nil nil)
 689           " ? "
 690           (ls-compile true env fenv)
 691           " : "
 692           (ls-compile false env fenv)
 693           ")"))
 694
 695
 696 (defvar *lambda-list-keywords* '(&optional &rest))
 697
 698 (defun list-until-keyword (list)
 699   (if (or (null list) (member (car list) *lambda-list-keywords*))
 700       nil
 701       (cons (car list) (list-until-keyword (cdr list)))))
 702
 703 (defun lambda-list-required-arguments (lambda-list)
 704   (list-until-keyword lambda-list))
 705
 706 (defun lambda-list-optional-arguments-with-default (lambda-list)
 707   (mapcar #'ensure-list (list-until-keyword (cdr (member '&optional lambda-list)))))
 708
 709 (defun lambda-list-optional-arguments (lambda-list)
 710   (mapcar #'car (lambda-list-optional-arguments-with-default lambda-list)))
 711
 712 (defun lambda-list-rest-argument (lambda-list)
 713   (let ((rest (list-until-keyword (cdr (member '&rest lambda-list)))))
 714     (when (cdr rest)
 715       (error "Bad lambda-list"))
 716     (car rest)))
 717
 718 (define-compilation lambda (lambda-list &rest body)
 719   (let ((required-arguments (lambda-list-required-arguments lambda-list))
 720         (optional-arguments (lambda-list-optional-arguments lambda-list))
 721         (rest-argument (lambda-list-rest-argument lambda-list)))
 722     (let ((n-required-arguments (length required-arguments))
 723           (n-optional-arguments (length optional-arguments))
 724           (new-env (extend-local-env
 725                     (append (ensure-list rest-argument)
 726                             required-arguments
 727                             optional-arguments)
 728                     env)))
 729       (concat "(function ("
 730               (join (mapcar (lambda (x)
 731                               (lookup-variable-translation x new-env))
 732                             (append required-arguments optional-arguments))
 733                     ",")
 734               "){" *newline*
 735               ;; Check number of arguments
 736               (if required-arguments
 737                   (concat "if (arguments.length < " (integer-to-string n-required-arguments)
 738                           ") throw 'too few arguments';" *newline*)
 739                   "")
 740               (if (not rest-argument)
 741                   (concat "if (arguments.length > "
 742                           (integer-to-string (+ n-required-arguments n-optional-arguments))
 743                           ") throw 'too many arguments';" *newline*)
 744                   "")
 745               ;; Optional arguments
 746               (if optional-arguments
 747                   (concat "switch(arguments.length){" *newline*
 748                           (let ((optional-and-defaults
 749                                  (lambda-list-optional-arguments-with-default lambda-list))
 750                                 (cases nil)
 751                                 (idx 0))
 752                             (progn (while (< idx n-optional-arguments)
 753                                      (let ((arg (nth idx optional-and-defaults)))
 754                                        (push (concat "case "
 755                                                      (integer-to-string (+ idx n-required-arguments)) ":" *newline*
 756                                                      (lookup-variable-translation (car arg) new-env)
 757                                                      "="
 758                                                      (ls-compile (cadr arg) new-env fenv)
 759                                                      ";" *newline*)
 760                                              cases)
 761                                        (incf idx)))
 762                                    (push (concat "default: break;" *newline*) cases)
 763                                    (join (reverse cases))))
 764                           "}" *newline*)
 765                   "")
 766               ;; &rest argument
 767               (if rest-argument
 768                   (let ((js!rest (lookup-variable-translation rest-argument new-env)))
 769                     (concat "var " js!rest "= " (ls-compile nil env fenv) ";" *newline*
 770                             "for (var i = arguments.length-1; i>="
 771                             (integer-to-string (+ n-required-arguments n-optional-arguments))
 772                             "; i--)" *newline*
 773                             js!rest " = "
 774                             "{car: arguments[i], cdr: " js!rest "};"
 775                             *newline*))
 776                   "")
 777               ;; Body
 778               (concat (ls-compile-block (butlast body) new-env fenv)
 779                       "return " (ls-compile (car (last body)) new-env fenv) ";")
 780               *newline* "})"))))
 781
 782 (define-compilation fsetq (var val)
 783   (concat (lookup-function-translation var fenv)
 784           " = "
 785           (ls-compile val env fenv)))
 786
 787 (define-compilation setq (var val)
 788   (concat (lookup-variable-translation var env)
 789           " = "
 790            (ls-compile val env fenv)))
 791
 792 ;;; Literals
 793 (defun escape-string (string)
 794   (let ((output "")
 795         (index 0)
 796         (size (length string)))
 797     (while (< index size)
 798       (let ((ch (char string index)))
 799         (when (or (char= ch #\") (char= ch #\\))
 800           (setq output (concat output "\\")))
 801         (when (or (char= ch #\newline))
 802           (setq output (concat output "\\"))
 803           (setq ch #\n))
 804         (setq output (concat output (string ch))))
 805       (incf index))
 806     output))
 807
 808 (defun literal->js (sexp)
 809   (cond
 810     ((integerp sexp) (integer-to-string sexp))
 811     ((stringp sexp) (concat "\"" (escape-string sexp) "\""))
 812     ((symbolp sexp) (ls-compile `(intern ,(escape-string (symbol-name sexp))) *env* *fenv*))
 813     ((consp sexp) (concat "{car: "
 814                           (literal->js (car sexp))
 815                           ", cdr: "
 816                           (literal->js (cdr sexp)) "}"))))
 817
 818 (defvar *literal-counter* 0)
 819 (defun literal (form)
 820   (let ((var (concat "l" (integer-to-string (incf *literal-counter*)))))
 821     (push (concat "var " var " = " (literal->js form)) *toplevel-compilations*)
 822     var))
 823
 824 (define-compilation quote (sexp)
 825   (literal sexp))
 826
 827 (define-compilation debug (form)
 828   (concat "console.log(" (ls-compile form env fenv) ")"))
 829
 830 (define-compilation while (pred &rest body)
 831   (concat "(function(){ while("
 832           (ls-compile pred env fenv) " !== " (ls-compile nil nil nil)
 833           "){"
 834           (ls-compile-block body env fenv)
 835           "}})()"))
 836
 837 (define-compilation function (x)
 838   (cond
 839     ((and (listp x) (eq (car x) 'lambda))
 840      (ls-compile x env fenv))
 841     ((symbolp x)
 842      (lookup-function-translation x fenv))))
 843
 844 (define-compilation eval-when-compile (&rest body)
 845   (eval (cons 'progn body))
 846   "")
 847
 848 (defmacro define-transformation (name args form)
 849   `(define-compilation ,name ,args
 850      (ls-compile ,form env fenv)))
 851
 852 (define-compilation progn (&rest body)
 853   (concat "(function(){" *newline*
 854           (ls-compile-block (butlast body) env fenv)
 855           "return " (ls-compile (car (last body)) env fenv) ";"
 856           "})()" *newline*))
 857
 858 (define-transformation let (bindings &rest body)
 859   (let ((bindings (mapcar #'ensure-list bindings)))
 860     `((lambda ,(mapcar #'car bindings) ,@body)
 861       ,@(mapcar #'cadr bindings))))
 862
 863 ;;; A little backquote implementation without optimizations of any
 864 ;;; kind for lispstrack.
 865 (defun backquote-expand-1 (form)
 866   (cond
 867     ((symbolp form)
 868      (list 'quote form))
 869     ((atom form)
 870      form)
 871     ((eq (car form) 'unquote)
 872      (car form))
 873     ((eq (car form) 'backquote)
 874      (backquote-expand-1 (backquote-expand-1 (cadr form))))
 875     (t
 876      (cons 'append
 877            (mapcar (lambda (s)
 878                      (cond
 879                        ((and (listp s) (eq (car s) 'unquote))
 880                         (list 'list (cadr s)))
 881                        ((and (listp s) (eq (car s) 'unquote-splicing))
 882                         (cadr s))
 883                        (t
 884                         (list 'list (backquote-expand-1 s)))))
 885                    form)))))
 886
 887 (defun backquote-expand (form)
 888   (if (and (listp form) (eq (car form) 'backquote))
 889       (backquote-expand-1 (cadr form))
 890       form))
 891
 892 (defmacro backquote (form)
 893   (backquote-expand-1 form))
 894
 895 (define-transformation backquote (form)
 896   (backquote-expand-1 form))
 897
 898 ;;; Primitives
 899
 900 (defun compile-bool (x)
 901   (concat "(" x "?" (ls-compile t nil nil) ": " (ls-compile nil nil nil) ")"))
 902
 903 (define-compilation + (x y)
 904   (concat "((" (ls-compile x env fenv) ") + (" (ls-compile y env fenv) "))"))
 905
 906 (define-compilation - (x y)
 907   (concat "((" (ls-compile x env fenv) ") - (" (ls-compile y env fenv) "))"))
 908
 909 (define-compilation * (x y)
 910   (concat "((" (ls-compile x env fenv) ") * (" (ls-compile y env fenv) "))"))
 911
 912 (define-compilation / (x y)
 913   (concat "((" (ls-compile x env fenv) ") / (" (ls-compile y env fenv) "))"))
 914
 915 (define-compilation < (x y)
 916   (compile-bool (concat "((" (ls-compile x env fenv) ") < (" (ls-compile y env fenv) "))")))
 917
 918 (define-compilation = (x y)
 919   (compile-bool (concat "((" (ls-compile x env fenv) ") == (" (ls-compile y env fenv) "))")))
 920
 921 (define-compilation numberp (x)
 922   (compile-bool (concat "(typeof (" (ls-compile x env fenv) ") == \"number\")")))
 923
 924
 925 (define-compilation mod (x y)
 926   (concat "((" (ls-compile x env fenv) ") % (" (ls-compile y env fenv) "))"))
 927
 928 (define-compilation floor (x)
 929   (concat "(Math.floor(" (ls-compile x env fenv) "))"))
 930
 931 (define-compilation null (x)
 932   (compile-bool (concat "(" (ls-compile x env fenv) "===" (ls-compile nil env fenv) ")")))
 933
 934 (define-compilation cons (x y)
 935   (concat "({car: " (ls-compile x env fenv) ", cdr: " (ls-compile y env fenv) "})"))
 936
 937 (define-compilation consp (x)
 938   (compile-bool
 939    (concat "(function(){ var tmp = "
 940            (ls-compile x env fenv)
 941            "; return (typeof tmp == 'object' && 'car' in tmp);})()")))
 942
 943 (define-compilation car (x)
 944   (concat "(function () { var tmp = " (ls-compile x env fenv)
 945           "; return tmp === " (ls-compile nil nil nil) "? "
 946           (ls-compile nil nil nil)
 947           ": tmp.car; })()"))
 948
 949 (define-compilation cdr (x)
 950   (concat "(function () { var tmp = " (ls-compile x env fenv)
 951           "; return tmp === " (ls-compile nil nil nil) "? "
 952           (ls-compile nil nil nil)
 953           ": tmp.cdr; })()"))
 954
 955 (define-compilation setcar (x new)
 956   (concat "((" (ls-compile x env fenv) ").car = " (ls-compile new env fenv) ")"))
 957
 958 (define-compilation setcdr (x new)
 959   (concat "((" (ls-compile x env fenv) ").cdr = " (ls-compile new env fenv) ")"))
 960
 961 (define-compilation symbolp (x)
 962   (compile-bool
 963    (concat "(function(){ var tmp = "
 964            (ls-compile x env fenv)
 965            "; return (typeof tmp == 'object' && 'name' in tmp); })()")))
 966
 967 (define-compilation make-symbol (name)
 968   (concat "({name: " (ls-compile name env fenv) "})"))
 969
 970 (define-compilation symbol-name (x)
 971   (concat "(" (ls-compile x env fenv) ").name"))
 972
 973 (define-compilation eq (x y)
 974   (compile-bool
 975    (concat "(" (ls-compile x env fenv) " === " (ls-compile y env fenv) ")")))
 976
 977 (define-compilation equal (x y)
 978   (compile-bool
 979    (concat "(" (ls-compile x env fenv) " == " (ls-compile y env fenv) ")")))
 980
 981 (define-compilation string (x)
 982   (concat "String.fromCharCode(" (ls-compile x env fenv) ")"))
 983
 984 (define-compilation stringp (x)
 985   (compile-bool
 986    (concat "(typeof(" (ls-compile x env fenv) ") == \"string\")")))
 987
 988 (define-compilation string-upcase (x)
 989   (concat "(" (ls-compile x env fenv) ").toUpperCase()"))
 990
 991 (define-compilation string-length (x)
 992   (concat "(" (ls-compile x env fenv) ").length"))
 993
 994 (define-compilation slice (string a &optional b)
 995   (concat "(function(){" *newline*
 996           "var str = " (ls-compile string env fenv) ";" *newline*
 997           "var a = " (ls-compile a env fenv) ";" *newline*
 998           "var b;" *newline*
 999           (if b
1000               (concat "b = " (ls-compile b env fenv) ";" *newline*)
1001               "")
1002           "return str.slice(a,b);" *newline*
1003           "})()"))
1004
1005 (define-compilation char (string index)
1006   (concat "("
1007           (ls-compile string env fenv)
1008           ").charCodeAt("
1009           (ls-compile index env fenv)
1010           ")"))
1011
1012 (define-compilation concat-two (string1 string2)
1013   (concat "("
1014           (ls-compile string1 env fenv)
1015           ").concat("
1016           (ls-compile string2 env fenv)
1017           ")"))
1018
1019 (define-compilation funcall (func &rest args)
1020   (concat "("
1021           (ls-compile func env fenv)
1022           ")("
1023           (join (mapcar (lambda (x)
1024                           (ls-compile x env fenv))
1025                         args)
1026                 ", ")
1027           ")"))
1028
1029 (define-compilation apply (func &rest args)
1030   (if (null args)
1031       (concat "(" (ls-compile func env fenv) ")()")
1032       (let ((args (butlast args))
1033             (last (car (last args))))
1034         (concat "(function(){" *newline*
1035                 "var f = " (ls-compile func env fenv) ";" *newline*
1036                 "var args = [" (join (mapcar (lambda (x)
1037                                                (ls-compile x env fenv))
1038                                              args)
1039                                      ", ")
1040                 "];" *newline*
1041                 "var tail = (" (ls-compile last env fenv) ");" *newline*
1042                 "while (tail != " (ls-compile nil env fenv) "){" *newline*
1043                 "    args.push(tail.car);" *newline*
1044                 "    tail = tail.cdr;" *newline*
1045                 "}" *newline*
1046                 "return f.apply(this, args);" *newline*
1047                 "})()" *newline*))))
1048
1049 (define-compilation js-eval (string)
1050   (concat "eval.apply(window, [" (ls-compile string env fenv)  "])"))
1051
1052
1053 (define-compilation error (string)
1054   (concat "(function (){ throw " (ls-compile string env fenv) ";" "return 0;})()"))
1055
1056 (define-compilation new ()
1057   "{}")
1058
1059 (define-compilation get (object key)
1060   (concat "(function(){ var tmp = "
1061           "(" (ls-compile object env fenv) ")[" (ls-compile key env fenv) "]"
1062           ";"
1063           "return tmp == undefined? " (ls-compile nil nil nil) ": tmp ;"
1064           "})()"))
1065
1066 (define-compilation set (object key value)
1067   (concat "(("
1068           (ls-compile object env fenv)
1069           ")["
1070           (ls-compile key env fenv) "]"
1071           " = " (ls-compile value env fenv) ")"))
1072
1073 (define-compilation in (key object)
1074   (compile-bool
1075    (concat "(" (ls-compile key env fenv) " in " (ls-compile object env fenv) ")")))
1076
1077 (define-compilation functionp (x)
1078   (compile-bool
1079    (concat "(typeof " (ls-compile x env fenv) " == 'function')")))
1080
1081
1082 (defun macrop (x)
1083   (and (symbolp x) (eq (binding-type (lookup-function x *fenv*)) 'macro)))
1084
1085 (defun ls-macroexpand-1 (form env fenv)
1086   (if (macrop (car form))
1087       (let ((binding (lookup-function (car form) *env*)))
1088         (if (eq (binding-type binding) 'macro)
1089             (apply (eval (binding-translation binding)) (cdr form))
1090             form))
1091       form))
1092
1093 (defun compile-funcall (function args env fenv)
1094   (cond
1095     ((symbolp function)
1096      (concat (lookup-function-translation function fenv)
1097              "("
1098              (join (mapcar (lambda (x) (ls-compile x env fenv)) args)
1099                    ", ")
1100              ")"))
1101     ((and (listp function) (eq (car function) 'lambda))
1102      (concat "(" (ls-compile function env fenv) ")("
1103              (join (mapcar (lambda (x) (ls-compile x env fenv)) args)
1104                    ", ")
1105              ")"))
1106     (t
1107      (error (concat "Invalid function designator " (symbol-name function))))))
1108
1109 (defun ls-compile (sexp env fenv)
1110   (cond
1111     ((symbolp sexp) (lookup-variable-translation sexp env))
1112     ((integerp sexp) (integer-to-string sexp))
1113     ((stringp sexp) (concat "\"" (escape-string sexp) "\""))
1114     ((listp sexp)
1115      (if (assoc (car sexp) *compilations*)
1116          (let ((comp (second (assoc (car sexp) *compilations*))))
1117            (apply comp env fenv (cdr sexp)))
1118          (if (macrop (car sexp))
1119              (ls-compile (ls-macroexpand-1 sexp env fenv) env fenv)
1120              (compile-funcall (car sexp) (cdr sexp) env fenv))))))
1121
1122 (defun ls-compile-toplevel (sexp)
1123   (setq *toplevel-compilations* nil)
1124   (let ((code (ls-compile sexp nil nil)))
1125     (prog1
1126         (concat (join (mapcar (lambda (x) (concat x ";" *newline*))
1127                               *toplevel-compilations*))
1128                 code)
1129       (setq *toplevel-compilations* nil))))
1130
1131
1132 ;;; Once we have the compiler, we define the runtime environment and
1133 ;;; interactive development (eval), which works calling the compiler
1134 ;;; and evaluating the Javascript result globally.
1135
1136 #+lispstrack
1137 (progn
1138  (defmacro with-compilation-unit (&rest body)
1139    `(prog1
1140         (progn
1141           (setq *compilation-unit-checks* nil)
1142           (setq *env* (remove-if-not #'binding-declared *env*))
1143           (setq *fenv* (remove-if-not #'binding-declared *fenv*))
1144           ,@body)
1145       (dolist (check *compilation-unit-checks*)
1146         (funcall check))))
1147
1148  (defun eval (x)
1149    (let ((code
1150           (with-compilation-unit
1151               (ls-compile-toplevel x))))
1152      (js-eval code)))
1153
1154  ;; Set the initial global environment to be equal to the host global
1155  ;; environment at this point of the compilation.
1156  (eval-when-compile
1157    (let ((c1 (ls-compile `(setq *fenv* ',*fenv*) nil nil))
1158          (c2 (ls-compile `(setq *env* ',*env*) nil nil))
1159          (c3 (ls-compile `(setq *variable-counter* ',*variable-counter*) nil nil))
1160          (c4 (ls-compile `(setq *function-counter* ',*function-counter*) nil nil))
1161          (c5 (ls-compile `(setq *literal-counter* ',*literal-counter*) nil nil)))
1162      (setq *toplevel-compilations*
1163            (append *toplevel-compilations* (list c1 c2 c3 c4 c5)))))
1164
1165  (js-eval
1166   (concat "var lisp = {};"
1167           "lisp.read = " (lookup-function-translation 'ls-read-from-string nil) ";" *newline*
1168           "lisp.print = " (lookup-function-translation 'print-to-string nil) ";" *newline*
1169           "lisp.eval = " (lookup-function-translation 'eval nil) ";" *newline*
1170           "lisp.compile = " (lookup-function-translation 'ls-compile-toplevel nil) ";" *newline*
1171           "lisp.evalString = function(str){" *newline*
1172           "   return lisp.eval(lisp.read(str));" *newline*
1173           "}" *newline*
1174           "lisp.compileString = function(str){" *newline*
1175           "   return lisp.compile(lisp.read(str));" *newline*
1176           "}" *newline*)))
1177
1178
1179 ;;; Finally, we provide a couple of functions to easily bootstrap
1180 ;;; this. It just calls the compiler with this file as input.
1181
1182 #+common-lisp
1183 (progn
1184   (defun read-whole-file (filename)
1185     (with-open-file (in filename)
1186       (let ((seq (make-array (file-length in) :element-type 'character)))
1187         (read-sequence seq in)
1188         seq)))
1189
1190   (defun ls-compile-file (filename output)
1191     (setq *env* nil *fenv* nil)
1192     (setq *compilation-unit-checks* nil)
1193     (with-open-file (out output :direction :output :if-exists :supersede)
1194       (let* ((source (read-whole-file filename))
1195              (in (make-string-stream source)))
1196         (loop
1197            for x = (ls-read in)
1198            until (eq x *eof*)
1199            for compilation = (ls-compile-toplevel x)
1200            when (plusp (length compilation))
1201            do (write-line (concat compilation "; ") out))
1202         (dolist (check *compilation-unit-checks*)
1203           (funcall check))
1204         (setq *compilation-unit-checks* nil))))
1205
1206   (defun bootstrap ()
1207     (ls-compile-file "lispstrack.lisp" "lispstrack.js")))