lispstrack.lisp

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