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