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