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