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