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