0c90bb2799c6b52c6bf116cad85566d68f21d9fe
[jscl.git] / 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)
310                           " = arguments.slice("
311                           (prin1-to-string (length required-arguments))
312                           ");"
313                           *newline*)
314                   "")
315               (concat (ls-compile-block (butlast body) new-env fenv)
316                       "return " (ls-compile (car (last body)) new-env fenv) ";")
317               *newline*
318               "})"))))
319
320 (define-compilation fsetq (var val)
321   (concat (lookup-function var fenv)
322           " = "
323           (ls-compile val env fenv)))
324
325 (define-compilation setq (var val)
326   (concat (lookup-variable var env)
327           " = "
328            (ls-compile val env fenv)))
329
330
331 ;;; Literals
332
333 (defun literal->js (sexp)
334   (cond
335     ((null sexp) "undefined")
336     ((integerp sexp) (integer-to-string sexp))
337     ((stringp sexp) (concat "\"" sexp "\""))
338     ((symbolp sexp) (concat "{name: \"" (symbol-name sexp) "\"}"))
339     ((consp sexp) (concat "{car: "
340                           (literal->js (car sexp))
341                           ", cdr: "
342                           (literal->js (cdr sexp)) "}"))))
343
344 (let ((counter 0))
345   (defun literal (form)
346     (let ((var (concat "l" (integer-to-string (incf counter)))))
347       (push (concat "var " var " = " (literal->js form)) *toplevel-compilations*)
348       var)))
349
350 (define-compilation quote (sexp)
351   (literal sexp))
352
353 (define-compilation debug (form)
354   (concat "console.log(" (ls-compile form env fenv) ")"))
355
356 (define-compilation while (pred &rest body)
357   (concat "(function(){ while("
358           (ls-compile pred env fenv)
359           "){"
360           (ls-compile-block body env fenv)
361           "}})()"))
362
363 (define-compilation function (x)
364   (cond
365     ((and (listp x) (eq (car x) 'lambda))
366      (ls-compile x env fenv))
367     ((symbolp x)
368      (lookup-function x fenv))))
369
370 #+common-lisp
371 (defmacro eval-when-compile (&body body)
372   `(eval-when (:compile-toplevel :execute)
373      ,@body))
374
375 (defvar *eval-when-compilations*)
376 (define-compilation eval-when-compile (&rest body)
377   (eval (cons 'progn body))
378   nil)
379
380 (defmacro define-transformation (name args form)
381   `(define-compilation ,name ,args
382      (ls-compile ,form env fenv)))
383
384 (define-transformation progn (&rest body)
385   `((lambda () ,@body)))
386
387 (define-transformation let (bindings &rest body)
388   `((lambda ,(mapcar 'car bindings) ,@body)
389     ,@(mapcar 'cadr bindings)))
390
391 ;;; A little backquote implementation without optimizations of any
392 ;;; kind for lispstrack.
393 (defun backquote-expand-1 (form)
394   (cond
395     ((symbolp form)
396      (list 'quote form))
397     ((atom form)
398      form)
399     ((eq (car form) 'unquote)
400      (car form))
401     ((eq (car form) 'backquote)
402      (backquote-expand-1 (backquote-expand-1 (cadr form))))
403     (t
404      (cons 'append
405            (mapcar (lambda (s)
406                      (cond
407                        ((and (listp s) (eq (car s) 'unquote))
408                         (list 'list (cadr s)))
409                        ((and (listp s) (eq (car s) 'unquote-splicing))
410                         (cadr s))
411                        (t
412                         (list 'list (backquote-expand-1 s)))))
413                    form)))))
414
415 (defun backquote-expand (form)
416   (if (and (listp form) (eq (car form) 'backquote))
417       (backquote-expand-1 (cadr form))
418       form))
419
420 (defmacro backquote (form)
421   (backquote-expand-1 form))
422
423 (define-transformation backquote (form)
424   (backquote-expand-1 form))
425
426 ;;; Primitives
427
428 (define-compilation + (x y)
429   (concat "((" (ls-compile x env fenv) ") + (" (ls-compile y env fenv) "))"))
430
431 (define-compilation - (x y)
432   (concat "((" (ls-compile x env fenv) ") - (" (ls-compile y env fenv) "))"))
433
434 (define-compilation * (x y)
435   (concat "((" (ls-compile x env fenv) ") * (" (ls-compile y env fenv) "))"))
436
437 (define-compilation / (x y)
438   (concat "((" (ls-compile x env fenv) ") / (" (ls-compile y env fenv) "))"))
439
440 (define-compilation = (x y)
441   (concat "((" (ls-compile x env fenv) ") == (" (ls-compile y env fenv) "))"))
442
443 (define-compilation null (x)
444   (concat "(" (ls-compile x env fenv) "== undefined)"))
445
446 (define-compilation cons (x y)
447   (concat "{car: " (ls-compile x env fenv) ", cdr: " (ls-compile y env fenv) "}"))
448
449 (define-compilation car (x)
450   (concat "(" (ls-compile x env fenv) ").car"))
451
452 (define-compilation cdr (x)
453   (concat "(" (ls-compile x env fenv) ").cdr"))
454
455 (define-compilation symbol-name (x)
456   (concat "(" (ls-compile x env fenv) ").name"))
457
458 (define-compilation eq (x y)
459   (concat "(" (ls-compile x env fenv) " === " (ls-compile y env fenv) ")"))
460
461 (define-compilation eql (x y)
462   (concat "(" (ls-compile x env fenv) " == " (ls-compile y env fenv) ")"))
463
464 (define-compilation code-char (x)
465   (concat "String.fromCharCode( " (ls-compile x env fenv) ")"))
466
467 (define-compilation char (string index)
468   (concat "("
469           (ls-compile string env fenv)
470           ").charCodeAt("
471           (ls-compile index env fenv)
472           ")"))
473
474 (define-compilation concat-two (string1 string2)
475   (concat "("
476           (ls-compile string1 env fenv)
477           ").concat("
478           (ls-compile string2 env fenv)
479           ")"))
480
481 (define-compilation funcall (func &rest args)
482   (concat "("
483           (ls-compile func env fenv)
484           ")("
485           (join (mapcar (lambda (x)
486                           (ls-compile x env fenv))
487                         args)
488                 ", ")
489           ")"))
490
491 (defun %compile-defvar (name)
492   (push (make-var-binding name) *env*)
493   (push (concat "var " (lookup-variable name *env*)) *toplevel-compilations*))
494
495 (defun %compile-defun (name)
496   (push (make-func-binding name) *fenv*)
497   (push (concat "var " (lookup-variable name *fenv*)) *toplevel-compilations*))
498
499 (defun %compile-defmacro (name lambda)
500   (push (cons name (cons 'macro lambda)) *fenv*))
501
502 (defun ls-macroexpand-1 (form &optional env fenv)
503   (let ((function (cdr (assoc (car form) *fenv*))))
504     (if (and (listp function) (eq (car function) 'macro))
505         (apply (eval (cdr function)) (cdr form))
506         form)))
507
508 (defun compile-funcall (function args env fenv)
509   (cond
510     ((symbolp function)
511      (concat (lookup-function function fenv)
512              "("
513              (join (mapcar (lambda (x) (ls-compile x env fenv)) args)
514                    ", ")
515              ")"))
516     ((and (listp function) (eq (car function) 'lambda))
517      (concat "(" (ls-compile function env fenv) ")("
518              (join (mapcar (lambda (x) (ls-compile x env fenv)) args)
519                    ", ")
520              ")"))
521     (t
522      (error "Invalid function designator ~a." function))))
523
524 (defun ls-compile (sexp &optional env fenv)
525   (cond
526     ((symbolp sexp) (lookup-variable sexp env))
527     ((integerp sexp) (integer-to-string sexp))
528     ((stringp sexp) (concat "\"" sexp "\""))
529     ((listp sexp)
530      (let ((sexp (ls-macroexpand-1 sexp env fenv)))
531        (let ((compiler-func (second (assoc (car sexp) *compilations*))))
532          (if compiler-func
533              (apply compiler-func env fenv (cdr sexp))
534              (compile-funcall (car sexp) (cdr sexp) env fenv)))))))
535
536 (defun ls-compile-toplevel (sexp)
537   (setq *toplevel-compilations* nil)
538   (let ((code (ls-compile sexp)))
539     (prog1
540         (concat (join (mapcar (lambda (x) (concat x ";" *newline*))
541                               *toplevel-compilations*)
542                       "")
543                 code)
544       (setq *toplevel-compilations* nil))))
545
546 #+common-lisp
547 (progn
548   (defun ls-compile-file (filename output)
549     (with-open-file (in filename)
550       (with-open-file (out output :direction :output :if-exists :supersede)
551         (loop
552            for x = (ls-read in)
553            until (eq x *eof*)
554            for compilation = (ls-compile-toplevel x)
555            when compilation do (write-line (concat compilation "; ") out)))))
556   (defun bootstrap ()
557     (ls-compile-file "lispstrack.lisp" "lispstrack.js")))