ecmalisp.lisp

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