lispstrack.lisp

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