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