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