diff options
| -rw-r--r-- | csc/compare.csc | 243 | ||||
| -rw-r--r-- | csc/compiler.csc | 10 | ||||
| -rw-r--r-- | csc/format.csc | 59 | ||||
| -rw-r--r-- | csc/strings-test.csc | 52 | ||||
| -rw-r--r-- | csc/strings.csc | 69 | ||||
| -rw-r--r-- | csc/testing.csc | 54 |
6 files changed, 264 insertions, 223 deletions
diff --git a/csc/compare.csc b/csc/compare.csc index fad9e4b..e8e68d3 100644 --- a/csc/compare.csc +++ b/csc/compare.csc @@ -1,25 +1,34 @@ (define-library (csc compare) - (export diff) + (export diff apply-transformer) (import (scheme base) - (only (csc format) fprintf) - (only (csc loop) - loop - return) + (only (scheme write) + display + write) (only (csc strings) - contains - split) - (only (csc vec) - vec - vec-append)) + contains? + split)) (begin ; compare is inspired by Go's cmp.Diff. + (define (print w . xs) + (unless (null? xs) + (let ((x (car xs))) + (if (or (string? x) + (symbol? x)) + (display x w) + (write x w))) + (apply print w (cdr xs)))) + + (define (apply-transformer t x) (if (list? t) - (loop for transformer in t - do (set! x (apply-transformer transformer x)) - finally (return x)) + (let loop ((transformers t) + (x x)) + (if (null? transformers) + x + (loop (cdr transformers) + (apply-transformer (car transformers) x)))) (if ((car t) x) ((cdr t) x) x))) @@ -27,11 +36,13 @@ (define (alist? l) (and (list? l) - (loop for x in l - unless (and (pair? x) - (symbol? (car x))) - return #f - finally (return #t)))) + (let loop ((l l)) + (cond + ((null? l) #t) + ((not (and (pair? (car l)) + (symbol? (caar l)))) + #f) + (else (loop (cdr l))))))) (define (transform x transformers) @@ -57,13 +68,16 @@ (define table (make-vector (* (+ 1 (vector-length x-vals)) (+ 1 (vector-length y-vals))) 0)) (define (index i j) (+ j (* i (+ 1 (vector-length y-vals))))) - (loop for i from 1 to (vector-length x-vals) - do (loop for j from 1 to (vector-length y-vals) - if (cmp (vector-ref x-vals (- i 1)) (vector-ref y-vals (- j 1))) - do (vector-set! table (index i j) (+ 1 (vector-ref table (index (- i 1) (- j 1))))) - else - do (vector-set! table (index i j) (max (vector-ref table (index (- i 1) j)) - (vector-ref table (index i (- j 1))))))) + (let loop-i ((i 1)) + (when (<= i (vector-length x-vals)) + (let loop-j ((j 1)) + (when (<= j (vector-length y-vals)) + (if (cmp (vector-ref x-vals (- i 1)) (vector-ref y-vals (- j 1))) + (vector-set! table (index i j) (+ 1 (vector-ref table (index (- i 1) (- j 1))))) + (vector-set! table (index i j) (max (vector-ref table (index (- i 1) j)) + (vector-ref table (index i (- j 1)))))) + (loop-j (+ 1 j)))) + (loop-i (+ 1 i)))) (let loop ((i (vector-length x-vals)) (j (vector-length y-vals)) (lcs '())) @@ -79,17 +93,18 @@ (define (pretty w x indent) (cond ((list? x) - (fprintf w "{} (\n" indent) - (loop with new-indent = (string-append indent " ") - for v in x - do (pretty w v new-indent)) - (fprintf w "{} )\n" indent)) + (print w indent " (\n") + (let ((new-indent (string-append indent " "))) + (for-each (lambda (v) + (pretty w v new-indent)) + x)) + (print w indent " )\n")) ((and (pair? x) (symbol? (car x))) - (fprintf w "{} ({} .\n" indent (car x)) + (print w indent " (" (car x) " .\n") (pretty w (cdr x) (string-append indent " ")) - (fprintf w "{} )\n" indent)) - (else (fprintf w "{} {}\n" indent x)))) + (print w indent " )\n")) + (else (print w indent " " x "\n")))) (define (diff* w x y indent) @@ -101,89 +116,94 @@ (and (string? x) (string? y))) (if (equal? x y) (begin - (fprintf w "{} {}\n" indent x) + (print w indent " " x "\n") #t) (begin - (fprintf w "{}- {}\n{}+ {}\n" indent x indent y) + (print w indent "- " x "\n" indent "+ " y "\n") #f))) ((and (alist? x) (alist? y)) - (fprintf w "{} (\n" indent) + (print w indent " (\n") (let ((key-lcs (lcs (map car x) (map car y) symbol=?)) (indent* (string-append indent " ")) (equal #t)) - (loop if (null? key-lcs) - if (null? x) - if (null? y) - do (return) - else - do (pretty w (car y) (string-append indent* "+")) - (set! y (cdr y)) - (set! equal #f) - else - do (pretty w (car x) (string-append indent* "-")) - (set! x (cdr x)) - (set! equal #f) - else - if (symbol=? (caar x) (caar y) (car key-lcs)) - do (fprintf w "{} ({} .\n" indent* (car key-lcs)) - (set! equal (and (diff* w (cdar x) (cdar y) (string-append indent* " ")) - equal)) - (fprintf w "{} )\n" indent*) - (set! x (cdr x)) - (set! y (cdr y)) - (set! key-lcs (cdr key-lcs)) - else if (symbol=? (caar x) (car key-lcs)) - do (pretty w (car y) (string-append indent* "+")) - (set! y (cdr y)) - (set! equal #f) - else - do (pretty w (car x) (string-append indent* "-")) - (set! x (cdr x)) - (set! equal #f)) - (fprintf w "{} )\n" indent) + (let loop () + (unless (and (null? key-lcs) + (null? x) + (null? y)) + (cond + ((and (null? key-lcs) + (null? x)) + (pretty w (car y) (string-append indent* "+")) + (set! y (cdr y)) + (set! equal #f)) + ((null? key-lcs) + (pretty w (car x) (string-append indent* "-")) + (set! x (cdr x)) + (set! equal #f)) + ((symbol=? (caar x) (caar y) (car key-lcs)) + (print w indent* " (" (car key-lcs) " .\n") + (set! equal (and (diff* w (cdar x) (cdar y) (string-append indent* " ")) + equal)) + (print w indent* " )\n") + (set! x (cdr x)) + (set! y (cdr y)) + (set! key-lcs (cdr key-lcs))) + ((symbol=? (caar x) (car key-lcs)) + (pretty w (car y) (string-append indent* "+")) + (set! y (cdr y)) + (set! equal #f)) + (else + (pretty w (car x) (string-append indent* "-")) + (set! x (cdr x)) + (set! equal #f))) + (loop))) + (print w indent " )\n") equal)) ((and (list? x) (list? y)) - (fprintf w "{} (\n" indent) + (print w indent " (\n") (let* ((common (lcs x y equal?)) (indent* (string-append indent " ")) (equal #t)) - (loop if (null? common) - if (null? x) - if (null? y) - do (return) - else - do (pretty w (car y) (string-append indent* "+")) - (set! y (cdr y)) - (set! equal #f) - else if (null? y) - do (pretty w (car x) (string-append indent* "-")) - (set! x (cdr x)) - (set! equal #f) - else - do (diff* w (car x) (car y) indent*) - (set! x (cdr x)) - (set! y (cdr y)) - (set! equal #f) - else - if (equal? (car x) (car y)) - do (pretty w (car x) (string-append indent* " ")) - (set! x (cdr x)) - (set! y (cdr y)) - (set! common (cdr common)) - else if (equal? (car x) (car common)) - do (pretty w (car y) (string-append indent* "+")) - (set! y (cdr y)) - (set! equal #f) - else if (equal? (car y) (car common)) - do (pretty w (car x) (string-append indent* "-")) - (set! x (cdr x)) - (set! equal #f) - else - do (diff* w (car x) (car y) indent*) - (set! x (cdr x)) - (set! y (cdr y)) - (set! equal #f)) - (fprintf w "{} )\n" indent) + (let loop () + (unless (and (null? common) + (null? x) + (null? y)) + (cond + ((and (null? common) + (null? x)) + (pretty w (car y) (string-append indent* "+")) + (set! y (cdr y)) + (set! equal #f)) + ((and (null? common) + (null? y)) + (pretty w (car x) (string-append indent* "-")) + (set! x (cdr x)) + (set! equal #f)) + ((null? common) + (diff* w (car x) (car y) indent*) + (set! x (cdr x)) + (set! y (cdr y)) + (set! equal #f)) + ((equal? (car x) (car y)) + (pretty w (car x) (string-append indent* " ")) + (set! x (cdr x)) + (set! y (cdr y)) + (set! common (cdr common))) + ((equal? (car x) (car common)) + (pretty w (car y) (string-append indent* "+")) + (set! y (cdr y)) + (set! equal #f)) + ((equal? (car y) (car common)) + (pretty w (car x) (string-append indent* "-")) + (set! x (cdr x)) + (set! equal #f)) + (else + (diff* w (car x) (car y) indent*) + (set! x (cdr x)) + (set! y (cdr y)) + (set! equal #f))) + (loop))) + (print w indent " )\n") equal)) (else (pretty w x (string-append indent "-")) @@ -195,7 +215,7 @@ (list (cons (lambda (s) (and (string? s) - (contains s "\n"))) + (contains? s "\n"))) (lambda (s) (list (cons '!type 'string) (cons 'value (split s "\n"))))) @@ -204,10 +224,15 @@ (cons 'value (vector->list v))))) (cons bytevector? (lambda (b) (list (cons '!type 'bytevector) - (cons 'value (loop for i below (bytevector-length b) - collect (string-append "0x" (number->string - (bytevector-u8-ref b i) - 16))))))))) + (cons 'value (let loop ((i 0) + (acc '())) + (when (< i (bytevector-length b)) + (loop (+ 1 i) + (cons (string-append "0x" (number->string + (bytevector-u8-ref b i) + 16)) + acc))) + (reverse acc)))))))) ; Returns a string diff between x and y. Diff knows how to compare lists, diff --git a/csc/compiler.csc b/csc/compiler.csc index 4f1cafc..728b8c5 100644 --- a/csc/compiler.csc +++ b/csc/compiler.csc @@ -3,6 +3,8 @@ *library-search-dir* compile) (import (scheme base) + (only (scheme file) + file-exists?) (only (csc codegen) ir2->ir3) (only (csc config) @@ -10,6 +12,8 @@ (only (csc cps) closure-convert ir1->ir2) + (only (csc encoding) + encode) (only (csc format) sprintf) (only (csc hash-map) @@ -22,9 +26,7 @@ (only (csc list) revappend) (only (csc match) - match) - (only (scheme file) - file-exists?)) + match)) (begin @@ -131,5 +133,5 @@ (compile (cons (list 'import (append imports1 imports2)) rest))) ((('import . imports) . body) (define compiled-body (ir1->bytecode (expand-body 'main body (make-import-map imports)))) - (link (revappend library-code (list compiled-body))) + (encode (link (revappend library-code (list compiled-body))))) (_ (error "unexpected form in compile" program)))))) diff --git a/csc/format.csc b/csc/format.csc index 0469812..6ffd736 100644 --- a/csc/format.csc +++ b/csc/format.csc @@ -4,39 +4,40 @@ printf sprintf) (import (scheme base) - (only (scheme write) display) + (only (scheme write) + display) + (only (csc loop) + loop) (only (csc strings) - find - not-found-error? - prefix?)) + index + has-prefix?)) (begin - (define (fprintf port format-string . format-args) - (let loop ((start 0) - (args format-args)) - (cond ((>= start (string-length format-string))) - ((prefix? "{{" format-string start) - (write-string "{" port) - (loop (+ 2 start) args)) - ((prefix? "}}" format-string start) - (write-string "}" port) - (loop (+ 2 start) args)) - ((prefix? "{}" format-string start) - (display (car args) port) - (loop (+ 2 start) (cdr args))) - ((prefix? "{" format-string start) - (raise (error "invalid format string" format-string))) - (else - (let* ((open-brace-pos (guard (e - ((not-found-error? e) (string-length format-string))) - (find "{" format-string start))) - (close-brace-pos (guard (e - ((not-found-error? e) (string-length format-string))) - (find "}" format-string start))) - (format-pos (min open-brace-pos close-brace-pos))) - (write-string format-string port start format-pos) - (loop format-pos args)))))) + (define (fprintf port format-string . args) + (loop with s = format-string + until (string=? "" s) + if (has-prefix? s "{{") + do (write-string "{" port) + (set! s (string-copy s 2)) + else if (has-prefix? s "}}") + do (write-string "}" port) + (set! s (string-copy s 2)) + else if (has-prefix? s "{}") + do (display (car args) port) + (set! args (cdr args)) + (set! s (string-copy s 2)) + else if (or (has-prefix? s "{") + (has-prefix? s "}")) + do (error "invalid format string" format-string) + else + do (let* ((open-brace-pos (index s "{")) + (close-brace-pos (index s "}")) + (format-pos (min open-brace-pos close-brace-pos))) + (when (negative? format-pos) + (set! format-pos (string-length s))) + (write-string s port 0 format-pos) + (set! s (string-copy s format-pos))))) (define (printf format-string . format-args) diff --git a/csc/strings-test.csc b/csc/strings-test.csc index 60bfb08..1f981ad 100644 --- a/csc/strings-test.csc +++ b/csc/strings-test.csc @@ -8,16 +8,16 @@ (begin - (test prefix?-good - (assert-equal #t (prefix? "asdf" "asdfjkl;"))) + (test has-prefix?-good + (assert-equal #t (has-prefix? "asdfjkl;" "asdf"))) - (test prefix?-bad - (assert-equal #f (prefix? "asdf" "asdbjkl;"))) + (test has-prefix?-bad + (assert-equal #f (has-prefix? "asdbjkl;" "asdf"))) - (test prefix?-too-long - (assert-equal #f (prefix? "asdf" "as"))) + (test has-prefix?-too-long + (assert-equal #f (has-prefix? "as" "asdf"))) (test str-quote-simple @@ -28,46 +28,42 @@ (assert-equal "\"this string \\\" has a quote\"" (str-quote "this string \" has a quote"))) - (test find-ok - (assert-equal 8 (find "abc" "dabsadfdabcdfdfd"))) + (test index-ok + (assert-equal 8 (index "dabsadfdabcdfdfd" "abc"))) - (test find-one-letter - (assert-equal 8 (find "a" "sdfdfdfsasdfe"))) + (test index-one-letter + (assert-equal 8 (index "sdfdfdfsasdfe" "a"))) - (test find-notfound - (let* ((match "a") - (str "def") - (got-exception '())) - (guard (e - ((not-found-error? e) (set! got-exception e))) - (find match str)) - (assert (not-found-error? got-exception)))) + (test index-notfound + (assert-equal + -1 + (index "def" "a"))) (test contains (assert-equal #t - (contains "abc" "b"))) + (contains? "abc" "b"))) (test doesnt-contain (assert-equal #f - (contains "abc" "d"))) + (contains? "abc" "d"))) (test contains-empty (assert-equal #t - (contains "" ""))) + (contains? "" ""))) (test empty-contains (assert-equal #f - (contains "" "a"))) + (contains? "" "a"))) (test join-, @@ -94,4 +90,14 @@ (test split-trailing-empty - (assert-equal '("a" "") (split "a " " "))))) + (assert-equal '("a" "") (split "a " " "))) + + + (test split-n + (assert-equal '("a" "b" "c d e") (split "a b c d e" " " 3))) + + + (test split-none + (assert-equal + '() + (split "a b c d e" " " 0))))) diff --git a/csc/strings.csc b/csc/strings.csc index 75175f0..255a2fd 100644 --- a/csc/strings.csc +++ b/csc/strings.csc @@ -1,26 +1,24 @@ (define-library (csc strings) (export - contains - find + contains? + has-prefix? + index join - not-found-error? - prefix? split str-quote) (import (scheme base) (only (scheme case-lambda) case-lambda) (only (scheme write) write) (only (csc list) intercalate) - (only (csc loop) loop)) + (only (csc loop) + loop + return)) (begin - (define prefix? - (case-lambda - ((prefix str) (prefix? prefix str 0)) - ((prefix str start) - (and (<= (string-length prefix) (- (string-length str) start)) - (string=? prefix (substring str start (+ start (string-length prefix)))))))) + (define (has-prefix? str prefix) + (and (<= (string-length prefix) (string-length str)) + (string=? prefix (substring str 0 (string-length prefix))))) (define (str-quote s) @@ -29,37 +27,38 @@ (get-output-string out))) - (define-record-type <not-found-error> - (make-not-found-error) - not-found-error?) - + (define (index s substr) + (loop for i from 0 + for s = s then (string-copy s 1) + until (string=? "" s) + if (has-prefix? s substr) + return i + finally (return -1))) - (define find - (case-lambda - ((match str) (find match str 0 (string-length str))) - ((match str start) (find match str start (string-length str))) - ((match str start end) - (let loop ((i start)) - (cond ((>= i end) (raise (make-not-found-error))) - ((prefix? match str i) i) - (else (loop (+ 1 i)))))))) - - (define (contains s substr) + (define (contains? s substr) (if (string=? "" substr) #t - (guard (e ((not-found-error? e) #f)) - (find substr s) - #t))) + (not (negative? (index s substr))))) (define (join sep strings) (apply string-append (intercalate sep strings))) - (define (split s sep) - (loop for s* = s then (string-copy s* (+ i (string-length sep))) - for i = (guard (e ((not-found-error? e) (string-length s*))) - (find sep s*)) - collect (substring s* 0 i) - while (< i (string-length s*)))))) + (define split + (case-lambda + ((s sep n) + (if (= 0 n) + '() + (loop for n = n then (- n 1) + for s = s then (string-copy s (+ i (string-length sep))) + for i = (let ((i (index s sep))) + (if (or (negative? i) + (= 1 n)) + (string-length s) + i)) + collect (substring s 0 i) + while (< i (string-length s))))) + ((s sep) + (split s sep -1)))))) diff --git a/csc/testing.csc b/csc/testing.csc index 3fa8ad5..68678ca 100644 --- a/csc/testing.csc +++ b/csc/testing.csc @@ -6,10 +6,10 @@ test test-main) (import (scheme base) - (only (csc compare) diff) - (only (csc format) - printf - sprintf)) + (only (scheme write) + display + write) + (only (csc compare) diff)) (begin @@ -30,32 +30,41 @@ test-error?) + (define *test-error* (make-test-error)) + + (define *test-handle* (make-test-handle "global")) + (define (print . xs) + (unless (null? xs) + (let ((x (car xs))) + (if (or (string? x) + (symbol? x)) + (display x) + (write x))) + (apply print (cdr xs)))) + + (define-syntax test (syntax-rules () ((test name body body* ...) (begin (set-name! *test-handle* (symbol->string 'name)) - (printf "=== RUN {}\n" 'name) + (print "=== RUN " 'name "\n") (guard (e ((test-error? e) - (printf "--- FAIL: {}\n" 'name) - (set-all-succeeded! #f))) + (print "--- FAIL: " 'name "\n") + (set-all-succeeded! #f))) body body* ... - (printf "--- PASS: {}\n" 'name)))))) - - - (define (fatalf format-string . format-args) - (printf "{}: {}\n" (test-name *test-handle*) (apply sprintf format-string format-args)) - (raise (make-test-error))) + (print "--- PASS: " 'name "\n")))))) (define-syntax assert (syntax-rules () ((assert expr) (unless expr - (fatalf "(assert {}) failed." 'expr))))) + (print (test-name *test-handle*) ": (assert " 'expr ") failed.\n") + (raise *test-error*))))) (define-syntax assert-equal @@ -63,21 +72,20 @@ ((assert-equal left right transformers ...) (let ((d (diff left right transformers ...))) (unless (string=? "" d) - (fatalf "Fatal:\n {}\nis not equal to\n {}.\ndiff (-left +right):\n{}" 'left 'right d)))) - ((assert-equal left right) - (assert-equal equal? left right)))) + (print "Fatal:\n " 'left "\nis not equal to\n " 'right "\ndiff (-left +right):\n" d "\n") + (raise *test-error*)))))) (define-syntax assert-raises (syntax-rules () ((assert-raises predicate body body* ...) - (assert - (guard (e ((predicate e) #t)) - body body* ... - #f))))) + (assert + (guard (e ((predicate e) #t)) + body body* ... + #f))))) (define (test-main) (if *all-tests-succeeded* - (printf "PASS\n") - (printf "FAIL\n"))))) + (print "PASS\n") + (print "FAIL\n"))))) |