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 (eql ch #\;))
 116       (read-until stream (lambda (x) (eql 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 (read-until stream #'terminalp)))
 168             (cond
 169               ((string= cname "space") (char-code #\space))
 170               ((string= cname "newline") (char-code #\newline))
 171               (t (char-code (char cname 0))))))
 172          (#\+
 173           (let ((feature (read-until stream #'terminalp)))
 174             (cond
 175               ((string= feature "common-lisp")
 176                (ls-read stream)         ;ignore
 177                (ls-read stream))
 178               ((string= feature "lispstrack")
 179                (ls-read stream))
 180               (t
 181                (error "Unknown reader form.")))))))
 182       (t
 183        (let ((string (read-until stream #'terminalp)))
 184          (if (every #'digit-char-p string)
 185              (parse-integer string)
 186              (intern (string-upcase string))))))))
 187
 188 (defun ls-read-from-string (string)
 189   (ls-read (make-string-stream string)))
 190
 191
 192 ;;;; Compiler
 193
 194 (let ((counter 0))
 195   (defun make-var-binding (symbol)
 196     (cons symbol (concat "v" (integer-to-string (incf counter))))))
 197
 198 (let ((counter 0))
 199   (defun make-func-binding (symbol)
 200     (cons symbol (concat "f" (integer-to-string (incf counter))))))
 201
 202 (defvar *compilations* nil)
 203
 204 (defun ls-compile-block (sexps env fenv)
 205   (join-trailing
 206    (remove nil (mapcar (lambda (x)
 207                          (ls-compile x env fenv))
 208                        sexps))
 209                  ";
 210 "))
 211
 212 (defun extend-env (args env)
 213   (append (mapcar #'make-var-binding args) env))
 214
 215 (defparameter *env* '())
 216 (defparameter *fenv* '())
 217
 218 (defun lookup (symbol env)
 219   (let ((binding (assoc symbol env)))
 220     (and binding (cdr binding))))
 221
 222 (defun lookup-variable (symbol env)
 223   (or (lookup symbol env)
 224       (lookup symbol *env*)
 225       (error "Undefined variable `~a'"  symbol)))
 226
 227 (defun lookup-function (symbol env)
 228   (or (lookup symbol env)
 229       (lookup symbol *fenv*)
 230       (error "Undefined function `~a'"  symbol)))
 231
 232 (defmacro define-compilation (name args &body body)
 233   ;; Creates a new primitive `name' with parameters args and
 234   ;; @body. The body can access to the local environment through the
 235   ;; variable ENV.
 236   `(push (list ',name (lambda (env fenv ,@args) ,@body))
 237          *compilations*))
 238
 239 (defvar *toplevel-compilations*)
 240
 241 (define-compilation if (condition true false)
 242   (concat "("
 243           (ls-compile condition env fenv)
 244           " ? "
 245           (ls-compile true env fenv)
 246           " : "
 247           (ls-compile false env fenv)
 248           ")"))
 249
 250 ;;; Return the required args of a lambda list
 251 (defun lambda-list-required-argument (lambda-list)
 252   (if (or (null lambda-list) (eq (car lambda-list) '&rest))
 253       nil
 254       (cons (car lambda-list) (lambda-list-required-argument (cdr lambda-list)))))
 255
 256 (defun lambda-list-rest-argument (lambda-list)
 257   (second (member '&rest lambda-list)))
 258
 259 (define-compilation lambda (lambda-list &rest body)
 260   (let ((required-arguments (lambda-list-required-argument lambda-list))
 261         (rest-argument (lambda-list-rest-argument lambda-list)))
 262     (let ((new-env (extend-env (append (if rest-argument (list rest-argument))
 263                                        required-arguments)
 264                                env)))
 265       (concat "(function ("
 266               (join (mapcar (lambda (x) (lookup-variable x new-env))
 267                             required-arguments)
 268                     ",")
 269               "){"
 270               *newline*
 271               (if rest-argument
 272                   (concat "var " (lookup-variable rest-argument new-env) ";" *newline*
 273                           "for (var i = arguments.length-1; i>="
 274                           (integer-to-string (length required-arguments))
 275                           "; i--)" *newline*
 276                           (lookup-variable rest-argument new-env) " = "
 277                           "{car: arguments[i], cdr: " (lookup-variable rest-argument new-env) "};"
 278                           *newline*)
 279                   "")
 280               (concat (ls-compile-block (butlast body) new-env fenv)
 281                       "return " (ls-compile (car (last body)) new-env fenv) ";")
 282               *newline*
 283               "})"))))
 284
 285 (define-compilation fsetq (var val)
 286   (concat (lookup-function var fenv)
 287           " = "
 288           (ls-compile val env fenv)))
 289
 290 (define-compilation setq (var val)
 291   (concat (lookup-variable var env)
 292           " = "
 293            (ls-compile val env fenv)))
 294
 295
 296 ;;; Literals
 297
 298 (defun literal->js (sexp)
 299   (cond
 300     ((null sexp) "undefined")
 301     ((integerp sexp) (integer-to-string sexp))
 302     ((stringp sexp) (concat "\"" sexp "\""))
 303     ((symbolp sexp) (concat "{name: \"" (symbol-name sexp) "\"}"))
 304     ((consp sexp) (concat "{car: "
 305                           (literal->js (car sexp))
 306                           ", cdr: "
 307                           (literal->js (cdr sexp)) "}"))))
 308
 309 (let ((counter 0))
 310   (defun literal (form)
 311     (if (null form)
 312         (literal->js form)
 313         (let ((var (concat "l" (integer-to-string (incf counter)))))
 314           (push (concat "var " var " = " (literal->js form)) *toplevel-compilations*)
 315           var))))
 316
 317 (define-compilation quote (sexp)
 318   (literal sexp))
 319
 320 (define-compilation debug (form)
 321   (concat "console.log(" (ls-compile form env fenv) ")"))
 322
 323 (define-compilation while (pred &rest body)
 324   (concat "(function(){ while("
 325           (ls-compile pred env fenv)
 326           "){"
 327           (ls-compile-block body env fenv)
 328           "}})()"))
 329
 330 (define-compilation function (x)
 331   (cond
 332     ((and (listp x) (eq (car x) 'lambda))
 333      (ls-compile x env fenv))
 334     ((symbolp x)
 335      (lookup-function x fenv))))
 336
 337 #+common-lisp
 338 (defmacro eval-when-compile (&body body)
 339   `(eval-when (:compile-toplevel :load-toplevel :execute)
 340      ,@body))
 341
 342 (define-compilation eval-when-compile (&rest body)
 343   (eval (cons 'progn body))
 344   nil)
 345
 346 (defmacro define-transformation (name args form)
 347   `(define-compilation ,name ,args
 348      (ls-compile ,form env fenv)))
 349
 350 (define-transformation progn (&rest body)
 351   `((lambda () ,@body)))
 352
 353 (define-transformation let (bindings &rest body)
 354   (let ((bindings (mapcar #'ensure-list bindings)))
 355     `((lambda ,(mapcar 'car bindings) ,@body)
 356       ,@(mapcar 'cadr bindings))))
 357
 358 ;;; A little backquote implementation without optimizations of any
 359 ;;; kind for lispstrack.
 360 (defun backquote-expand-1 (form)
 361   (cond
 362     ((symbolp form)
 363      (list 'quote form))
 364     ((atom form)
 365      form)
 366     ((eq (car form) 'unquote)
 367      (car form))
 368     ((eq (car form) 'backquote)
 369      (backquote-expand-1 (backquote-expand-1 (cadr form))))
 370     (t
 371      (cons 'append
 372            (mapcar (lambda (s)
 373                      (cond
 374                        ((and (listp s) (eq (car s) 'unquote))
 375                         (list 'list (cadr s)))
 376                        ((and (listp s) (eq (car s) 'unquote-splicing))
 377                         (cadr s))
 378                        (t
 379                         (list 'list (backquote-expand-1 s)))))
 380                    form)))))
 381
 382 (defun backquote-expand (form)
 383   (if (and (listp form) (eq (car form) 'backquote))
 384       (backquote-expand-1 (cadr form))
 385       form))
 386
 387 (defmacro backquote (form)
 388   (backquote-expand-1 form))
 389
 390 (define-transformation backquote (form)
 391   (backquote-expand-1 form))
 392
 393 ;;; Primitives
 394
 395 (define-compilation + (x y)
 396   (concat "((" (ls-compile x env fenv) ") + (" (ls-compile y env fenv) "))"))
 397
 398 (define-compilation - (x y)
 399   (concat "((" (ls-compile x env fenv) ") - (" (ls-compile y env fenv) "))"))
 400
 401 (define-compilation * (x y)
 402   (concat "((" (ls-compile x env fenv) ") * (" (ls-compile y env fenv) "))"))
 403
 404 (define-compilation / (x y)
 405   (concat "((" (ls-compile x env fenv) ") / (" (ls-compile y env fenv) "))"))
 406
 407 (define-compilation < (x y)
 408   (concat "((" (ls-compile x env fenv) ") < (" (ls-compile y env fenv) "))"))
 409
 410 (define-compilation = (x y)
 411   (concat "((" (ls-compile x env fenv) ") == (" (ls-compile y env fenv) "))"))
 412
 413 (define-compilation mod (x y)
 414   (concat "((" (ls-compile x env fenv) ") % (" (ls-compile y env fenv) "))"))
 415
 416 (define-compilation floor (x)
 417   (concat "(Math.floor(" (ls-compile x env fenv) "))"))
 418
 419 (define-compilation null (x)
 420   (concat "(" (ls-compile x env fenv) "== undefined)"))
 421
 422 (define-compilation cons (x y)
 423   (concat "{car: " (ls-compile x env fenv) ", cdr: " (ls-compile y env fenv) "}"))
 424
 425 (define-compilation car (x)
 426   (concat "(" (ls-compile x env fenv) ").car"))
 427
 428 (define-compilation cdr (x)
 429   (concat "(" (ls-compile x env fenv) ").cdr"))
 430
 431 (define-compilation setcar (x new)
 432   (concat "((" (ls-compile x env fenv) ").car = " (ls-compile new env fenv) ")"))
 433
 434 (define-compilation setcdr (x new)
 435   (concat "((" (ls-compile x env fenv) ").cdr = " (ls-compile new env fenv) ")"))
 436
 437
 438 (define-compilation make-symbol (name)
 439   (concat "{name: " (ls-compile name env fenv) "}"))
 440
 441 (define-compilation symbol-name (x)
 442   (concat "(" (ls-compile x env fenv) ").name"))
 443
 444 (define-compilation eq (x y)
 445   (concat "(" (ls-compile x env fenv) " === " (ls-compile y env fenv) ")"))
 446
 447 (define-compilation string (x)
 448   (concat "String.fromCharCode(" (ls-compile x env fenv) ")"))
 449
 450 (define-compilation char (string index)
 451   (concat "("
 452           (ls-compile string env fenv)
 453           ").charCodeAt("
 454           (ls-compile index env fenv)
 455           ")"))
 456
 457 (define-compilation concat-two (string1 string2)
 458   (concat "("
 459           (ls-compile string1 env fenv)
 460           ").concat("
 461           (ls-compile string2 env fenv)
 462           ")"))
 463
 464 (define-compilation funcall (func &rest args)
 465   (concat "("
 466           (ls-compile func env fenv)
 467           ")("
 468           (join (mapcar (lambda (x)
 469                           (ls-compile x env fenv))
 470                         args)
 471                 ", ")
 472           ")"))
 473
 474 (define-compilation new ()
 475   "{}")
 476
 477 (define-compilation get (object key)
 478   (concat "(" (ls-compile object env fenv) ")[" (ls-compile key env fenv) "]"))
 479
 480 (define-compilation set (object key value)
 481   (concat "(("
 482           (ls-compile object env fenv)
 483           ")["
 484           (ls-compile key env fenv) "]"
 485           " = " (ls-compile value env fenv) ")"))
 486
 487
 488 (defun %compile-defvar (name)
 489   (unless (lookup name *env*)
 490     (push (make-var-binding name) *env*)
 491     (push (concat "var " (lookup-variable name *env*)) *toplevel-compilations*)))
 492
 493 (defun %compile-defun (name)
 494   (unless (lookup name *fenv*)
 495     (push (make-func-binding name) *fenv*)
 496     (push (concat "var " (lookup-variable name *fenv*)) *toplevel-compilations*)))
 497
 498 (defun %compile-defmacro (name lambda)
 499   (push (cons name (cons 'macro lambda)) *fenv*))
 500
 501 (defun ls-macroexpand-1 (form &optional env fenv)
 502   (let ((function (cdr (assoc (car form) *fenv*))))
 503     (if (and (listp function) (eq (car function) 'macro))
 504         (apply (eval (cdr function)) (cdr form))
 505         form)))
 506
 507 (defun compile-funcall (function args env fenv)
 508   (cond
 509     ((symbolp function)
 510      (concat (lookup-function function fenv)
 511              "("
 512              (join (mapcar (lambda (x) (ls-compile x env fenv)) args)
 513                    ", ")
 514              ")"))
 515     ((and (listp function) (eq (car function) 'lambda))
 516      (concat "(" (ls-compile function env fenv) ")("
 517              (join (mapcar (lambda (x) (ls-compile x env fenv)) args)
 518                    ", ")
 519              ")"))
 520     (t
 521      (error "Invalid function designator ~a." function))))
 522
 523 (defun ls-compile (sexp &optional env fenv)
 524   (cond
 525     ((symbolp sexp) (lookup-variable sexp env))
 526     ((integerp sexp) (integer-to-string sexp))
 527     ((stringp sexp) (concat "\"" sexp "\""))
 528     ((listp sexp)
 529      (if (assoc (car sexp) *compilations*)
 530          (let ((comp (second (assoc (car sexp) *compilations*))))
 531            (apply comp env fenv (cdr sexp)))
 532          (let ((fn (cdr (assoc (car sexp) *fenv*))))
 533            (if (and (listp fn) (eq (car fn) 'macro))
 534                (ls-compile (ls-macroexpand-1 sexp env fenv) env fenv)
 535                (compile-funcall (car sexp) (cdr sexp) env fenv)))))))
 536
 537
 538 (defun ls-compile-toplevel (sexp)
 539   (setq *toplevel-compilations* nil)
 540   (let ((code (ls-compile sexp)))
 541     (prog1
 542         (concat (join (mapcar (lambda (x) (concat x ";" *newline*))
 543                               *toplevel-compilations*)
 544                       "")
 545                 code)
 546       (setq *toplevel-compilations* nil))))
 547
 548 #+common-lisp
 549 (progn
 550
 551   (defun read-whole-file (filename)
 552     (with-open-file (in filename)
 553       (let ((seq (make-array (file-length in) :element-type 'character)))
 554         (read-sequence seq in)
 555         seq)))
 556
 557   (defun ls-compile-file (filename output)
 558     (setq *env* nil *fenv* nil)
 559     (with-open-file (out output :direction :output :if-exists :supersede)
 560       (let* ((source (read-whole-file filename))
 561              (in (make-string-stream source)))
 562         (loop
 563            for x = (ls-read in)
 564            until (eq x *eof*)
 565            for compilation = (ls-compile-toplevel x)
 566            when (plusp (length compilation))
 567            do (write-line (concat compilation "; ") out)))))
 568
 569   (defun bootstrap ()
 570     (ls-compile-file "lispstrack.lisp" "lispstrack.js")))