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