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