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