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 ;;; Some Tests comparing backquote agains the backquote of the host
 314 ;;; Lisp. It is not very exhaustive, but we just want a working
 315 ;;; backquotation to be able bootstrap this program.
 316 (macrolet ((test (form1 form2)
 317              `(assert (equal ,form1 ,form2))))
 318   (test (backquote (1 2 3 4))
 319         `(1 2 3 4))
 320   (test (backquote (1 2 (+ 3 4)))
 321         `(1 2 (+ 3 4)))
 322   (test (backquote (1 2 (unquote (+ 3 4))))
 323         `(1 2 ,(+ 3 4)))
 324   (test (backquote (1 2 (unquote-splicing '(3 4))))
 325         `(1 2 ,@'(3 4)))
 326   (test (backquote (backquote x))
 327         ``x)
 328   (let ((x 10))
 329     (test `',x
 330           (backquote (quote (unquote x)))))
 331   (let ((x 10))
 332     (test (eval ``(,,x))
 333           (eval (backquote (backquote ((unquote (unquote x)))))))))
 334
 335 (define-transformation backquote (form)
 336   (backquote-expand-1 form))
 337
 338 ;;; Primitives
 339
 340 (define-compilation + (x y)
 341   (concat "((" (ls-compile x env fenv) ") + (" (ls-compile y env fenv) "))"))
 342
 343 (define-compilation - (x y)
 344   (concat "((" (ls-compile x env fenv) ") - (" (ls-compile y env fenv) "))"))
 345
 346 (define-compilation * (x y)
 347   (concat "((" (ls-compile x env fenv) ") * (" (ls-compile y env fenv) "))"))
 348
 349 (define-compilation / (x y)
 350   (concat "((" (ls-compile x env fenv) ") / (" (ls-compile y env fenv) "))"))
 351
 352 (define-compilation = (x y)
 353   (concat "((" (ls-compile x env fenv) ") == (" (ls-compile y env fenv) "))"))
 354
 355 (define-compilation cons (x y)
 356   (concat "{car: " (ls-compile x env fenv) ", cdr: " (ls-compile y env fenv) "}"))
 357
 358 (define-compilation car (x)
 359   (concat "(" (ls-compile x env fenv) ").car"))
 360
 361 (define-compilation cdr (x)
 362   (concat "(" (ls-compile x env fenv) ").cdr"))
 363
 364 (define-compilation symbol-name (x)
 365   (concat "(" (ls-compile x env fenv) ").name"))
 366
 367 (define-compilation eq (x y)
 368   (concat "(" (ls-compile x env fenv) " === " (ls-compile y env fenv) ")"))
 369
 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     (format nil "var ~a" (lookup-variable name *env*))))
 380
 381 (defun %compile-defun (name)
 382   (push (make-func-binding name) *fenv*)
 383   (with-eval-when-compilation
 384     (format nil "var ~a" (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      (format nil "~a(~{~a~^, ~})"
 399              (lookup-function function fenv)
 400              (mapcar (lambda (x) (ls-compile x env fenv)) args)))
 401     ((and (listp function) (eq (car function) 'lambda))
 402      (format nil "(~a)(~{~a~^, ~})"
 403              (ls-compile function env fenv)
 404              (mapcar (lambda (x) (ls-compile x env fenv)) args)))
 405     (t
 406      (error "Invalid function designator ~a." function))))
 407
 408 (defun ls-compile (sexp &optional env fenv)
 409   (cond
 410     ((symbolp sexp) (lookup-variable sexp env))
 411     ((integerp sexp) (format nil "~a" sexp))
 412     ((stringp sexp) (format nil "\"~a\"" sexp))
 413     ((listp sexp)
 414      (let ((sexp (ls-macroexpand-1 sexp env fenv)))
 415        (let ((compiler-func (second (assoc (car sexp) *compilations*))))
 416          (if compiler-func
 417              (apply compiler-func env fenv (cdr sexp))
 418              (compile-funcall (car sexp) (cdr sexp) env fenv)))))))
 419
 420 (defun ls-compile-toplevel (sexp)
 421   (setq *literals* nil)
 422   (let ((code (ls-compile sexp)))
 423     (prog1
 424         (concat (join (mapcar (lambda (lit)
 425                                 (concat "var " (car lit) " = " (cdr lit) ";
 426 "))
 427                               *literals*)
 428                       "")
 429                 code)
 430       (setq *literals* nil))))
 431
 432 (defun ls-compile-file (filename output)
 433   (with-open-file (in filename)
 434     (with-open-file (out output :direction :output :if-exists :supersede)
 435       (loop
 436          for x = (ls-read in)
 437          until (eq x *eof*)
 438          for compilation = (ls-compile-toplevel x)
 439          when compilation do (write-line (concat compilation "; ") out)))))
 440
 441
 442 ;;; Testing
 443 (defun compile-test ()
 444   (ls-compile-file "test.lisp" "test.js"))