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 parse-integer (string)
 327     (let ((value 0)
 328           (index 0)
 329           (size (length string)))
 330       (while (< index size)
 331         (setq value (+ (* value 10) (digit-char-p (char string index))))
 332         (incf index))
 333       value))
 334
 335   (defun every (function seq)
 336     ;; string
 337     (let ((ret t)
 338           (index 0)
 339           (size (length seq)))
 340       (while (and ret (< index size))
 341         (unless (funcall function (char seq index))
 342           (setq ret nil))
 343         (incf index))
 344       ret))
 345
 346   (defun assoc (x alist)
 347     (cond
 348       ((null alist)
 349        nil)
 350       ((eql x (caar alist))
 351        (car alist))
 352       (t
 353        (assoc x (cdr alist)))))
 354
 355   (defun string= (s1 s2)
 356     (equal s1 s2)))
 357
 358
 359 ;;; The compiler offers some primitives and special forms which are
 360 ;;; not found in Common Lisp, for instance, while. So, we grow Common
 361 ;;; Lisp a bit to it can execute the rest of the file.
 362 #+common-lisp
 363 (progn
 364   (defmacro while (condition &body body)
 365     `(do ()
 366          ((not ,condition))
 367        ,@body))
 368
 369   (defmacro eval-when-compile (&body body)
 370     `(eval-when (:compile-toplevel :load-toplevel :execute)
 371        ,@body))
 372
 373   (defun concat-two (s1 s2)
 374     (concatenate 'string s1 s2))
 375
 376   (defun setcar (cons new)
 377     (setf (car cons) new))
 378   (defun setcdr (cons new)
 379     (setf (cdr cons) new)))
 380
 381
 382 ;;; At this point, no matter if Common Lisp or lispstrack is compiling
 383 ;;; from here, this code will compile on both. We define some helper
 384 ;;; functions now for string manipulation and so on. They will be
 385 ;;; useful in the compiler, mostly.
 386
 387 (defvar *newline* (string (code-char 10)))
 388
 389 (defun concat (&rest strs)
 390   (!reduce #'concat-two strs ""))
 391
 392 ;;; Concatenate a list of strings, with a separator
 393 (defun join (list &optional (separator ""))
 394   (cond
 395     ((null list)
 396      "")
 397     ((null (cdr list))
 398      (car list))
 399     (t
 400      (concat (car list)
 401              separator
 402              (join (cdr list) separator)))))
 403
 404 (defun join-trailing (list &optional (separator ""))
 405   (if (null list)
 406       ""
 407       (concat (car list) separator (join-trailing (cdr list) separator))))
 408
 409 (defun integer-to-string (x)
 410   (cond
 411     ((zerop x)
 412      "0")
 413     ((minusp x)
 414      (concat "-" (integer-to-string (- 0 x))))
 415     (t
 416      (let ((digits nil))
 417        (while (not (zerop x))
 418          (push (mod x 10) digits)
 419          (setq x (truncate x 10)))
 420        (join (mapcar (lambda (d) (string (char "0123456789" d)))
 421                      digits)
 422              "")))))
 423
 424 (defun print-to-string (form)
 425   (cond
 426     ((symbolp form) (symbol-name form))
 427     ((integerp form) (integer-to-string form))
 428     ((stringp form) (concat "\"" (escape-string form) "\""))
 429     ((functionp form) (concat "#<FUNCTION>"))
 430     ((listp form)
 431      (concat "("
 432              (join (mapcar #'print-to-string form)
 433                    " ")
 434              ")"))))
 435
 436 ;;;; Reader
 437
 438 ;;; The Lisp reader, parse strings and return Lisp objects. The main
 439 ;;; entry points are `ls-read' and `ls-read-from-string'.
 440
 441 (defun make-string-stream (string)
 442   (cons string 0))
 443
 444 (defun %peek-char (stream)
 445   (and (< (cdr stream) (length (car stream)))
 446        (char (car stream) (cdr stream))))
 447
 448 (defun %read-char (stream)
 449   (and (< (cdr stream) (length (car stream)))
 450        (prog1 (char (car stream) (cdr stream))
 451          (setcdr stream (1+ (cdr stream))))))
 452
 453 (defun whitespacep (ch)
 454   (or (char= ch #\space) (char= ch #\newline) (char= ch #\tab)))
 455
 456 (defun skip-whitespaces (stream)
 457   (let (ch)
 458     (setq ch (%peek-char stream))
 459     (while (and ch (whitespacep ch))
 460       (%read-char stream)
 461       (setq ch (%peek-char stream)))))
 462
 463 (defun terminalp (ch)
 464   (or (null ch) (whitespacep ch) (char= #\) ch) (char= #\( ch)))
 465
 466 (defun read-until (stream func)
 467   (let ((string "")
 468         (ch))
 469     (setq ch (%peek-char stream))
 470     (while (not (funcall func ch))
 471       (setq string (concat string (string ch)))
 472       (%read-char stream)
 473       (setq ch (%peek-char stream)))
 474     string))
 475
 476 (defun skip-whitespaces-and-comments (stream)
 477   (let (ch)
 478     (skip-whitespaces stream)
 479     (setq ch (%peek-char stream))
 480     (while (and ch (char= ch #\;))
 481       (read-until stream (lambda (x) (char= x #\newline)))
 482       (skip-whitespaces stream)
 483       (setq ch (%peek-char stream)))))
 484
 485 (defun %read-list (stream)
 486   (skip-whitespaces-and-comments stream)
 487   (let ((ch (%peek-char stream)))
 488     (cond
 489       ((null ch)
 490        (error "Unspected EOF"))
 491       ((char= ch #\))
 492        (%read-char stream)
 493        nil)
 494       ((char= ch #\.)
 495        (%read-char stream)
 496        (prog1 (ls-read stream)
 497          (skip-whitespaces-and-comments stream)
 498          (unless (char= (%read-char stream) #\))
 499            (error "')' was expected."))))
 500       (t
 501        (cons (ls-read stream) (%read-list stream))))))
 502
 503 (defun read-string (stream)
 504   (let ((string "")
 505         (ch nil))
 506     (setq ch (%read-char stream))
 507     (while (not (eql ch #\"))
 508       (when (null ch)
 509         (error "Unexpected EOF"))
 510       (when (eql ch #\\)
 511         (setq ch (%read-char stream)))
 512       (setq string (concat string (string ch)))
 513       (setq ch (%read-char stream)))
 514     string))
 515
 516 (defun read-sharp (stream)
 517   (%read-char stream)
 518   (ecase (%read-char stream)
 519     (#\'
 520      (list 'function (ls-read stream)))
 521     (#\\
 522      (let ((cname
 523             (concat (string (%read-char stream))
 524                     (read-until stream #'terminalp))))
 525        (cond
 526          ((string= cname "space") (char-code #\space))
 527          ((string= cname "tab") (char-code #\tab))
 528          ((string= cname "newline") (char-code #\newline))
 529          (t (char-code (char cname 0))))))
 530     (#\+
 531      (let ((feature (read-until stream #'terminalp)))
 532        (cond
 533          ((string= feature "common-lisp")
 534           (ls-read stream)              ;ignore
 535           (ls-read stream))
 536          ((string= feature "lispstrack")
 537           (ls-read stream))
 538          (t
 539           (error "Unknown reader form.")))))))
 540
 541 (defvar *eof* (make-symbol "EOF"))
 542 (defun ls-read (stream)
 543   (skip-whitespaces-and-comments stream)
 544   (let ((ch (%peek-char stream)))
 545     (cond
 546       ((null ch)
 547        *eof*)
 548       ((char= ch #\()
 549        (%read-char stream)
 550        (%read-list stream))
 551       ((char= ch #\')
 552        (%read-char stream)
 553        (list 'quote (ls-read stream)))
 554       ((char= ch #\`)
 555        (%read-char stream)
 556        (list 'backquote (ls-read stream)))
 557       ((char= ch #\")
 558        (%read-char stream)
 559        (read-string stream))
 560       ((char= ch #\,)
 561        (%read-char stream)
 562        (if (eql (%peek-char stream) #\@)
 563            (progn (%read-char stream) (list 'unquote-splicing (ls-read stream)))
 564            (list 'unquote (ls-read stream))))
 565       ((char= ch #\#)
 566        (read-sharp stream))
 567       (t
 568        (let ((string (read-until stream #'terminalp)))
 569          (if (every #'digit-char-p string)
 570              (parse-integer string)
 571              (intern (string-upcase string))))))))
 572
 573 (defun ls-read-from-string (string)
 574   (ls-read (make-string-stream string)))
 575
 576
 577 ;;;; Compiler
 578
 579 ;;; Translate the Lisp code to Javascript. It will compile the special
 580 ;;; forms. Some primitive functions are compiled as special forms
 581 ;;; too. The respective real functions are defined in the target (see
 582 ;;; the beginning of this file) as well as some primitive functions.
 583
 584 (defvar *compilation-unit-checks* '())
 585
 586 (defvar *env* '())
 587 (defvar *fenv* '())
 588
 589 (defun make-binding (name type js declared)
 590   (list name type js declared))
 591
 592 (defun binding-name (b) (first b))
 593 (defun binding-type (b) (second b))
 594 (defun binding-translation (b) (third b))
 595 (defun binding-declared (b)
 596   (and b (fourth b)))
 597 (defun mark-binding-as-declared (b)
 598   (setcar (cdddr b) t))
 599
 600 (defvar *variable-counter* 0)
 601 (defun gvarname (symbol)
 602   (concat "v" (integer-to-string (incf *variable-counter*))))
 603
 604 (defun lookup-variable (symbol env)
 605   (or (assoc symbol env)
 606       (assoc symbol *env*)
 607       (let ((name (symbol-name symbol))
 608             (binding (make-binding symbol 'variable (gvarname symbol) nil)))
 609         (push binding *env*)
 610         (push (lambda ()
 611                 (unless (binding-declared (assoc symbol *env*))
 612                   (error (concat "Undefined variable `" name "'"))))
 613               *compilation-unit-checks*)
 614         binding)))
 615
 616 (defun lookup-variable-translation (symbol env)
 617   (binding-translation (lookup-variable symbol env)))
 618
 619 (defun extend-local-env (args env)
 620   (append (mapcar (lambda (symbol)
 621                     (make-binding symbol 'variable (gvarname symbol) t))
 622                   args)
 623           env))
 624
 625 (defvar *function-counter* 0)
 626 (defun lookup-function (symbol env)
 627   (or (assoc symbol env)
 628       (assoc symbol *fenv*)
 629       (let ((name (symbol-name symbol))
 630             (binding
 631              (make-binding symbol
 632                            'function
 633                            (concat "f" (integer-to-string (incf *function-counter*)))
 634                            nil)))
 635         (push binding *fenv*)
 636         (push (lambda ()
 637                 (unless (binding-declared (assoc symbol *fenv*))
 638                   (error (concat "Undefined function `" name "'"))))
 639               *compilation-unit-checks*)
 640         binding)))
 641
 642 (defun lookup-function-translation (symbol env)
 643   (binding-translation (lookup-function symbol env)))
 644
 645 (defvar *toplevel-compilations* nil)
 646
 647 (defun %compile-defvar (name)
 648   (let ((b (lookup-variable name *env*)))
 649     (mark-binding-as-declared b)
 650     (push (concat "var " (binding-translation b)) *toplevel-compilations*)))
 651
 652 (defun %compile-defun (name)
 653   (let ((b (lookup-function name *env*)))
 654     (mark-binding-as-declared b)
 655     (push (concat "var " (binding-translation b)) *toplevel-compilations*)))
 656
 657 (defun %compile-defmacro (name lambda)
 658   (push (make-binding name 'macro lambda t) *fenv*))
 659
 660 (defvar *compilations* nil)
 661
 662 (defun ls-compile-block (sexps env fenv)
 663   (join-trailing
 664    (remove-if (lambda (x)
 665                 (or (null x)
 666                     (and (stringp x)
 667                          (zerop (length x)))))
 668               (mapcar (lambda (x) (ls-compile x env fenv))  sexps))
 669    (concat ";" *newline*)))
 670
 671 (defmacro define-compilation (name args &rest body)
 672   ;; Creates a new primitive `name' with parameters args and
 673   ;; @body. The body can access to the local environment through the
 674   ;; variable ENV.
 675   `(push (list ',name (lambda (env fenv ,@args) ,@body))
 676          *compilations*))
 677
 678 (define-compilation if (condition true false)
 679   (concat "("
 680           (ls-compile condition env fenv) " !== " (ls-compile nil nil nil)
 681           " ? "
 682           (ls-compile true env fenv)
 683           " : "
 684           (ls-compile false env fenv)
 685           ")"))
 686
 687
 688 (defvar *lambda-list-keywords* '(&optional &rest))
 689
 690 (defun list-until-keyword (list)
 691   (if (or (null list) (member (car list) *lambda-list-keywords*))
 692       nil
 693       (cons (car list) (list-until-keyword (cdr list)))))
 694
 695 (defun lambda-list-required-arguments (lambda-list)
 696   (list-until-keyword lambda-list))
 697
 698 (defun lambda-list-optional-arguments-with-default (lambda-list)
 699   (mapcar #'ensure-list (list-until-keyword (cdr (member '&optional lambda-list)))))
 700
 701 (defun lambda-list-optional-arguments (lambda-list)
 702   (mapcar #'car (lambda-list-optional-arguments-with-default lambda-list)))
 703
 704 (defun lambda-list-rest-argument (lambda-list)
 705   (let ((rest (list-until-keyword (cdr (member '&rest lambda-list)))))
 706     (when (cdr rest)
 707       (error "Bad lambda-list"))
 708     (car rest)))
 709
 710 (define-compilation lambda (lambda-list &rest body)
 711   (let ((required-arguments (lambda-list-required-arguments lambda-list))
 712         (optional-arguments (lambda-list-optional-arguments lambda-list))
 713         (rest-argument (lambda-list-rest-argument lambda-list)))
 714     (let ((n-required-arguments (length required-arguments))
 715           (n-optional-arguments (length optional-arguments))
 716           (new-env (extend-local-env
 717                     (append (ensure-list rest-argument)
 718                             required-arguments
 719                             optional-arguments)
 720                     env)))
 721       (concat "(function ("
 722               (join (mapcar (lambda (x)
 723                               (lookup-variable-translation x new-env))
 724                             (append required-arguments optional-arguments))
 725                     ",")
 726               "){" *newline*
 727               ;; Check number of arguments
 728               (if required-arguments
 729                   (concat "if (arguments.length < " (integer-to-string n-required-arguments)
 730                           ") throw 'too few arguments';" *newline*)
 731                   "")
 732               (if (not rest-argument)
 733                   (concat "if (arguments.length > "
 734                           (integer-to-string (+ n-required-arguments n-optional-arguments))
 735                           ") throw 'too many arguments';" *newline*)
 736                   "")
 737               ;; Optional arguments
 738               (if optional-arguments
 739                   (concat "switch(arguments.length){" *newline*
 740                           (let ((optional-and-defaults
 741                                  (lambda-list-optional-arguments-with-default lambda-list))
 742                                 (cases nil)
 743                                 (idx 0))
 744                             (progn (while (< idx n-optional-arguments)
 745                                      (let ((arg (nth idx optional-and-defaults)))
 746                                        (push (concat "case "
 747                                                      (integer-to-string (+ idx n-required-arguments)) ":" *newline*
 748                                                      (lookup-variable-translation (car arg) new-env)
 749                                                      "="
 750                                                      (ls-compile (cadr arg) new-env fenv)
 751                                                      ";" *newline*)
 752                                              cases)
 753                                        (incf idx)))
 754                                    (push (concat "default: break;" *newline*) cases)
 755                                    (join (reverse cases) "")))
 756                           "}" *newline*)
 757                   "")
 758               ;; &rest argument
 759               (if rest-argument
 760                   (let ((js!rest (lookup-variable-translation rest-argument new-env)))
 761                     (concat "var " js!rest "= " (ls-compile nil env fenv) ";" *newline*
 762                             "for (var i = arguments.length-1; i>="
 763                             (integer-to-string (+ n-required-arguments n-optional-arguments))
 764                             "; i--)" *newline*
 765                             js!rest " = "
 766                             "{car: arguments[i], cdr: " js!rest "};"
 767                             *newline*))
 768                   "")
 769               ;; Body
 770               (concat (ls-compile-block (butlast body) new-env fenv)
 771                       "return " (ls-compile (car (last body)) new-env fenv) ";")
 772               *newline* "})"))))
 773
 774 (define-compilation fsetq (var val)
 775   (concat (lookup-function-translation var fenv)
 776           " = "
 777           (ls-compile val env fenv)))
 778
 779 (define-compilation setq (var val)
 780   (concat (lookup-variable-translation var env)
 781           " = "
 782            (ls-compile val env fenv)))
 783
 784 ;;; Literals
 785 (defun escape-string (string)
 786   (let ((output "")
 787         (index 0)
 788         (size (length string)))
 789     (while (< index size)
 790       (let ((ch (char string index)))
 791         (when (or (char= ch #\") (char= ch #\\))
 792           (setq output (concat output "\\")))
 793         (when (or (char= ch #\newline))
 794           (setq output (concat output "\\"))
 795           (setq ch #\n))
 796         (setq output (concat output (string ch))))
 797       (incf index))
 798     output))
 799
 800 (defun literal->js (sexp)
 801   (cond
 802     ((integerp sexp) (integer-to-string sexp))
 803     ((stringp sexp) (concat "\"" (escape-string sexp) "\""))
 804     ((symbolp sexp) (ls-compile `(intern ,(escape-string (symbol-name sexp))) *env* *fenv*))
 805     ((consp sexp) (concat "{car: "
 806                           (literal->js (car sexp))
 807                           ", cdr: "
 808                           (literal->js (cdr sexp)) "}"))))
 809
 810 (defvar *literal-counter* 0)
 811 (defun literal (form)
 812   (let ((var (concat "l" (integer-to-string (incf *literal-counter*)))))
 813     (push (concat "var " var " = " (literal->js form)) *toplevel-compilations*)
 814     var))
 815
 816 (define-compilation quote (sexp)
 817   (literal sexp))
 818
 819 (define-compilation debug (form)
 820   (concat "console.log(" (ls-compile form env fenv) ")"))
 821
 822 (define-compilation while (pred &rest body)
 823   (concat "(function(){ while("
 824           (ls-compile pred env fenv) " !== " (ls-compile nil nil nil)
 825           "){"
 826           (ls-compile-block body env fenv)
 827           "}})()"))
 828
 829 (define-compilation function (x)
 830   (cond
 831     ((and (listp x) (eq (car x) 'lambda))
 832      (ls-compile x env fenv))
 833     ((symbolp x)
 834      (lookup-function-translation x fenv))))
 835
 836 (define-compilation eval-when-compile (&rest body)
 837   (eval (cons 'progn body))
 838   "")
 839
 840 (defmacro define-transformation (name args form)
 841   `(define-compilation ,name ,args
 842      (ls-compile ,form env fenv)))
 843
 844 (define-compilation progn (&rest body)
 845   (concat "(function(){" *newline*
 846           (ls-compile-block (butlast body) env fenv)
 847           "return " (ls-compile (car (last body)) env fenv) ";"
 848           "})()" *newline*))
 849
 850 (define-transformation let (bindings &rest body)
 851   (let ((bindings (mapcar #'ensure-list bindings)))
 852     `((lambda ,(mapcar #'car bindings) ,@body)
 853       ,@(mapcar #'cadr bindings))))
 854
 855 ;;; A little backquote implementation without optimizations of any
 856 ;;; kind for lispstrack.
 857 (defun backquote-expand-1 (form)
 858   (cond
 859     ((symbolp form)
 860      (list 'quote form))
 861     ((atom form)
 862      form)
 863     ((eq (car form) 'unquote)
 864      (car form))
 865     ((eq (car form) 'backquote)
 866      (backquote-expand-1 (backquote-expand-1 (cadr form))))
 867     (t
 868      (cons 'append
 869            (mapcar (lambda (s)
 870                      (cond
 871                        ((and (listp s) (eq (car s) 'unquote))
 872                         (list 'list (cadr s)))
 873                        ((and (listp s) (eq (car s) 'unquote-splicing))
 874                         (cadr s))
 875                        (t
 876                         (list 'list (backquote-expand-1 s)))))
 877                    form)))))
 878
 879 (defun backquote-expand (form)
 880   (if (and (listp form) (eq (car form) 'backquote))
 881       (backquote-expand-1 (cadr form))
 882       form))
 883
 884 (defmacro backquote (form)
 885   (backquote-expand-1 form))
 886
 887 (define-transformation backquote (form)
 888   (backquote-expand-1 form))
 889
 890 ;;; Primitives
 891
 892 (defun compile-bool (x)
 893   (concat "(" x "?" (ls-compile t nil nil) ": " (ls-compile nil nil nil) ")"))
 894
 895 (define-compilation + (x y)
 896   (concat "((" (ls-compile x env fenv) ") + (" (ls-compile y env fenv) "))"))
 897
 898 (define-compilation - (x y)
 899   (concat "((" (ls-compile x env fenv) ") - (" (ls-compile y env fenv) "))"))
 900
 901 (define-compilation * (x y)
 902   (concat "((" (ls-compile x env fenv) ") * (" (ls-compile y env fenv) "))"))
 903
 904 (define-compilation / (x y)
 905   (concat "((" (ls-compile x env fenv) ") / (" (ls-compile y env fenv) "))"))
 906
 907 (define-compilation < (x y)
 908   (compile-bool (concat "((" (ls-compile x env fenv) ") < (" (ls-compile y env fenv) "))")))
 909
 910 (define-compilation = (x y)
 911   (compile-bool (concat "((" (ls-compile x env fenv) ") == (" (ls-compile y env fenv) "))")))
 912
 913 (define-compilation numberp (x)
 914   (compile-bool (concat "(typeof (" (ls-compile x env fenv) ") == \"number\")")))
 915
 916
 917 (define-compilation mod (x y)
 918   (concat "((" (ls-compile x env fenv) ") % (" (ls-compile y env fenv) "))"))
 919
 920 (define-compilation floor (x)
 921   (concat "(Math.floor(" (ls-compile x env fenv) "))"))
 922
 923 (define-compilation null (x)
 924   (compile-bool (concat "(" (ls-compile x env fenv) "===" (ls-compile nil env fenv) ")")))
 925
 926 (define-compilation cons (x y)
 927   (concat "({car: " (ls-compile x env fenv) ", cdr: " (ls-compile y env fenv) "})"))
 928
 929 (define-compilation consp (x)
 930   (compile-bool
 931    (concat "(function(){ var tmp = "
 932            (ls-compile x env fenv)
 933            "; return (typeof tmp == 'object' && 'car' in tmp);})()")))
 934
 935 (define-compilation car (x)
 936   (concat "(function () { var tmp = " (ls-compile x env fenv)
 937           "; return tmp === " (ls-compile nil nil nil) "? "
 938           (ls-compile nil nil nil)
 939           ": tmp.car; })()"))
 940
 941 (define-compilation cdr (x)
 942   (concat "(function () { var tmp = " (ls-compile x env fenv)
 943           "; return tmp === " (ls-compile nil nil nil) "? "
 944           (ls-compile nil nil nil)
 945           ": tmp.cdr; })()"))
 946
 947 (define-compilation setcar (x new)
 948   (concat "((" (ls-compile x env fenv) ").car = " (ls-compile new env fenv) ")"))
 949
 950 (define-compilation setcdr (x new)
 951   (concat "((" (ls-compile x env fenv) ").cdr = " (ls-compile new env fenv) ")"))
 952
 953 (define-compilation symbolp (x)
 954   (compile-bool
 955    (concat "(function(){ var tmp = "
 956            (ls-compile x env fenv)
 957            "; return (typeof tmp == 'object' && 'name' in tmp); })()")))
 958
 959 (define-compilation make-symbol (name)
 960   (concat "({name: " (ls-compile name env fenv) "})"))
 961
 962 (define-compilation symbol-name (x)
 963   (concat "(" (ls-compile x env fenv) ").name"))
 964
 965 (define-compilation eq (x y)
 966   (compile-bool
 967    (concat "(" (ls-compile x env fenv) " === " (ls-compile y env fenv) ")")))
 968
 969 (define-compilation equal (x y)
 970   (compile-bool
 971    (concat "(" (ls-compile x env fenv) " == " (ls-compile y env fenv) ")")))
 972
 973 (define-compilation string (x)
 974   (concat "String.fromCharCode(" (ls-compile x env fenv) ")"))
 975
 976 (define-compilation stringp (x)
 977   (compile-bool
 978    (concat "(typeof(" (ls-compile x env fenv) ") == \"string\")")))
 979
 980 (define-compilation string-upcase (x)
 981   (concat "(" (ls-compile x env fenv) ").toUpperCase()"))
 982
 983 (define-compilation string-length (x)
 984   (concat "(" (ls-compile x env fenv) ").length"))
 985
 986 (define-compilation char (string index)
 987   (concat "("
 988           (ls-compile string env fenv)
 989           ").charCodeAt("
 990           (ls-compile index env fenv)
 991           ")"))
 992
 993 (define-compilation concat-two (string1 string2)
 994   (concat "("
 995           (ls-compile string1 env fenv)
 996           ").concat("
 997           (ls-compile string2 env fenv)
 998           ")"))
 999
1000 (define-compilation funcall (func &rest args)
1001   (concat "("
1002           (ls-compile func env fenv)
1003           ")("
1004           (join (mapcar (lambda (x)
1005                           (ls-compile x env fenv))
1006                         args)
1007                 ", ")
1008           ")"))
1009
1010 (define-compilation apply (func &rest args)
1011   (if (null args)
1012       (concat "(" (ls-compile func env fenv) ")()")
1013       (let ((args (butlast args))
1014             (last (car (last args))))
1015         (concat "(function(){" *newline*
1016                 "var f = " (ls-compile func env fenv) ";" *newline*
1017                 "var args = [" (join (mapcar (lambda (x)
1018                                                (ls-compile x env fenv))
1019                                              args)
1020                                      ", ")
1021                 "];" *newline*
1022                 "var tail = (" (ls-compile last env fenv) ");" *newline*
1023                 "while (tail != " (ls-compile nil env fenv) "){" *newline*
1024                 "    args.push(tail.car);" *newline*
1025                 "    tail = tail.cdr;" *newline*
1026                 "}" *newline*
1027                 "return f.apply(this, args);" *newline*
1028                 "})()" *newline*))))
1029
1030 (define-compilation js-eval (string)
1031   (concat "eval.apply(window, [" (ls-compile string env fenv)  "])"))
1032
1033
1034 (define-compilation error (string)
1035   (concat "(function (){ throw " (ls-compile string env fenv) ";" "return 0;})()"))
1036
1037 (define-compilation new ()
1038   "{}")
1039
1040 (define-compilation get (object key)
1041   (concat "(function(){ var tmp = "
1042           "(" (ls-compile object env fenv) ")[" (ls-compile key env fenv) "]"
1043           ";"
1044           "return tmp == undefined? " (ls-compile nil nil nil) ": tmp ;"
1045           "})()"))
1046
1047 (define-compilation set (object key value)
1048   (concat "(("
1049           (ls-compile object env fenv)
1050           ")["
1051           (ls-compile key env fenv) "]"
1052           " = " (ls-compile value env fenv) ")"))
1053
1054 (define-compilation in (key object)
1055   (compile-bool
1056    (concat "(" (ls-compile key env fenv) " in " (ls-compile object env fenv) ")")))
1057
1058 (define-compilation functionp (x)
1059   (compile-bool
1060    (concat "(typeof " (ls-compile x env fenv) " == 'function')")))
1061
1062
1063 (defun macrop (x)
1064   (and (symbolp x) (eq (binding-type (lookup-function x *fenv*)) 'macro)))
1065
1066 (defun ls-macroexpand-1 (form env fenv)
1067   (if (macrop (car form))
1068       (let ((binding (lookup-function (car form) *env*)))
1069         (if (eq (binding-type binding) 'macro)
1070             (apply (eval (binding-translation binding)) (cdr form))
1071             form))
1072       form))
1073
1074 (defun compile-funcall (function args env fenv)
1075   (cond
1076     ((symbolp function)
1077      (concat (lookup-function-translation function fenv)
1078              "("
1079              (join (mapcar (lambda (x) (ls-compile x env fenv)) args)
1080                    ", ")
1081              ")"))
1082     ((and (listp function) (eq (car function) 'lambda))
1083      (concat "(" (ls-compile function env fenv) ")("
1084              (join (mapcar (lambda (x) (ls-compile x env fenv)) args)
1085                    ", ")
1086              ")"))
1087     (t
1088      (error (concat "Invalid function designator " (symbol-name function))))))
1089
1090 (defun ls-compile (sexp env fenv)
1091   (cond
1092     ((symbolp sexp) (lookup-variable-translation sexp env))
1093     ((integerp sexp) (integer-to-string sexp))
1094     ((stringp sexp) (concat "\"" (escape-string sexp) "\""))
1095     ((listp sexp)
1096      (if (assoc (car sexp) *compilations*)
1097          (let ((comp (second (assoc (car sexp) *compilations*))))
1098            (apply comp env fenv (cdr sexp)))
1099          (if (macrop (car sexp))
1100              (ls-compile (ls-macroexpand-1 sexp env fenv) env fenv)
1101              (compile-funcall (car sexp) (cdr sexp) env fenv))))))
1102
1103 (defun ls-compile-toplevel (sexp)
1104   (setq *toplevel-compilations* nil)
1105   (let ((code (ls-compile sexp nil nil)))
1106     (prog1
1107         (concat (join (mapcar (lambda (x) (concat x ";" *newline*))
1108                               *toplevel-compilations*)
1109                "")
1110                 code)
1111       (setq *toplevel-compilations* nil))))
1112
1113
1114 ;;; Once we have the compiler, we define the runtime environment and
1115 ;;; interactive development (eval), which works calling the compiler
1116 ;;; and evaluating the Javascript result globally.
1117
1118 #+lispstrack
1119 (progn
1120  (defmacro with-compilation-unit (&rest body)
1121    `(prog1
1122         (progn
1123           (setq *compilation-unit-checks* nil)
1124           (setq *env* (remove-if-not #'binding-declared *env*))
1125           (setq *fenv* (remove-if-not #'binding-declared *fenv*))
1126           ,@body)
1127       (dolist (check *compilation-unit-checks*)
1128         (funcall check))))
1129
1130  (defun eval (x)
1131    (let ((code
1132           (with-compilation-unit
1133               (ls-compile-toplevel x))))
1134      (js-eval code)))
1135
1136  ;; Set the initial global environment to be equal to the host global
1137  ;; environment at this point of the compilation.
1138  (eval-when-compile
1139    (let ((c1 (ls-compile `(setq *fenv* ',*fenv*) nil nil))
1140          (c2 (ls-compile `(setq *env* ',*env*) nil nil))
1141          (c3 (ls-compile `(setq *variable-counter* ',*variable-counter*) nil nil))
1142          (c4 (ls-compile `(setq *function-counter* ',*function-counter*) nil nil))
1143          (c5 (ls-compile `(setq *literal-counter* ',*literal-counter*) nil nil)))
1144      (setq *toplevel-compilations*
1145            (append *toplevel-compilations* (list c1 c2 c3 c4 c5)))))
1146
1147  (js-eval
1148   (concat "var lisp = {};"
1149           "lisp.read = " (lookup-function-translation 'ls-read-from-string nil) ";" *newline*
1150           "lisp.print = " (lookup-function-translation 'print-to-string nil) ";" *newline*
1151           "lisp.eval = " (lookup-function-translation 'eval nil) ";" *newline*
1152           "lisp.compile = " (lookup-function-translation 'ls-compile-toplevel nil) ";" *newline*
1153           "lisp.evalString = function(str){" *newline*
1154           "   return lisp.eval(lisp.read(str));" *newline*
1155           "}" *newline*
1156           "lisp.compileString = function(str){" *newline*
1157           "   return lisp.compile(lisp.read(str));" *newline*
1158           "}" *newline*)))
1159
1160
1161 ;;; Finally, we provide a couple of functions to easily bootstrap
1162 ;;; this. It just calls the compiler with this file as input.
1163
1164 #+common-lisp
1165 (progn
1166   (defun read-whole-file (filename)
1167     (with-open-file (in filename)
1168       (let ((seq (make-array (file-length in) :element-type 'character)))
1169         (read-sequence seq in)
1170         seq)))
1171
1172   (defun ls-compile-file (filename output)
1173     (setq *env* nil *fenv* nil)
1174     (setq *compilation-unit-checks* nil)
1175     (with-open-file (out output :direction :output :if-exists :supersede)
1176       (let* ((source (read-whole-file filename))
1177              (in (make-string-stream source)))
1178         (loop
1179            for x = (ls-read in)
1180            until (eq x *eof*)
1181            for compilation = (ls-compile-toplevel x)
1182            when (plusp (length compilation))
1183            do (write-line (concat compilation "; ") out))
1184         (dolist (check *compilation-unit-checks*)
1185           (funcall check))
1186         (setq *compilation-unit-checks* nil))))
1187
1188   (defun bootstrap ()
1189     (ls-compile-file "lispstrack.lisp" "lispstrack.js")))