lispstrack.lisp

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