lispstrack.lisp

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