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 (defvar *toplevel-compilations*)
 205
 206 (define-compilation if (condition true false)
 207   (concat "("
 208           (ls-compile condition env fenv)
 209           " ? "
 210           (ls-compile true env fenv)
 211           " : "
 212           (ls-compile false env fenv)
 213           ")"))
 214
 215 ;;; Return the required args of a lambda list
 216 (defun lambda-list-required-argument (lambda-list)
 217   (if (or (null lambda-list) (eq (car lambda-list) '&rest))
 218       nil
 219       (cons (car lambda-list) (lambda-list-required-argument (cdr lambda-list)))))
 220
 221 (defun lambda-list-rest-argument (lambda-list)
 222   (second (member '&rest lambda-list)))
 223
 224 (define-compilation lambda (lambda-list &rest body)
 225   (let ((required-arguments (lambda-list-required-argument lambda-list))
 226         (rest-argument (lambda-list-rest-argument lambda-list)))
 227     (let ((new-env (extend-env (cons rest-argument required-arguments) env)))
 228       (concat "(function ("
 229               (join (mapcar (lambda (x) (lookup-variable x new-env))
 230                             required-arguments)
 231                     ",")
 232               "){
 233 "
 234               (if rest-argument
 235                   (concat "var " (lookup-variable rest-argument new-env)
 236                           " = arguments.slice("
 237                           (prin1-to-string (length required-arguments)) ");
 238 ")
 239                   "")
 240
 241               (concat (ls-compile-block (butlast body) new-env fenv)
 242                       "return " (ls-compile (car (last body)) new-env fenv) ";")
 243               "
 244 })"))))
 245
 246 (define-compilation fsetq (var val)
 247   (concat (lookup-function var fenv)
 248           " = "
 249           (ls-compile val env fenv)))
 250
 251 (define-compilation setq (var val)
 252   (concat (lookup-variable var env)
 253           " = "
 254            (ls-compile val env fenv)))
 255
 256
 257 ;;; 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 (concat "var " var " = " (literal->js form)) *toplevel-compilations*)
 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   (eval (cons 'progn body))
 303   nil)
 304
 305 (defmacro define-transformation (name args form)
 306   `(define-compilation ,name ,args
 307      (ls-compile ,form env fenv)))
 308
 309 (define-transformation progn (&rest body)
 310   `((lambda () ,@body)))
 311
 312 (define-transformation let (bindings &rest body)
 313   `((lambda ,(mapcar 'car bindings) ,@body)
 314     ,@(mapcar 'cadr bindings)))
 315
 316 ;;; A little backquote implementation without optimizations of any
 317 ;;; kind for lispstrack.
 318 (defun backquote-expand-1 (form)
 319   (cond
 320     ((symbolp form)
 321      (list 'quote form))
 322     ((atom form)
 323      form)
 324     ((eq (car form) 'unquote)
 325      (car form))
 326     ((eq (car form) 'backquote)
 327      (backquote-expand-1 (backquote-expand-1 (cadr form))))
 328     (t
 329      (cons 'append
 330            (mapcar (lambda (s)
 331                      (cond
 332                        ((and (listp s) (eq (car s) 'unquote))
 333                         (list 'list (cadr s)))
 334                        ((and (listp s) (eq (car s) 'unquote-splicing))
 335                         (cadr s))
 336                        (t
 337                         (list 'list (backquote-expand-1 s)))))
 338                    form)))))
 339
 340 (defun backquote-expand (form)
 341   (if (and (listp form) (eq (car form) 'backquote))
 342       (backquote-expand-1 (cadr form))
 343       form))
 344
 345 (define-transformation backquote (form)
 346   (backquote-expand-1 form))
 347
 348 ;;; Primitives
 349
 350 (define-compilation + (x y)
 351   (concat "((" (ls-compile x env fenv) ") + (" (ls-compile y env fenv) "))"))
 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 cons (x y)
 366   (concat "{car: " (ls-compile x env fenv) ", cdr: " (ls-compile y env fenv) "}"))
 367
 368 (define-compilation car (x)
 369   (concat "(" (ls-compile x env fenv) ").car"))
 370
 371 (define-compilation cdr (x)
 372   (concat "(" (ls-compile x env fenv) ").cdr"))
 373
 374 (define-compilation symbol-name (x)
 375   (concat "(" (ls-compile x env fenv) ").name"))
 376
 377 (define-compilation eq (x y)
 378   (concat "(" (ls-compile x env fenv) " === " (ls-compile y env fenv) ")"))
 379
 380 (define-compilation code-char (x)
 381   (concat "String.fromCharCode( " (ls-compile x env fenv) ")"))
 382
 383 (defun %compile-defvar (name)
 384   (push (make-var-binding name) *env*)
 385   (push (concat "var " (lookup-variable name *env*)) *toplevel-compilations*))
 386
 387 (defun %compile-defun (name)
 388   (push (make-func-binding name) *fenv*)
 389   (push (concat "var " (lookup-variable name *fenv*)) *toplevel-compilations*))
 390
 391 (defun %compile-defmacro (name lambda)
 392   (push (cons name (cons 'macro lambda)) *fenv*))
 393
 394 (defun ls-macroexpand-1 (form &optional env fenv)
 395   (let ((function (cdr (assoc (car form) *fenv*))))
 396     (if (and (listp function) (eq (car function) 'macro))
 397         (apply (eval (cdr function)) (cdr form))
 398         form)))
 399
 400 (defun compile-funcall (function args env fenv)
 401   (cond
 402     ((symbolp function)
 403      (concat (lookup-function function fenv)
 404              "("
 405              (join (mapcar (lambda (x) (ls-compile x env fenv)) args)
 406                    ", ")
 407              ")"))
 408     ((and (listp function) (eq (car function) 'lambda))
 409      (concat "(" (ls-compile function env fenv) ")("
 410              (join (mapcar (lambda (x) (ls-compile x env fenv)) args)
 411                    ", ")
 412              ")"))
 413     (t
 414      (error "Invalid function designator ~a." function))))
 415
 416 (defun ls-compile (sexp &optional env fenv)
 417   (cond
 418     ((symbolp sexp) (lookup-variable sexp env))
 419     ((integerp sexp) (integer-to-string sexp))
 420     ((stringp sexp) (concat "\"" sexp "\""))
 421     ((listp sexp)
 422      (let ((sexp (ls-macroexpand-1 sexp env fenv)))
 423        (let ((compiler-func (second (assoc (car sexp) *compilations*))))
 424          (if compiler-func
 425              (apply compiler-func env fenv (cdr sexp))
 426              (compile-funcall (car sexp) (cdr sexp) env fenv)))))))
 427
 428 (defun ls-compile-toplevel (sexp)
 429   (setq *toplevel-compilations* nil)
 430   (let ((code (ls-compile sexp)))
 431     (prog1
 432         (concat (join (mapcar (lambda (x)(concat x ";
 433 "))
 434                               *toplevel-compilations*)
 435                       "")
 436                 code)
 437       (setq *toplevel-compilations* nil))))
 438
 439 #+common-lisp
 440 (defun ls-compile-file (filename output)
 441   (with-open-file (in filename)
 442     (with-open-file (out output :direction :output :if-exists :supersede)
 443       (loop
 444          for x = (ls-read in)
 445          until (eq x *eof*)
 446          for compilation = (ls-compile-toplevel x)
 447          when compilation do (write-line (concat compilation "; ") out)))))
 448
 449 ;;; Testing
 450 (defun compile-test ()
 451   (ls-compile-file "test.lisp" "test.js"))