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   (if (null list)
  41       ""
  42       (concat (car list) separator (join-trailing (cdr list) separator))))
  43
  44 (defun integer-to-string (x)
  45   (if (zerop x)
  46       "0"
  47       (let ((digits nil))
  48         (while (not (= x 0))
  49           (push (mod x 10) digits)
  50           (setq x (truncate x 10)))
  51         (join (mapcar (lambda (d) (string (char "0123456789" d)))
  52                       digits)
  53               ""))))
  54
  55 ;;;; Reader
  56
  57 ;;; It is a basic Lisp reader. It does not use advanced stuff
  58 ;;; intentionally, because we want to use it to bootstrap a simple
  59 ;;; Lisp. The main entry point is the function `ls-read', which
  60 ;;; accepts a strings as argument and return the Lisp expression.
  61 (defun make-string-stream (string)
  62   (cons string 0))
  63
  64 (defun %peek-char (stream)
  65   (if (streamp stream)
  66       (peek-char nil stream nil)
  67       (and (< (cdr stream) (length (car stream)))
  68            (char (car stream) (cdr stream)))))
  69
  70 (defun %read-char (stream)
  71   (if (streamp stream)
  72       (read-char stream nil)
  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 (mapcar (lambda (x)
 189                            (ls-compile x env fenv))
 190                          sexps)
 191                  ";
 192 "))
 193
 194 (defun extend-env (args env)
 195   (append (mapcar #'make-var-binding args) env))
 196
 197 (defparameter *env* '())
 198 (defparameter *fenv* '())
 199
 200 (defun lookup (symbol env)
 201   (let ((binding (assoc symbol env)))
 202     (and binding (cdr binding))))
 203
 204 (defun lookup-variable (symbol env)
 205   (or (lookup symbol env)
 206       (lookup symbol *env*)
 207       (error "Undefined variable `~a'"  symbol)))
 208
 209 (defun lookup-function (symbol env)
 210   (or (lookup symbol env)
 211       (lookup symbol *fenv*)
 212       (error "Undefined function `~a'"  symbol)))
 213
 214 (defmacro define-compilation (name args &body body)
 215   ;; Creates a new primitive `name' with parameters args and
 216   ;; @body. The body can access to the local environment through the
 217   ;; variable ENV.
 218   `(push (list ',name (lambda (env fenv ,@args) ,@body))
 219          *compilations*))
 220
 221 (defvar *toplevel-compilations*)
 222
 223 (define-compilation if (condition true false)
 224   (concat "("
 225           (ls-compile condition env fenv) " == undefined"
 226           " ? "
 227           (ls-compile true env fenv)
 228           " : "
 229           (ls-compile false env fenv)
 230           ")"))
 231
 232 ;;; Return the required args of a lambda list
 233 (defun lambda-list-required-argument (lambda-list)
 234   (if (or (null lambda-list) (eq (car lambda-list) '&rest))
 235       nil
 236       (cons (car lambda-list) (lambda-list-required-argument (cdr lambda-list)))))
 237
 238 (defun lambda-list-rest-argument (lambda-list)
 239   (second (member '&rest lambda-list)))
 240
 241 (define-compilation lambda (lambda-list &rest body)
 242   (let ((required-arguments (lambda-list-required-argument lambda-list))
 243         (rest-argument (lambda-list-rest-argument lambda-list)))
 244     (let ((new-env (extend-env (append (if rest-argument (list rest-argument))
 245                                        required-arguments)
 246                                env)))
 247       (concat "(function ("
 248               (join (mapcar (lambda (x) (lookup-variable x new-env))
 249                             required-arguments)
 250                     ",")
 251               "){"
 252               *newline*
 253               (if rest-argument
 254                   (concat "var " (lookup-variable rest-argument new-env) ";" *newline*
 255                           "for (var i = arguments.length-1; i>="
 256                           (integer-to-string (length required-arguments))
 257                           "; i--)" *newline*
 258                           (lookup-variable rest-argument new-env) " = "
 259                           "{car: arguments[i], cdr: " (lookup-variable rest-argument new-env) "};"
 260                           *newline*)
 261                   "")
 262               (concat (ls-compile-block (butlast body) new-env fenv)
 263                       "return " (ls-compile (car (last body)) new-env fenv) ";")
 264               *newline*
 265               "})"))))
 266
 267 (define-compilation fsetq (var val)
 268   (concat (lookup-function var fenv)
 269           " = "
 270           (ls-compile val env fenv)))
 271
 272 (define-compilation setq (var val)
 273   (concat (lookup-variable var env)
 274           " = "
 275            (ls-compile val env fenv)))
 276
 277
 278 ;;; Literals
 279
 280 (defun literal->js (sexp)
 281   (cond
 282     ((null sexp) "unspecified")
 283     ((integerp sexp) (integer-to-string sexp))
 284     ((stringp sexp) (concat "\"" sexp "\""))
 285     ((symbolp sexp) (concat "{name: \"" (symbol-name sexp) "\"}"))
 286     ((consp sexp) (concat "{car: "
 287                           (literal->js (car sexp))
 288                           ", cdr: "
 289                           (literal->js (cdr sexp)) "}"))))
 290
 291 (let ((counter 0))
 292   (defun literal (form)
 293     (if (null form)
 294         (literal->js form)
 295         (let ((var (concat "l" (integer-to-string (incf counter)))))
 296           (push (concat "var " var " = " (literal->js form)) *toplevel-compilations*)
 297           var))))
 298
 299 (define-compilation quote (sexp)
 300   (literal sexp))
 301
 302 (define-compilation debug (form)
 303   (concat "console.log(" (ls-compile form env fenv) ")"))
 304
 305 (define-compilation while (pred &rest body)
 306   (concat "(function(){ while("
 307           (ls-compile pred env fenv)
 308           "){"
 309           (ls-compile-block body env fenv)
 310           "}})()"))
 311
 312 (define-compilation function (x)
 313   (cond
 314     ((and (listp x) (eq (car x) 'lambda))
 315      (ls-compile x env fenv))
 316     ((symbolp x)
 317      (lookup-function x fenv))))
 318
 319 #+common-lisp
 320 (defmacro eval-when-compile (&body body)
 321   `(eval-when (:compile-toplevel :load-toplevel :execute)
 322      ,@body))
 323
 324 (define-compilation eval-when-compile (&rest body)
 325   (eval (cons 'progn body))
 326   nil)
 327
 328 (defmacro define-transformation (name args form)
 329   `(define-compilation ,name ,args
 330      (ls-compile ,form env fenv)))
 331
 332 (define-transformation progn (&rest body)
 333   `((lambda () ,@body)))
 334
 335 (define-transformation let (bindings &rest body)
 336   `((lambda ,(mapcar 'car bindings) ,@body)
 337     ,@(mapcar 'cadr bindings)))
 338
 339 ;;; A little backquote implementation without optimizations of any
 340 ;;; kind for lispstrack.
 341 (defun backquote-expand-1 (form)
 342   (cond
 343     ((symbolp form)
 344      (list 'quote form))
 345     ((atom form)
 346      form)
 347     ((eq (car form) 'unquote)
 348      (car form))
 349     ((eq (car form) 'backquote)
 350      (backquote-expand-1 (backquote-expand-1 (cadr form))))
 351     (t
 352      (cons 'append
 353            (mapcar (lambda (s)
 354                      (cond
 355                        ((and (listp s) (eq (car s) 'unquote))
 356                         (list 'list (cadr s)))
 357                        ((and (listp s) (eq (car s) 'unquote-splicing))
 358                         (cadr s))
 359                        (t
 360                         (list 'list (backquote-expand-1 s)))))
 361                    form)))))
 362
 363 (defun backquote-expand (form)
 364   (if (and (listp form) (eq (car form) 'backquote))
 365       (backquote-expand-1 (cadr form))
 366       form))
 367
 368 (defmacro backquote (form)
 369   (backquote-expand-1 form))
 370
 371 (define-transformation backquote (form)
 372   (backquote-expand-1 form))
 373
 374 ;;; Primitives
 375
 376 (define-compilation + (x y)
 377   (concat "((" (ls-compile x env fenv) ") + (" (ls-compile y env fenv) "))"))
 378
 379 (define-compilation - (x y)
 380   (concat "((" (ls-compile x env fenv) ") - (" (ls-compile y env fenv) "))"))
 381
 382 (define-compilation * (x y)
 383   (concat "((" (ls-compile x env fenv) ") * (" (ls-compile y env fenv) "))"))
 384
 385 (define-compilation / (x y)
 386   (concat "((" (ls-compile x env fenv) ") / (" (ls-compile y env fenv) "))"))
 387
 388 (define-compilation = (x y)
 389   (concat "((" (ls-compile x env fenv) ") == (" (ls-compile y env fenv) "))"))
 390
 391 (define-compilation mod (x y)
 392   (concat "((" (ls-compile x env fenv) ") % (" (ls-compile y env fenv) "))"))
 393
 394 (define-compilation floor (x)
 395   (concat "(Math.floor(" (ls-compile x env fenv) "))"))
 396
 397 (define-compilation null (x)
 398   (concat "(" (ls-compile x env fenv) "== undefined)"))
 399
 400 (define-compilation cons (x y)
 401   (concat "{car: " (ls-compile x env fenv) ", cdr: " (ls-compile y env fenv) "}"))
 402
 403 (define-compilation car (x)
 404   (concat "(" (ls-compile x env fenv) ").car"))
 405
 406 (define-compilation cdr (x)
 407   (concat "(" (ls-compile x env fenv) ").cdr"))
 408
 409 (define-compilation make-symbol (name)
 410   (concat "{name: " (ls-compile name env fenv) "}"))
 411
 412 (define-compilation symbol-name (x)
 413   (concat "(" (ls-compile x env fenv) ").name"))
 414
 415 (define-compilation eq (x y)
 416   (concat "(" (ls-compile x env fenv) " === " (ls-compile y env fenv) ")"))
 417
 418 (define-compilation string (x)
 419   (concat "String.fromCharCode( " (ls-compile x env fenv) ")"))
 420
 421 (define-compilation char (string index)
 422   (concat "("
 423           (ls-compile string env fenv)
 424           ").charCodeAt("
 425           (ls-compile index env fenv)
 426           ")"))
 427
 428 (define-compilation concat-two (string1 string2)
 429   (concat "("
 430           (ls-compile string1 env fenv)
 431           ").concat("
 432           (ls-compile string2 env fenv)
 433           ")"))
 434
 435 (define-compilation funcall (func &rest args)
 436   (concat "("
 437           (ls-compile func env fenv)
 438           ")("
 439           (join (mapcar (lambda (x)
 440                           (ls-compile x env fenv))
 441                         args)
 442                 ", ")
 443           ")"))
 444
 445 (define-compilation new ()
 446   "{}")
 447
 448 (define-compilation get (object key)
 449   (concat "(" (ls-compile object env fenv) ")[" (ls-compile key env fenv) "]"))
 450
 451 (define-compilation set (object key value)
 452   (concat "(("
 453           (ls-compile object env fenv)
 454           ")["
 455           (ls-compile key env fenv) "]"
 456           " = " (ls-compile value env fenv) ")"))
 457
 458
 459 (defun %compile-defvar (name)
 460   (unless (lookup name *env*)
 461     (push (make-var-binding name) *env*)
 462     (push (concat "var " (lookup-variable name *env*)) *toplevel-compilations*)))
 463
 464 (defun %compile-defun (name)
 465   (unless (lookup name *fenv*)
 466     (push (make-func-binding name) *fenv*)
 467     (push (concat "var " (lookup-variable name *fenv*)) *toplevel-compilations*)))
 468
 469 (defun %compile-defmacro (name lambda)
 470   (push (cons name (cons 'macro lambda)) *fenv*))
 471
 472 (defun ls-macroexpand-1 (form &optional env fenv)
 473   (let ((function (cdr (assoc (car form) *fenv*))))
 474     (if (and (listp function) (eq (car function) 'macro))
 475         (apply (eval (cdr function)) (cdr form))
 476         form)))
 477
 478 (defun compile-funcall (function args env fenv)
 479   (cond
 480     ((symbolp function)
 481      (concat (lookup-function function fenv)
 482              "("
 483              (join (mapcar (lambda (x) (ls-compile x env fenv)) args)
 484                    ", ")
 485              ")"))
 486     ((and (listp function) (eq (car function) 'lambda))
 487      (concat "(" (ls-compile function env fenv) ")("
 488              (join (mapcar (lambda (x) (ls-compile x env fenv)) args)
 489                    ", ")
 490              ")"))
 491     (t
 492      (error "Invalid function designator ~a." function))))
 493
 494 (defun ls-compile (sexp &optional env fenv)
 495   (cond
 496     ((symbolp sexp) (lookup-variable sexp env))
 497     ((integerp sexp) (integer-to-string sexp))
 498     ((stringp sexp) (concat "\"" sexp "\""))
 499     ((listp sexp)
 500      (let ((sexp (ls-macroexpand-1 sexp env fenv)))
 501        (let ((compiler-func (second (assoc (car sexp) *compilations*))))
 502          (if compiler-func
 503              (apply compiler-func env fenv (cdr sexp))
 504              (compile-funcall (car sexp) (cdr sexp) env fenv)))))))
 505
 506 (defun ls-compile-toplevel (sexp)
 507   (setq *toplevel-compilations* nil)
 508   (let ((code (ls-compile sexp)))
 509     (prog1
 510         (concat (join (mapcar (lambda (x) (concat x ";" *newline*))
 511                               *toplevel-compilations*)
 512                       "")
 513                 code)
 514       (setq *toplevel-compilations* nil))))
 515
 516 #+common-lisp
 517 (progn
 518   (defun ls-compile-file (filename output)
 519     (with-open-file (in filename)
 520       (with-open-file (out output :direction :output :if-exists :supersede)
 521         (loop
 522            for x = (ls-read in)
 523            until (eq x *eof*)
 524            for compilation = (ls-compile-toplevel x)
 525            when compilation do (write-line (concat compilation "; ") out)))))
 526   (defun bootstrap ()
 527     (ls-compile-file "lispstrack.lisp" "lispstrack.js")))