lispstrack.lisp

   1 (defun ensure-list (x)
   2   (if (listp x)
   3       x
   4       (list x)))
   5
   6 (defun !reduce (func list initial)
   7   (if (null list)
   8       initial
   9       (!reduce func
  10                (cdr list)
  11                (funcall func initial (car list)))))
  12
  13 ;;; Utils
  14
  15 #+common-lisp
  16 (progn
  17   (defmacro while (condition &body body)
  18     `(do ()
  19          ((not ,condition))
  20        ,@body))
  21
  22   (defun concat-two (s1 s2)
  23     (concatenate 'string s1 s2))
  24
  25   (defun setcar (cons new)
  26     (setf (car cons) new))
  27   (defun setcdr (cons new)
  28     (setf (cdr cons) new)))
  29
  30 (defvar *newline* (string (code-char 10)))
  31
  32 (defun concat (&rest strs)
  33   (!reduce (lambda (s1 s2) (concat-two s1 s2))
  34            strs
  35            ""))
  36
  37 ;;; Concatenate a list of strings, with a separator
  38 (defun join (list separator)
  39   (cond
  40     ((null list)
  41      "")
  42     ((null (cdr list))
  43      (car list))
  44     (t
  45      (concat (car list)
  46              separator
  47              (join (cdr list) separator)))))
  48
  49 (defun join-trailing (list separator)
  50   (cond
  51     ((null list)
  52      "")
  53     ((null (car list))
  54      (join-trailing (cdr list) separator))
  55     (t
  56      (concat (car list) separator (join-trailing (cdr list) separator)))))
  57
  58 (defun integer-to-string (x)
  59   (if (zerop x)
  60       "0"
  61       (let ((digits nil))
  62         (while (not (= x 0))
  63           (push (mod x 10) digits)
  64           (setq x (truncate x 10)))
  65         (join (mapcar (lambda (d) (string (char "0123456789" d)))
  66                       digits)
  67               ""))))
  68
  69 ;;;; Reader
  70
  71 ;;; It is a basic Lisp reader. It does not use advanced stuff
  72 ;;; intentionally, because we want to use it to bootstrap a simple
  73 ;;; Lisp. The main entry point is the function `ls-read', which
  74 ;;; accepts a strings as argument and return the Lisp expression.
  75 (defun make-string-stream (string)
  76   (cons string 0))
  77
  78 (defun %peek-char (stream)
  79   (and (< (cdr stream) (length (car stream)))
  80        (char (car stream) (cdr stream))))
  81
  82 (defun %read-char (stream)
  83   (and (< (cdr stream) (length (car stream)))
  84        (prog1 (char (car stream) (cdr stream))
  85          (setcdr stream (1+ (cdr stream))))))
  86
  87 (defun whitespacep (ch)
  88   (or (char= ch #\space) (char= ch #\newline) (char= ch #\tab)))
  89
  90 (defun skip-whitespaces (stream)
  91   (let (ch)
  92     (setq ch (%peek-char stream))
  93     (while (and ch (whitespacep ch))
  94       (%read-char stream)
  95       (setq ch (%peek-char stream)))))
  96
  97 (defun terminalp (ch)
  98   (or (null ch) (whitespacep ch) (char= #\) ch) (char= #\( ch)))
  99
 100 (defun read-until (stream func)
 101   (let ((string "")
 102         (ch))
 103     (setq ch (%peek-char stream))
 104     (while (not (funcall func ch))
 105       (setq string (concat string (string ch)))
 106       (%read-char stream)
 107       (setq ch (%peek-char stream)))
 108     string))
 109
 110 (defun skip-whitespaces-and-comments (stream)
 111   (let (ch)
 112     (skip-whitespaces stream)
 113     (setq ch (%peek-char stream))
 114     (while (and ch (char= ch #\;))
 115       (read-until stream (lambda (x) (char= x #\newline)))
 116       (skip-whitespaces stream)
 117       (setq ch (%peek-char stream)))))
 118
 119 (defun %read-list (stream)
 120   (skip-whitespaces-and-comments stream)
 121   (let ((ch (%peek-char stream)))
 122     (cond
 123       ((char= ch #\))
 124        (%read-char stream)
 125        nil)
 126       ((char= ch #\.)
 127        (%read-char stream)
 128        (skip-whitespaces-and-comments stream)
 129        (prog1 (ls-read stream)
 130          (unless (char= (%read-char stream) #\))
 131            (error "')' was expected."))))
 132       (t
 133        (cons (ls-read stream) (%read-list stream))))))
 134
 135 (defvar *eof* (make-symbol "EOF"))
 136 (defun ls-read (stream)
 137   (skip-whitespaces-and-comments stream)
 138   (let ((ch (%peek-char stream)))
 139     (cond
 140       ((null ch)
 141        *eof*)
 142       ((char= ch #\()
 143        (%read-char stream)
 144        (%read-list stream))
 145       ((char= ch #\')
 146        (%read-char stream)
 147        (list 'quote (ls-read stream)))
 148       ((char= ch #\`)
 149        (%read-char stream)
 150        (list 'backquote (ls-read stream)))
 151       ((char= ch #\")
 152        (%read-char stream)
 153        (prog1 (read-until stream (lambda (ch) (char= ch #\")))
 154          (%read-char stream)))
 155       ((char= ch #\,)
 156        (%read-char stream)
 157        (if (eql (%peek-char stream) #\@)
 158            (progn (%read-char stream) (list 'unquote-splicing (ls-read stream)))
 159            (list 'unquote (ls-read stream))))
 160       ((char= ch #\#)
 161        (%read-char stream)
 162        (ecase (%read-char stream)
 163          (#\'
 164           (list 'function (ls-read stream)))
 165          (#\\
 166           (let ((cname
 167                  (concat (string (%read-char stream))
 168                          (read-until stream #'terminalp))))
 169             (cond
 170               ((string= cname "space") (char-code #\space))
 171               ((string= cname "newline") (char-code #\newline))
 172               (t (char-code (char cname 0))))))
 173          (#\+
 174           (let ((feature (read-until stream #'terminalp)))
 175             (cond
 176               ((string= feature "common-lisp")
 177                (ls-read stream)         ;ignore
 178                (ls-read stream))
 179               ((string= feature "lispstrack")
 180                (ls-read stream))
 181               (t
 182                (error "Unknown reader form.")))))))
 183       (t
 184        (let ((string (read-until stream #'terminalp)))
 185          (if (every #'digit-char-p string)
 186              (parse-integer string)
 187              (intern (string-upcase string))))))))
 188
 189 (defun ls-read-from-string (string)
 190   (ls-read (make-string-stream string)))
 191
 192
 193 ;;;; Compiler
 194
 195 (defvar *compilation-unit-checks* '())
 196
 197 (defvar *env* '())
 198 (defvar *fenv* '())
 199
 200 (defun make-binding (name type js declared)
 201   (list name type js declared))
 202
 203 (defun binding-name (b) (first b))
 204 (defun binding-type (b) (second b))
 205 (defun binding-translation (b) (third b))
 206 (defun binding-declared (b)
 207   (and b (fourth b)))
 208 (defun mark-binding-as-declared (b)
 209   (setcar (cdddr b) t))
 210
 211 (let ((counter 0))
 212   (defun gvarname (symbol)
 213     (concat "v" (integer-to-string (incf counter))))
 214
 215   (defun lookup-variable (symbol env)
 216     (or (assoc symbol env)
 217         (assoc symbol *env*)
 218         (let ((name (symbol-name symbol))
 219               (binding (make-binding symbol 'variable (gvarname symbol) nil)))
 220           (push binding *env*)
 221           (push (lambda ()
 222                   (unless (binding-declared (assoc symbol *env*))
 223                     (error (concat "Undefined variable `" name "'"))))
 224                 *compilation-unit-checks*)
 225           binding)))
 226
 227   (defun lookup-variable-translation (symbol env)
 228     (binding-translation (lookup-variable symbol env)))
 229
 230   (defun extend-local-env (args env)
 231     (append (mapcar (lambda (symbol)
 232                       (make-binding symbol 'variable (gvarname symbol) t))
 233                     args)
 234             env)))
 235
 236 (let ((counter 0))
 237   (defun lookup-function (symbol env)
 238     (or (assoc symbol env)
 239         (assoc symbol *fenv*)
 240         (let ((name (symbol-name symbol))
 241               (binding
 242                (make-binding symbol
 243                              'function
 244                              (concat "f" (integer-to-string (incf counter)))
 245                              nil)))
 246           (push binding *fenv*)
 247           (push (lambda ()
 248                   (unless (binding-declared (assoc symbol *fenv*))
 249                     (error (concat "Undefined function `" name "'"))))
 250                 *compilation-unit-checks*)
 251           binding)))
 252
 253   (defun lookup-function-translation (symbol env)
 254     (binding-translation (lookup-function symbol env))))
 255
 256
 257 (defvar *toplevel-compilations*)
 258
 259 (defun %compile-defvar (name)
 260   (let ((b (lookup-variable name *env*)))
 261     (mark-binding-as-declared b)
 262     (push (concat "var " (binding-translation b)) *toplevel-compilations*)))
 263
 264 (defun %compile-defun (name)
 265   (let ((b (lookup-function name *env*)))
 266     (mark-binding-as-declared b)
 267     (push (concat "var " (binding-translation b)) *toplevel-compilations*)))
 268
 269 (defun %compile-defmacro (name lambda)
 270   (push (make-binding name 'macro lambda t) *fenv*))
 271
 272
 273 (defvar *compilations* nil)
 274
 275 (defun ls-compile-block (sexps env fenv)
 276   (join-trailing
 277    (remove nil (mapcar (lambda (x)
 278                          (ls-compile x env fenv))
 279                        sexps))
 280                  ";
 281 "))
 282 (defmacro define-compilation (name args &body body)
 283   ;; Creates a new primitive `name' with parameters args and
 284   ;; @body. The body can access to the local environment through the
 285   ;; variable ENV.
 286   `(push (list ',name (lambda (env fenv ,@args) ,@body))
 287          *compilations*))
 288
 289 (define-compilation if (condition true false)
 290   (concat "("
 291           (ls-compile condition env fenv)
 292           " ? "
 293           (ls-compile true env fenv)
 294           " : "
 295           (ls-compile false env fenv)
 296           ")"))
 297
 298 ;;; Return the required args of a lambda list
 299 (defun lambda-list-required-argument (lambda-list)
 300   (if (or (null lambda-list) (eq (car lambda-list) '&rest))
 301       nil
 302       (cons (car lambda-list) (lambda-list-required-argument (cdr lambda-list)))))
 303
 304 (defun lambda-list-rest-argument (lambda-list)
 305   (second (member '&rest lambda-list)))
 306
 307 (define-compilation lambda (lambda-list &rest body)
 308   (let ((required-arguments (lambda-list-required-argument lambda-list))
 309         (rest-argument (lambda-list-rest-argument lambda-list)))
 310     (let ((new-env (extend-local-env
 311                     (append (if rest-argument (list rest-argument))
 312                             required-arguments)
 313                     env)))
 314       (concat "(function ("
 315               (join (mapcar (lambda (x)
 316                               (lookup-variable-translation x new-env))
 317                             required-arguments)
 318                     ",")
 319               "){"
 320               *newline*
 321               (if rest-argument
 322                   (let ((js!rest (lookup-variable-translation rest-argument new-env)))
 323                     (concat "var " js!rest ";" *newline*
 324                             "for (var i = arguments.length-1; i>="
 325                             (integer-to-string (length required-arguments))
 326                             "; i--)" *newline*
 327                             js!rest " = "
 328                             "{car: arguments[i], cdr: " js!rest "};"
 329                             *newline*))
 330                   "")
 331               (concat (ls-compile-block (butlast body) new-env fenv)
 332                       "return " (ls-compile (car (last body)) new-env fenv) ";")
 333               *newline*
 334               "})"))))
 335
 336 (define-compilation fsetq (var val)
 337   (concat (lookup-function-translation var fenv)
 338           " = "
 339           (ls-compile val env fenv)))
 340
 341 (define-compilation setq (var val)
 342   (concat (lookup-variable-translation var env)
 343           " = "
 344            (ls-compile val env fenv)))
 345
 346 ;;; Literals
 347
 348 (defun literal->js (sexp)
 349   (cond
 350     ((null sexp) "false")
 351     ((integerp sexp) (integer-to-string sexp))
 352     ((stringp sexp) (concat "\"" sexp "\""))
 353     ((symbolp sexp) (concat "{name: \"" (symbol-name sexp) "\"}"))
 354     ((consp sexp) (concat "{car: "
 355                           (literal->js (car sexp))
 356                           ", cdr: "
 357                           (literal->js (cdr sexp)) "}"))))
 358
 359 (let ((counter 0))
 360   (defun literal (form)
 361     (if (null form)
 362         (literal->js form)
 363         (let ((var (concat "l" (integer-to-string (incf counter)))))
 364           (push (concat "var " var " = " (literal->js form)) *toplevel-compilations*)
 365           var))))
 366
 367 (define-compilation quote (sexp)
 368   (literal sexp))
 369
 370 (define-compilation debug (form)
 371   (concat "console.log(" (ls-compile form env fenv) ")"))
 372
 373 (define-compilation while (pred &rest body)
 374   (concat "(function(){ while("
 375           (ls-compile pred env fenv)
 376           "){"
 377           (ls-compile-block body env fenv)
 378           "}})()"))
 379
 380 (define-compilation function (x)
 381   (cond
 382     ((and (listp x) (eq (car x) 'lambda))
 383      (ls-compile x env fenv))
 384     ((symbolp x)
 385      (lookup-function-translation x fenv))))
 386
 387 #+common-lisp
 388 (defmacro eval-when-compile (&body body)
 389   `(eval-when (:compile-toplevel :load-toplevel :execute)
 390      ,@body))
 391
 392 (define-compilation eval-when-compile (&rest body)
 393   (eval (cons 'progn body))
 394   nil)
 395
 396 (defmacro define-transformation (name args form)
 397   `(define-compilation ,name ,args
 398      (ls-compile ,form env fenv)))
 399
 400 (define-transformation progn (&rest body)
 401   `((lambda () ,@body)))
 402
 403 (define-transformation let (bindings &rest body)
 404   (let ((bindings (mapcar #'ensure-list bindings)))
 405     `((lambda ,(mapcar 'car bindings) ,@body)
 406       ,@(mapcar 'cadr bindings))))
 407
 408 ;;; A little backquote implementation without optimizations of any
 409 ;;; kind for lispstrack.
 410 (defun backquote-expand-1 (form)
 411   (cond
 412     ((symbolp form)
 413      (list 'quote form))
 414     ((atom form)
 415      form)
 416     ((eq (car form) 'unquote)
 417      (car form))
 418     ((eq (car form) 'backquote)
 419      (backquote-expand-1 (backquote-expand-1 (cadr form))))
 420     (t
 421      (cons 'append
 422            (mapcar (lambda (s)
 423                      (cond
 424                        ((and (listp s) (eq (car s) 'unquote))
 425                         (list 'list (cadr s)))
 426                        ((and (listp s) (eq (car s) 'unquote-splicing))
 427                         (cadr s))
 428                        (t
 429                         (list 'list (backquote-expand-1 s)))))
 430                    form)))))
 431
 432 (defun backquote-expand (form)
 433   (if (and (listp form) (eq (car form) 'backquote))
 434       (backquote-expand-1 (cadr form))
 435       form))
 436
 437 (defmacro backquote (form)
 438   (backquote-expand-1 form))
 439
 440 (define-transformation backquote (form)
 441   (backquote-expand-1 form))
 442
 443 ;;; Primitives
 444
 445 (define-compilation + (x y)
 446   (concat "((" (ls-compile x env fenv) ") + (" (ls-compile y env fenv) "))"))
 447
 448 (define-compilation - (x y)
 449   (concat "((" (ls-compile x env fenv) ") - (" (ls-compile y env fenv) "))"))
 450
 451 (define-compilation * (x y)
 452   (concat "((" (ls-compile x env fenv) ") * (" (ls-compile y env fenv) "))"))
 453
 454 (define-compilation / (x y)
 455   (concat "((" (ls-compile x env fenv) ") / (" (ls-compile y env fenv) "))"))
 456
 457 (define-compilation < (x y)
 458   (concat "((" (ls-compile x env fenv) ") < (" (ls-compile y env fenv) "))"))
 459
 460 (define-compilation = (x y)
 461   (concat "((" (ls-compile x env fenv) ") == (" (ls-compile y env fenv) "))"))
 462
 463 (define-compilation mod (x y)
 464   (concat "((" (ls-compile x env fenv) ") % (" (ls-compile y env fenv) "))"))
 465
 466 (define-compilation floor (x)
 467   (concat "(Math.floor(" (ls-compile x env fenv) "))"))
 468
 469 (define-compilation null (x)
 470   (concat "(" (ls-compile x env fenv) "== false)"))
 471
 472 (define-compilation cons (x y)
 473   (concat "{car: " (ls-compile x env fenv) ", cdr: " (ls-compile y env fenv) "}"))
 474
 475 (define-compilation car (x)
 476   (concat "(" (ls-compile x env fenv) ").car"))
 477
 478 (define-compilation cdr (x)
 479   (concat "(" (ls-compile x env fenv) ").cdr"))
 480
 481 (define-compilation setcar (x new)
 482   (concat "((" (ls-compile x env fenv) ").car = " (ls-compile new env fenv) ")"))
 483
 484 (define-compilation setcdr (x new)
 485   (concat "((" (ls-compile x env fenv) ").cdr = " (ls-compile new env fenv) ")"))
 486
 487 (define-compilation make-symbol (name)
 488   (concat "{name: " (ls-compile name env fenv) "}"))
 489
 490 (define-compilation symbol-name (x)
 491   (concat "(" (ls-compile x env fenv) ").name"))
 492
 493 (define-compilation eq (x y)
 494   (concat "(" (ls-compile x env fenv) " === " (ls-compile y env fenv) ")"))
 495
 496 (define-compilation equal (x y)
 497   (concat "(" (ls-compile x env fenv) " == " (ls-compile y env fenv) ")"))
 498
 499 (define-compilation string (x)
 500   (concat "String.fromCharCode(" (ls-compile x env fenv) ")"))
 501
 502 (define-compilation string-upcase (x)
 503   (concat "(" (ls-compile x env fenv) ").toUpperCase()"))
 504
 505 (define-compilation string-length (x)
 506   (concat "(" (ls-compile x env fenv) ").length"))
 507
 508 (define-compilation char (string index)
 509   (concat "("
 510           (ls-compile string env fenv)
 511           ").charCodeAt("
 512           (ls-compile index env fenv)
 513           ")"))
 514
 515 (define-compilation concat-two (string1 string2)
 516   (concat "("
 517           (ls-compile string1 env fenv)
 518           ").concat("
 519           (ls-compile string2 env fenv)
 520           ")"))
 521
 522 (define-compilation funcall (func &rest args)
 523   (concat "("
 524           (ls-compile func env fenv)
 525           ")("
 526           (join (mapcar (lambda (x)
 527                           (ls-compile x env fenv))
 528                         args)
 529                 ", ")
 530           ")"))
 531
 532 (define-compilation error (string)
 533   (concat "(function (){ throw " (ls-compile string env fenv) ";" "return 0;})()"))
 534
 535 (define-compilation new ()
 536   "{}")
 537
 538 (define-compilation get (object key)
 539   (concat "(" (ls-compile object env fenv) ")[" (ls-compile key env fenv) "]"))
 540
 541 (define-compilation set (object key value)
 542   (concat "(("
 543           (ls-compile object env fenv)
 544           ")["
 545           (ls-compile key env fenv) "]"
 546           " = " (ls-compile value env fenv) ")"))
 547
 548 (defun macrop (x)
 549   (and (symbolp x) (eq (binding-type (lookup-function x *fenv*)) 'macro)))
 550
 551 (defun ls-macroexpand-1 (form &optional env fenv)
 552   (when (macrop (car form))
 553     (let ((binding (lookup-function (car form) *env*)))
 554       (if (eq (binding-type binding) 'macro)
 555           (apply (eval (binding-translation binding)) (cdr form))
 556           form))))
 557
 558 (defun compile-funcall (function args env fenv)
 559   (cond
 560     ((symbolp function)
 561      (concat (lookup-function-translation function fenv)
 562              "("
 563              (join (mapcar (lambda (x) (ls-compile x env fenv)) args)
 564                    ", ")
 565              ")"))
 566     ((and (listp function) (eq (car function) 'lambda))
 567      (concat "(" (ls-compile function env fenv) ")("
 568              (join (mapcar (lambda (x) (ls-compile x env fenv)) args)
 569                    ", ")
 570              ")"))
 571     (t
 572      (error "Invalid function designator ~a." function))))
 573
 574 (defun ls-compile (sexp &optional env fenv)
 575   (cond
 576     ((symbolp sexp) (lookup-variable-translation sexp env))
 577     ((integerp sexp) (integer-to-string sexp))
 578     ((stringp sexp) (concat "\"" sexp "\""))
 579     ((listp sexp)
 580      (if (assoc (car sexp) *compilations*)
 581          (let ((comp (second (assoc (car sexp) *compilations*))))
 582            (apply comp env fenv (cdr sexp)))
 583          (if (macrop (car sexp))
 584              (ls-compile (ls-macroexpand-1 sexp env fenv) env fenv)
 585              (compile-funcall (car sexp) (cdr sexp) env fenv))))))
 586
 587 (defun ls-compile-toplevel (sexp)
 588   (setq *toplevel-compilations* nil)
 589   (let ((code (ls-compile sexp)))
 590     (prog1
 591         (concat (join (mapcar (lambda (x) (concat x ";" *newline*))
 592                               *toplevel-compilations*)
 593                       "")
 594                 code)
 595       (setq *toplevel-compilations* nil))))
 596
 597 #+common-lisp
 598 (progn
 599   (defun read-whole-file (filename)
 600     (with-open-file (in filename)
 601       (let ((seq (make-array (file-length in) :element-type 'character)))
 602         (read-sequence seq in)
 603         seq)))
 604
 605   (defun ls-compile-file (filename output)
 606     (setq *env* nil *fenv* nil)
 607     (setq *compilation-unit-checks* nil)
 608     (with-open-file (out output :direction :output :if-exists :supersede)
 609       (let* ((source (read-whole-file filename))
 610              (in (make-string-stream source)))
 611         (loop
 612            for x = (ls-read in)
 613            until (eq x *eof*)
 614            for compilation = (ls-compile-toplevel x)
 615            when (plusp (length compilation))
 616            do (write-line (concat compilation "; ") out))
 617         (dolist (check *compilation-unit-checks*)
 618           (funcall check))
 619         (setq *compilation-unit-checks* nil))))
 620
 621   (defun bootstrap ()
 622     (ls-compile-file "lispstrack.lisp" "lispstrack.js")))