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