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