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