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