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