lispstrack.lisp

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