lispstrack.lisp

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