lispstrack.lisp

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