Fix bug in string escape
[jscl.git] / lispstrack.lisp
1 (defun ensure-list (x)
2   (if (listp x)
3       x
4       (list x)))
5
6 (defun !reduce (func list initial)
7   (if (null list)
8       initial
9       (!reduce func
10                (cdr list)
11                (funcall func initial (car list)))))
12
13 ;;; Utils
14
15 #+common-lisp
16 (progn
17   (defmacro while (condition &body body)
18     `(do ()
19          ((not ,condition))
20        ,@body))
21
22   (defun concat-two (s1 s2)
23     (concatenate 'string s1 s2))
24
25   (defun setcar (cons new)
26     (setf (car cons) new))
27   (defun setcdr (cons new)
28     (setf (cdr cons) new)))
29
30 (defvar *newline* (string (code-char 10)))
31
32 (defun concat (&rest strs)
33   (!reduce (lambda (s1 s2) (concat-two s1 s2))
34            strs
35            ""))
36
37 ;;; Concatenate a list of strings, with a separator
38 (defun join (list separator)
39   (cond
40     ((null list)
41      "")
42     ((null (cdr list))
43      (car list))
44     (t
45      (concat (car list)
46              separator
47              (join (cdr list) separator)))))
48
49 (defun join-trailing (list separator)
50   (cond
51     ((null list)
52      "")
53     ((null (car list))
54      (join-trailing (cdr list) separator))
55     (t
56      (concat (car list) separator (join-trailing (cdr list) separator)))))
57
58 (defun integer-to-string (x)
59   (if (zerop x)
60       "0"
61       (let ((digits nil))
62         (while (not (= x 0))
63           (push (mod x 10) digits)
64           (setq x (truncate x 10)))
65         (join (mapcar (lambda (d) (string (char "0123456789" d)))
66                       digits)
67               ""))))
68
69 ;;;; Reader
70
71 ;;; It is a basic Lisp reader. It does not use advanced stuff
72 ;;; intentionally, because we want to use it to bootstrap a simple
73 ;;; Lisp. The main entry point is the function `ls-read', which
74 ;;; accepts a strings as argument and return the Lisp expression.
75 (defun make-string-stream (string)
76   (cons string 0))
77
78 (defun %peek-char (stream)
79   (and (< (cdr stream) (length (car stream)))
80        (char (car stream) (cdr stream))))
81
82 (defun %read-char (stream)
83   (and (< (cdr stream) (length (car stream)))
84        (prog1 (char (car stream) (cdr stream))
85          (setcdr stream (1+ (cdr stream))))))
86
87 (defun whitespacep (ch)
88   (or (char= ch #\space) (char= ch #\newline) (char= ch #\tab)))
89
90 (defun skip-whitespaces (stream)
91   (let (ch)
92     (setq ch (%peek-char stream))
93     (while (and ch (whitespacep ch))
94       (%read-char stream)
95       (setq ch (%peek-char stream)))))
96
97 (defun terminalp (ch)
98   (or (null ch) (whitespacep ch) (char= #\) ch) (char= #\( ch)))
99
100 (defun read-until (stream func)
101   (let ((string "")
102         (ch))
103     (setq ch (%peek-char stream))
104     (while (not (funcall func ch))
105       (setq string (concat string (string ch)))
106       (%read-char stream)
107       (setq ch (%peek-char stream)))
108     string))
109
110 (defun skip-whitespaces-and-comments (stream)
111   (let (ch)
112     (skip-whitespaces stream)
113     (setq ch (%peek-char stream))
114     (while (and ch (char= ch #\;))
115       (read-until stream (lambda (x) (char= x #\newline)))
116       (skip-whitespaces stream)
117       (setq ch (%peek-char stream)))))
118
119 (defun %read-list (stream)
120   (skip-whitespaces-and-comments stream)
121   (let ((ch (%peek-char stream)))
122     (cond
123       ((char= ch #\))
124        (%read-char stream)
125        nil)
126       ((char= ch #\.)
127        (%read-char stream)
128        (skip-whitespaces-and-comments stream)
129        (prog1 (ls-read stream)
130          (unless (char= (%read-char stream) #\))
131            (error "')' was expected."))))
132       (t
133        (cons (ls-read stream) (%read-list stream))))))
134
135 (defun read-string (stream)
136   (let ((string "")
137         (ch nil))
138     (setq ch (%read-char stream))
139     (while (not (char= ch #\"))
140       (when (char= ch #\\)
141         (setq ch (%read-char stream)))
142       (setq string (concat string (string ch)))
143       (setq ch (%read-char stream)))
144     string))
145
146 (defvar *eof* (make-symbol "EOF"))
147 (defun ls-read (stream)
148   (skip-whitespaces-and-comments stream)
149   (let ((ch (%peek-char stream)))
150     (cond
151       ((null ch)
152        *eof*)
153       ((char= ch #\()
154        (%read-char stream)
155        (%read-list stream))
156       ((char= ch #\')
157        (%read-char stream)
158        (list 'quote (ls-read stream)))
159       ((char= ch #\`)
160        (%read-char stream)
161        (list 'backquote (ls-read stream)))
162       ((char= ch #\")
163        (%read-char stream)
164        (read-string stream))
165       ((char= ch #\,)
166        (%read-char stream)
167        (if (eql (%peek-char stream) #\@)
168            (progn (%read-char stream) (list 'unquote-splicing (ls-read stream)))
169            (list 'unquote (ls-read stream))))
170       ((char= ch #\#)
171        (%read-char stream)
172        (ecase (%read-char stream)
173          (#\'
174           (list 'function (ls-read stream)))
175          (#\\
176           (let ((cname
177                  (concat (string (%read-char stream))
178                          (read-until stream #'terminalp))))
179             (cond
180               ((string= cname "space") (char-code #\space))
181               ((string= cname "newline") (char-code #\newline))
182               (t (char-code (char cname 0))))))
183          (#\+
184           (let ((feature (read-until stream #'terminalp)))
185             (cond
186               ((string= feature "common-lisp")
187                (ls-read stream)         ;ignore
188                (ls-read stream))
189               ((string= feature "lispstrack")
190                (ls-read stream))
191               (t
192                (error "Unknown reader form.")))))))
193       (t
194        (let ((string (read-until stream #'terminalp)))
195          (if (every #'digit-char-p string)
196              (parse-integer string)
197              (intern (string-upcase string))))))))
198
199 (defun ls-read-from-string (string)
200   (ls-read (make-string-stream string)))
201
202
203 ;;;; Compiler
204
205 (defvar *compilation-unit-checks* '())
206
207 (defvar *env* '())
208 (defvar *fenv* '())
209
210 (defun make-binding (name type js declared)
211   (list name type js declared))
212
213 (defun binding-name (b) (first b))
214 (defun binding-type (b) (second b))
215 (defun binding-translation (b) (third b))
216 (defun binding-declared (b)
217   (and b (fourth b)))
218 (defun mark-binding-as-declared (b)
219   (setcar (cdddr b) t))
220
221 (let ((counter 0))
222   (defun gvarname (symbol)
223     (concat "v" (integer-to-string (incf counter))))
224
225   (defun lookup-variable (symbol env)
226     (or (assoc symbol env)
227         (assoc symbol *env*)
228         (let ((name (symbol-name symbol))
229               (binding (make-binding symbol 'variable (gvarname symbol) nil)))
230           (push binding *env*)
231           (push (lambda ()
232                   (unless (binding-declared (assoc symbol *env*))
233                     (error (concat "Undefined variable `" name "'"))))
234                 *compilation-unit-checks*)
235           binding)))
236
237   (defun lookup-variable-translation (symbol env)
238     (binding-translation (lookup-variable symbol env)))
239
240   (defun extend-local-env (args env)
241     (append (mapcar (lambda (symbol)
242                       (make-binding symbol 'variable (gvarname symbol) t))
243                     args)
244             env)))
245
246 (let ((counter 0))
247   (defun lookup-function (symbol env)
248     (or (assoc symbol env)
249         (assoc symbol *fenv*)
250         (let ((name (symbol-name symbol))
251               (binding
252                (make-binding symbol
253                              'function
254                              (concat "f" (integer-to-string (incf counter)))
255                              nil)))
256           (push binding *fenv*)
257           (push (lambda ()
258                   (unless (binding-declared (assoc symbol *fenv*))
259                     (error (concat "Undefined function `" name "'"))))
260                 *compilation-unit-checks*)
261           binding)))
262
263   (defun lookup-function-translation (symbol env)
264     (binding-translation (lookup-function symbol env))))
265
266
267 (defvar *toplevel-compilations* nil)
268
269 (defun %compile-defvar (name)
270   (let ((b (lookup-variable name *env*)))
271     (mark-binding-as-declared b)
272     (push (concat "var " (binding-translation b)) *toplevel-compilations*)))
273
274 (defun %compile-defun (name)
275   (let ((b (lookup-function name *env*)))
276     (mark-binding-as-declared b)
277     (push (concat "var " (binding-translation b)) *toplevel-compilations*)))
278
279 (defun %compile-defmacro (name lambda)
280   (push (make-binding name 'macro lambda t) *fenv*))
281
282
283 (defvar *compilations* nil)
284
285 (defun ls-compile-block (sexps env fenv)
286   (join-trailing
287    (remove nil (mapcar (lambda (x)
288                          (ls-compile x env fenv))
289                        sexps))
290                  ";
291 "))
292 (defmacro define-compilation (name args &rest body)
293   ;; Creates a new primitive `name' with parameters args and
294   ;; @body. The body can access to the local environment through the
295   ;; variable ENV.
296   `(push (list ',name (lambda (env fenv ,@args) ,@body))
297          *compilations*))
298
299 (define-compilation if (condition true false)
300   (concat "("
301           (ls-compile condition env fenv)
302           " ? "
303           (ls-compile true env fenv)
304           " : "
305           (ls-compile false env fenv)
306           ")"))
307
308 ;;; Return the required args of a lambda list
309 (defun lambda-list-required-argument (lambda-list)
310   (if (or (null lambda-list) (eq (car lambda-list) '&rest))
311       nil
312       (cons (car lambda-list) (lambda-list-required-argument (cdr lambda-list)))))
313
314 (defun lambda-list-rest-argument (lambda-list)
315   (second (member '&rest lambda-list)))
316
317 (define-compilation lambda (lambda-list &rest body)
318   (let ((required-arguments (lambda-list-required-argument lambda-list))
319         (rest-argument (lambda-list-rest-argument lambda-list)))
320     (let ((new-env (extend-local-env
321                     (append (and rest-argument (list rest-argument))
322                             required-arguments)
323                     env)))
324       (concat "(function ("
325               (join (mapcar (lambda (x)
326                               (lookup-variable-translation x new-env))
327                             required-arguments)
328                     ",")
329               "){"
330               *newline*
331               (if rest-argument
332                   (let ((js!rest (lookup-variable-translation rest-argument new-env)))
333                     (concat "var " js!rest ";" *newline*
334                             "for (var i = arguments.length-1; i>="
335                             (integer-to-string (length required-arguments))
336                             "; i--)" *newline*
337                             js!rest " = "
338                             "{car: arguments[i], cdr: " js!rest "};"
339                             *newline*))
340                   "")
341               (concat (ls-compile-block (butlast body) new-env fenv)
342                       "return " (ls-compile (car (last body)) new-env fenv) ";")
343               *newline*
344               "})"))))
345
346 (define-compilation fsetq (var val)
347   (concat (lookup-function-translation var fenv)
348           " = "
349           (ls-compile val env fenv)))
350
351 (define-compilation setq (var val)
352   (concat (lookup-variable-translation var env)
353           " = "
354            (ls-compile val env fenv)))
355
356 ;;; Literals
357
358 (defun escape-string (string)
359   (let ((output "")
360         (index 0)
361         (size (length string)))
362     (while (< index size)
363       (let ((ch (char string index)))
364         (when (or (char= ch #\") (char= ch #\\))
365           (setq output (concat output "\\")))
366         (setq output (concat output (string ch))))
367       (incf index))
368     output))
369
370 (defun literal->js (sexp)
371   (cond
372     ((null sexp) "false")
373     ((integerp sexp) (integer-to-string sexp))
374     ((stringp sexp) (concat "\"" (escape-string sexp) "\""))
375     ((symbolp sexp) (concat "{name: \"" (escape-string (symbol-name sexp)) "\"}"))
376     ((consp sexp) (concat "{car: "
377                           (literal->js (car sexp))
378                           ", cdr: "
379                           (literal->js (cdr sexp)) "}"))))
380
381 (let ((counter 0))
382   (defun literal (form)
383     (if (null form)
384         (literal->js form)
385         (let ((var (concat "l" (integer-to-string (incf counter)))))
386           (push (concat "var " var " = " (literal->js form)) *toplevel-compilations*)
387           var))))
388
389 (define-compilation quote (sexp)
390   (literal sexp))
391
392 (define-compilation debug (form)
393   (concat "console.log(" (ls-compile form env fenv) ")"))
394
395 (define-compilation while (pred &rest body)
396   (concat "(function(){ while("
397           (ls-compile pred env fenv)
398           "){"
399           (ls-compile-block body env fenv)
400           "}})()"))
401
402 (define-compilation function (x)
403   (cond
404     ((and (listp x) (eq (car x) 'lambda))
405      (ls-compile x env fenv))
406     ((symbolp x)
407      (lookup-function-translation x fenv))))
408
409 #+common-lisp
410 (defmacro eval-when-compile (&body body)
411   `(eval-when (:compile-toplevel :load-toplevel :execute)
412      ,@body))
413
414 (define-compilation eval-when-compile (&rest body)
415   (eval (cons 'progn body))
416   nil)
417
418 (defmacro define-transformation (name args form)
419   `(define-compilation ,name ,args
420      (ls-compile ,form env fenv)))
421
422 (define-transformation progn (&rest body)
423   `((lambda () ,@body)))
424
425 (define-transformation let (bindings &rest body)
426   (let ((bindings (mapcar #'ensure-list bindings)))
427     `((lambda ,(mapcar 'car bindings) ,@body)
428       ,@(mapcar 'cadr bindings))))
429
430 ;;; A little backquote implementation without optimizations of any
431 ;;; kind for lispstrack.
432 (defun backquote-expand-1 (form)
433   (cond
434     ((symbolp form)
435      (list 'quote form))
436     ((atom form)
437      form)
438     ((eq (car form) 'unquote)
439      (car form))
440     ((eq (car form) 'backquote)
441      (backquote-expand-1 (backquote-expand-1 (cadr form))))
442     (t
443      (cons 'append
444            (mapcar (lambda (s)
445                      (cond
446                        ((and (listp s) (eq (car s) 'unquote))
447                         (list 'list (cadr s)))
448                        ((and (listp s) (eq (car s) 'unquote-splicing))
449                         (cadr s))
450                        (t
451                         (list 'list (backquote-expand-1 s)))))
452                    form)))))
453
454 (defun backquote-expand (form)
455   (if (and (listp form) (eq (car form) 'backquote))
456       (backquote-expand-1 (cadr form))
457       form))
458
459 (defmacro backquote (form)
460   (backquote-expand-1 form))
461
462 (define-transformation backquote (form)
463   (backquote-expand-1 form))
464
465 ;;; Primitives
466
467 (define-compilation + (x y)
468   (concat "((" (ls-compile x env fenv) ") + (" (ls-compile y env fenv) "))"))
469
470 (define-compilation - (x y)
471   (concat "((" (ls-compile x env fenv) ") - (" (ls-compile y env fenv) "))"))
472
473 (define-compilation * (x y)
474   (concat "((" (ls-compile x env fenv) ") * (" (ls-compile y env fenv) "))"))
475
476 (define-compilation / (x y)
477   (concat "((" (ls-compile x env fenv) ") / (" (ls-compile y env fenv) "))"))
478
479 (define-compilation < (x y)
480   (concat "((" (ls-compile x env fenv) ") < (" (ls-compile y env fenv) "))"))
481
482 (define-compilation = (x y)
483   (concat "((" (ls-compile x env fenv) ") == (" (ls-compile y env fenv) "))"))
484
485 (define-compilation numberp (x)
486   (concat "(typeof (" (ls-compile x env fenv) ") == \"number\")"))
487
488
489 (define-compilation mod (x y)
490   (concat "((" (ls-compile x env fenv) ") % (" (ls-compile y env fenv) "))"))
491
492 (define-compilation floor (x)
493   (concat "(Math.floor(" (ls-compile x env fenv) "))"))
494
495 (define-compilation null (x)
496   (concat "(" (ls-compile x env fenv) "== false)"))
497
498 (define-compilation cons (x y)
499   (concat "{car: " (ls-compile x env fenv) ", cdr: " (ls-compile y env fenv) "}"))
500
501 (define-compilation consp (x)
502   (concat "('car' in " (ls-compile x env fenv) ")"))
503
504
505 (define-compilation car (x)
506   (concat "(" (ls-compile x env fenv) ").car"))
507
508 (define-compilation cdr (x)
509   (concat "(" (ls-compile x env fenv) ").cdr"))
510
511 (define-compilation setcar (x new)
512   (concat "((" (ls-compile x env fenv) ").car = " (ls-compile new env fenv) ")"))
513
514 (define-compilation setcdr (x new)
515   (concat "((" (ls-compile x env fenv) ").cdr = " (ls-compile new env fenv) ")"))
516
517 (define-compilation symbolp (x)
518   (concat "('name' in " (ls-compile x env fenv) ")"))
519
520 (define-compilation make-symbol (name)
521   (concat "{name: " (ls-compile name env fenv) "}"))
522
523 (define-compilation symbol-name (x)
524   (concat "(" (ls-compile x env fenv) ").name"))
525
526 (define-compilation eq (x y)
527   (concat "(" (ls-compile x env fenv) " === " (ls-compile y env fenv) ")"))
528
529 (define-compilation equal (x y)
530   (concat "(" (ls-compile x env fenv) " == " (ls-compile y env fenv) ")"))
531
532 (define-compilation string (x)
533   (concat "String.fromCharCode(" (ls-compile x env fenv) ")"))
534
535 (define-compilation stringp (x)
536   (concat "(typeof(" (ls-compile x env fenv) ") == \"string\")"))
537
538 (define-compilation string-upcase (x)
539   (concat "(" (ls-compile x env fenv) ").toUpperCase()"))
540
541 (define-compilation string-length (x)
542   (concat "(" (ls-compile x env fenv) ").length"))
543
544 (define-compilation char (string index)
545   (concat "("
546           (ls-compile string env fenv)
547           ").charCodeAt("
548           (ls-compile index env fenv)
549           ")"))
550
551 (define-compilation concat-two (string1 string2)
552   (concat "("
553           (ls-compile string1 env fenv)
554           ").concat("
555           (ls-compile string2 env fenv)
556           ")"))
557
558 (define-compilation funcall (func &rest args)
559   (concat "("
560           (ls-compile func env fenv)
561           ")("
562           (join (mapcar (lambda (x)
563                           (ls-compile x env fenv))
564                         args)
565                 ", ")
566           ")"))
567
568 (define-compilation apply (func &rest args)
569   (if (null args)
570       (concat "(" (ls-compile func env fenv) ")()")
571       (let ((args (butlast args))
572             (last (car (last args))))
573         (concat "function(){" *newline*
574                 "var f = " (ls-compile func env fenv) ";" *newline*
575                 "var args = [" (join (mapcar (lambda (x)
576                                                (ls-compile x env fenv))
577                                              args)
578                                      ", ")
579                 "];" *newline*
580                 "var tail = (" (ls-compile last env fenv) ");" *newline*
581                 "while (tail != false){" *newline*
582                 "    args.push(tail[0]);" *newline*
583                 "    args = args.slice(1);" *newline*
584                 "}" *newline*
585                 "return f.apply(this, args);" *newline*
586                 "}" *newline*))))
587
588 (define-compilation js-eval (string)
589   (concat "eval(" (ls-compile string env fenv)  ")"))
590
591
592 (define-compilation error (string)
593   (concat "(function (){ throw " (ls-compile string env fenv) ";" "return 0;})()"))
594
595 (define-compilation new ()
596   "{}")
597
598 (define-compilation get (object key)
599   (concat "(" (ls-compile object env fenv) ")[" (ls-compile key env fenv) "]"))
600
601 (define-compilation set (object key value)
602   (concat "(("
603           (ls-compile object env fenv)
604           ")["
605           (ls-compile key env fenv) "]"
606           " = " (ls-compile value env fenv) ")"))
607
608 (defun macrop (x)
609   (and (symbolp x) (eq (binding-type (lookup-function x *fenv*)) 'macro)))
610
611 (defun ls-macroexpand-1 (form &optional env fenv)
612   (when (macrop (car form))
613     (let ((binding (lookup-function (car form) *env*)))
614       (if (eq (binding-type binding) 'macro)
615           (apply (eval (binding-translation binding)) (cdr form))
616           form))))
617
618 (defun compile-funcall (function args env fenv)
619   (cond
620     ((symbolp function)
621      (concat (lookup-function-translation function fenv)
622              "("
623              (join (mapcar (lambda (x) (ls-compile x env fenv)) args)
624                    ", ")
625              ")"))
626     ((and (listp function) (eq (car function) 'lambda))
627      (concat "(" (ls-compile function env fenv) ")("
628              (join (mapcar (lambda (x) (ls-compile x env fenv)) args)
629                    ", ")
630              ")"))
631     (t
632      (error (concat "Invalid function designator " (symbol-name function))))))
633
634 (defun ls-compile (sexp &optional env fenv)
635   (cond
636     ((symbolp sexp) (lookup-variable-translation sexp env))
637     ((integerp sexp) (integer-to-string sexp))
638     ((stringp sexp) (concat "\"" (escape-string sexp) "\""))
639     ((listp sexp)
640      (if (assoc (car sexp) *compilations*)
641          (let ((comp (second (assoc (car sexp) *compilations*))))
642            (apply comp env fenv (cdr sexp)))
643          (if (macrop (car sexp))
644              (ls-compile (ls-macroexpand-1 sexp env fenv) env fenv)
645              (compile-funcall (car sexp) (cdr sexp) env fenv))))))
646
647 (defun ls-compile-toplevel (sexp)
648   (setq *toplevel-compilations* nil)
649   (let ((code (ls-compile sexp)))
650     (prog1
651         (concat (join (mapcar (lambda (x) (concat x ";" *newline*))
652                               *toplevel-compilations*)
653                       "")
654                 code)
655       (setq *toplevel-compilations* nil))))
656
657 #+common-lisp
658 (progn
659   (defun read-whole-file (filename)
660     (with-open-file (in filename)
661       (let ((seq (make-array (file-length in) :element-type 'character)))
662         (read-sequence seq in)
663         seq)))
664
665   (defun ls-compile-file (filename output)
666     (setq *env* nil *fenv* nil)
667     (setq *compilation-unit-checks* nil)
668     (with-open-file (out output :direction :output :if-exists :supersede)
669       (let* ((source (read-whole-file filename))
670              (in (make-string-stream source)))
671         (loop
672            for x = (ls-read in)
673            until (eq x *eof*)
674            for compilation = (ls-compile-toplevel x)
675            when (plusp (length compilation))
676            do (write-line (concat compilation "; ") out))
677         (dolist (check *compilation-unit-checks*)
678           (funcall check))
679         (setq *compilation-unit-checks* nil))))
680
681   (defun bootstrap ()
682     (ls-compile-file "lispstrack.lisp" "lispstrack.js")))