Commit | Line | Data |
---|---|---|
eb17f15c HH |
1 | (in-package :js-test) |
2 | ;;Generates automatic tests from the reference | |
3 | ||
4 | (defparameter +reference-file+ (make-pathname :name "reference" | |
5 | :type "lisp" | |
6 | :defaults *load-truename*)) | |
7 | (defparameter +generate-file+ (make-pathname :name "reference-tests" | |
8 | :type "lisp" | |
9 | :defaults *load-truename*)) | |
10 | ||
11 | (defparameter +head+ "(in-package :js-test) | |
12 | ;; Tests of everything in the reference. | |
13 | ;; File is generated automatically from the text in reference.lisp by | |
14 | ;; the function make-reference-tests-dot-lisp in ref2test.lisp | |
15 | ;; so do not edit this file. | |
16 | (def-suite ref-tests) | |
17 | (in-suite ref-tests)~%~%") ; a double-quote for emacs: " | |
18 | ||
19 | (defun make-reference-tests-dot-lisp() | |
20 | (let ((built "") | |
21 | heading | |
22 | heading-count) | |
23 | (with-open-file (out-stream +generate-file+ | |
24 | :direction :output | |
25 | :if-exists :supersede) | |
26 | (labels | |
27 | ((empty-p (str) | |
28 | (zerop (length str))) | |
29 | (trim-whitespace (str) | |
30 | (string-trim '(#\Space #\Tab #\Newline) str)) | |
31 | (left (str count) | |
32 | (subseq str 0 (min count (length str)))) | |
33 | (lispify-heading (heading) | |
34 | (remove-if (lambda (ch) (or (char= ch #\`)(char= ch #\'))) | |
35 | (substitute #\- #\Space (string-downcase (trim-whitespace heading)) | |
36 | :test #'char=))) | |
eb17f15c HH |
37 | (strip-indentation (str indentation) |
38 | (if indentation | |
39 | (js::string-join (mapcar #'(lambda (str) | |
40 | (if (> (length str) indentation) | |
41 | (subseq str indentation) | |
42 | str)) | |
43 | (js::string-split str (list #\Newline))) | |
44 | (string #\Newline)) | |
45 | str)) | |
46 | ||
47 | (make-test () | |
48 | (let* ((sep-pos (search "=>" built)) | |
49 | (cr-before-sep (when sep-pos | |
50 | (or (position #\Newline | |
51 | (left built sep-pos) | |
52 | :from-end t | |
53 | :test #'char=) | |
54 | 0))) | |
55 | (js-indent-width (when cr-before-sep | |
56 | (+ 2 (- sep-pos cr-before-sep)))) | |
57 | (lisp-part (and sep-pos (left built sep-pos))) | |
58 | (javascript-part (when cr-before-sep | |
59 | (subseq built (+ 1 cr-before-sep))))) | |
60 | (cond | |
61 | ((null sep-pos) | |
7a7d6c73 | 62 | (format t "Ignoring:~a...~%" (left built 40))) |
eb17f15c | 63 | ((search "=>" (subseq built (+ 1 sep-pos))) |
7a7d6c73 | 64 | (format t "Error , two separators found~%")) |
eb17f15c HH |
65 | ((and (string= heading "regular-expression-literals") |
66 | (= 2 heading-count)) ;requires cl-interpol reader | |
7a7d6c73 | 67 | (format t "Skipping regex-test two~&")) |
eb17f15c | 68 | ((and lisp-part javascript-part) |
7a7d6c73 | 69 | (format out-stream "(test-ps-js ~a-~a ~% ~a ~% \"~a\")~%~%" |
eb17f15c HH |
70 | heading heading-count |
71 | (trim-whitespace lisp-part) | |
7a7d6c73 HH |
72 | (strip-indentation javascript-part js-indent-width))) |
73 | (t (format t "Error, should not be here~%")))))) | |
eb17f15c HH |
74 | (format out-stream +head+) |
75 | (with-open-file (stream +reference-file+ :direction :input) | |
76 | (loop for line = (read-line stream nil nil) | |
77 | with is-collecting | |
78 | while line do | |
79 | (cond | |
80 | ((string= (left line 4) ";;;#") | |
81 | (setf heading (lispify-heading (subseq line 5))) | |
82 | (setf heading-count 0) | |
83 | (when (string= (trim-whitespace heading) | |
84 | "the-parenscript-compiler") | |
85 | (return))) | |
86 | ((string= (left line 1) ";") 'skip-comment) | |
87 | ((empty-p (trim-whitespace line)) | |
88 | (when is-collecting | |
89 | (setf is-collecting nil) | |
90 | (incf heading-count) | |
91 | (make-test) | |
92 | (setf built ""))) | |
93 | (t | |
94 | (setf is-collecting t | |
95 | built (concatenate 'string built | |
96 | (when (not (empty-p built)) | |
97 | (list #\Newline)) | |
98 | line)))))) | |
711dd89e | 99 | (format out-stream "~%(run-tests)~%"))))) |