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