lispstrack.lisp

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