lispstrack.lisp

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