test.lisp

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