ref: a4055b3185d796477984c88dbce9e833695ebf4f
parent: 52c2630d1928a59568bcec62189150369cab628c
author: Sigrid Solveig Haflínudóttir <sigrid@ftrv.se>
date: Thu Feb 6 23:18:19 EST 2025
tests: clean up
--- a/meson.build
+++ b/meson.build
@@ -382,6 +382,6 @@
test('mp.lsp', flisp, args: ['mp.lsp'], workdir: tests_dir) test('perf.lsp', flisp, args: ['perf.lsp'], workdir: tests_dir, timeout: -1) test('tme.lsp', flisp, args: ['tme.lsp'], workdir: tests_dir)-test('torture.lsp', flisp, args: ['torture.scm'], workdir: tests_dir, timeout: -1)+test('torture.lsp', flisp, args: ['torture.lsp'], workdir: tests_dir, timeout: -1) test('torus.lsp', flisp, args: ['torus.lsp'], workdir: tests_dir) test('unit.lsp', flisp, args: ['unittest.lsp'], workdir: tests_dir)--- a/test/ast/asttools.lsp
+++ b/test/ast/asttools.lsp
@@ -11,7 +11,7 @@
(define (index-of item lst start)
(cond ((null? lst) #f)
- ((eq item (car lst)) start)
+ ((eq? item (car lst)) start)
(#t (index-of item (cdr lst) (+ start 1)))))
(define (each f l)
@@ -87,10 +87,10 @@
(define (flatten-left-op op e)
(maptree-post (lambda (node)
(if (and (cons? node)
- (eq (car node) op)
+ (eq? (car node) op)
(cons? (cdr node))
(cons? (cadr node))
- (eq (caadr node) op))
+ (eq? (caadr node) op))
(cons op
(append (cdadr node) (cddr node)))
node))
@@ -108,9 +108,9 @@
(define (lvc- e env)
(cond ((symbol? e) (lookup-var e env 0))
((cons? e)
- (if (eq (car e) 'quote)
+ (if (eq? (car e) 'quote)
e
- (let* ((newvs (and (eq (car e) 'lambda) (cadr e)))
+ (let* ((newvs (and (eq? (car e) 'lambda) (cadr e)))
(newenv (if newvs (cons newvs env) env)))
(if newvs
(cons 'lambda
@@ -125,7 +125,7 @@
; convert let to lambda
(define (let-expand e)
(maptree-post (lambda (n)
- (if (and (cons? n) (eq (car n) 'let))
+ (if (and (cons? n) (eq? (car n) 'let))
`((lambda ,(map car (cadr n)) ,@(cddr n))
,@(map cadr (cadr n)))
n))
--- a/test/ast/match.lsp
+++ b/test/ast/match.lsp
@@ -6,7 +6,7 @@
(if (null? lst)
()
(cons (car lst)
- (filter (lambda (x) (not (eq x (car lst))))
+ (filter (lambda (x) (not (eq? x (car lst))))
(unique (cdr lst))))))
; list of special pattern symbols that cannot be variable names
@@ -40,7 +40,7 @@
;
(define (match- p expr state)
(cond ((symbol? p)
- (cond ((eq p '_) state)
+ (cond ((eq? p '_) state)
(#t
(let ((capt (assq p state)))
(if capt
@@ -51,12 +51,12 @@
(and (p expr) state))
((cons? p)
- (cond ((eq (car p) '-/) (and (equal? (cadr p) expr) state))
- ((eq (car p) '-^) (and (not (match- (cadr p) expr state)) state))
- ((eq (car p) '--)
+ (cond ((eq? (car p) '-/) (and (equal? (cadr p) expr) state))
+ ((eq? (car p) '-^) (and (not (match- (cadr p) expr state)) state))
+ ((eq? (car p) '--)
(and (match- (caddr p) expr state)
(cons (cons (cadr p) expr) state)))
- ((eq (car p) '-$) ; greedy alternation for toplevel pattern
+ ((eq? (car p) '-$) ; greedy alternation for toplevel pattern
(match-alt (cdr p) () (list expr) state #f 1))
(#t
(and (cons? expr)
@@ -108,20 +108,20 @@
(let ((subp (car p))
(var #f))
(if (and (cons? subp)
- (eq (car subp) '--))
+ (eq? (car subp) '--))
(begin (set! var (cadr subp))
(set! subp (caddr subp)))
#f)
(let ((head (if (cons? subp) (car subp) ())))
- (cond ((eq subp '...)
+ (cond ((eq? subp '...)
(match-star '_ (cdr p) expr state var 0 L L))
- ((eq head '-*)
+ ((eq? head '-*)
(match-star (cadr subp) (cdr p) expr state var 0 L L))
- ((eq head '-+)
+ ((eq? head '-+)
(match-star (cadr subp) (cdr p) expr state var 1 L L))
- ((eq head '-?)
+ ((eq? head '-?)
(match-star (cadr subp) (cdr p) expr state var 0 1 L))
- ((eq head '-$)
+ ((eq? head '-$)
(match-alt (cdr subp) (cdr p) expr state var L))
(#t
(and (cons? expr)
@@ -138,7 +138,7 @@
(list p))
((cons? p)
- (if (eq (car p) '-/)
+ (if (eq? (car p) '-/)
()
(unique (apply append (map patargs- (cdr p))))))
@@ -173,7 +173,7 @@
(if (not (cons? expr))
expr
(let ((enew (apply-patterns plist expr)))
- (if (eq enew expr)
+ (if (eq? enew expr)
; expr didn't change; move to subexpressions
(cons (car expr)
(map (lambda (subex) (pattern-expand plist subex)) (cdr expr)))
--- a/test/ast/match.scm
+++ /dev/null
@@ -1,174 +1,0 @@
-; tree regular expression pattern matching
-; by Jeff Bezanson
-
-; list of special pattern symbols that cannot be variable names
-(define metasymbols '(_ ...))
-
-; expression tree pattern matching
-; matches expr against pattern p and returns an assoc list ((var . expr) (var . expr) ...)
-; mapping variables to captured subexpressions, or #f if no match.
-; when a match succeeds, __ is always bound to the whole matched expression.
-;
-; p is an expression in the following pattern language:
-;
-; _ match anything, not captured
-; <func> any scheme function; matches if (func expr) returns #t
-; <var> match anything and capture as <var>. future occurrences of <var> in the pattern
-; must match the same thing.
-; (head <p1> <p2> etc) match an s-expr with 'head' matched literally, and the rest of the
-; subpatterns matched recursively.
-; (-/ <ex>) match <ex> literally
-; (-^ <p>) complement of pattern <p>
-; (-- <var> <p>) match <p> and capture as <var> if match succeeds
-;
-; regular match constructs:
-; ... match any number of anything
-; (-$ <p1> <p2> etc) match any of subpatterns <p1>, <p2>, etc
-; (-* <p>) match any number of <p>
-; (-? <p>) match 0 or 1 of <p>
-; (-+ <p>) match at least 1 of <p>
-; all of these can be wrapped in (-- var ) for capturing purposes
-; This is NP-complete. Be careful.
-;
-(define (match- p expr state)
- (cond ((symbol? p)
- (cond ((eq? p '_) state)
- (else
- (let ((capt (assq p state)))
- (if capt
- (and (equal? expr (cdr capt)) state)
- (cons (cons p expr) state))))))
-
- ((procedure? p)
- (and (p expr) state))
-
- ((cons? p)
- (cond ((eq? (car p) '-/) (and (equal? (cadr p) expr) state))
- ((eq? (car p) '-^) (and (not (match- (cadr p) expr state)) state))
- ((eq? (car p) '--)
- (and (match- (caddr p) expr state)
- (cons (cons (cadr p) expr) state)))
- ((eq? (car p) '-$) ; greedy alternation for toplevel pattern
- (match-alt (cdr p) () (list expr) state #f 1))
- (else
- (and (cons? expr)
- (equal? (car p) (car expr))
- (match-seq (cdr p) (cdr expr) state (length (cdr expr)))))))
-
- (else
- (and (equal? p expr) state))))
-
-; match an alternation
-(define (match-alt alt prest expr state var L)
- (if (null? alt) #f ; no alternatives left
- (let ((subma (match- (car alt) (car expr) state)))
- (or (and subma
- (match-seq prest (cdr expr)
- (if var
- (cons (cons var (car expr))
- subma)
- subma)
- (- L 1)))
- (match-alt (cdr alt) prest expr state var L)))))
-
-; match generalized kleene star (try consuming min to max)
-(define (match-star p prest expr state var min max L)
- (define (match-star- p prest expr state var min max L sofar)
- (cond ; case 0: impossible to match
- ((> min max) #f)
- ; case 1: only allowed to match 0 subexpressions
- ((= max 0) (match-seq prest expr
- (if var (cons (cons var (reverse sofar)) state)
- state)
- L))
- ; case 2: must match at least 1
- ((> min 0)
- (and (match- p (car expr) state)
- (match-star- p prest (cdr expr) state var (- min 1) (- max 1) (- L 1)
- (cons (car expr) sofar))))
- ; otherwise, must match either 0 or between 1 and max subexpressions
- (else
- (or (match-star- p prest expr state var 0 0 L sofar)
- (match-star- p prest expr state var 1 max L sofar)))))
-
- (match-star- p prest expr state var min max L ()))
-
-; match sequences of expressions
-(define (match-seq p expr state L)
- (cond ((not state) #f)
- ((null? p) (if (null? expr) state #f))
- (else
- (let ((subp (car p))
- (var #f))
- (if (and (cons? subp)
- (eq? (car subp) '--))
- (begin (set! var (cadr subp))
- (set! subp (caddr subp)))
- #f)
- (let ((head (if (cons? subp) (car subp) ())))
- (cond ((eq? subp '...)
- (match-star '_ (cdr p) expr state var 0 L L))
- ((eq? head '-*)
- (match-star (cadr subp) (cdr p) expr state var 0 L L))
- ((eq? head '-+)
- (match-star (cadr subp) (cdr p) expr state var 1 L L))
- ((eq? head '-?)
- (match-star (cadr subp) (cdr p) expr state var 0 1 L))
- ((eq? head '-$)
- (match-alt (cdr subp) (cdr p) expr state var L))
- (else
- (and (cons? expr)
- (match-seq (cdr p) (cdr expr)
- (match- (car p) (car expr) state)
- (- L 1))))))))))
-
-(define (match p expr) (match- p expr (list (cons '__ expr))))
-
-; given a pattern p, return the list of capturing variables it uses
-(define (patargs p)
- (define (patargs- p)
- (cond ((and (symbol? p)
- (not (member p metasymbols)))
- (list p))
-
- ((cons? p)
- (if (eq? (car p) '-/)
- ()
- (delete-duplicates (apply append (map patargs- (cdr p))))))
-
- (else ())))
- (cons '__ (patargs- p)))
-
-; try to transform expr using a pattern-lambda from plist
-; returns the new expression, or expr if no matches
-(define (apply-patterns plist expr)
- (if (null? plist) expr
- (if (procedure? plist)
- (let ((enew (plist expr)))
- (if (not enew)
- expr
- enew))
- (let ((enew ((car plist) expr)))
- (if (not enew)
- (apply-patterns (cdr plist) expr)
- enew)))))
-
-; top-down fixed-point macroexpansion. this is a typical algorithm,
-; but it may leave some structure that matches a pattern unexpanded.
-; the advantage is that non-terminating cases cannot arise as a result
-; of expression composition. in other words, if the outer loop terminates
-; on all inputs for a given set of patterns, then the whole algorithm
-; terminates. pattern sets that violate this should be easier to detect,
-; for example
-; (pattern-lambda (/ 2 3) '(/ 3 2)), (pattern-lambda (/ 3 2) '(/ 2 3))
-; TODO: ignore quoted expressions
-(define (pattern-expand plist expr)
- (if (not (cons? expr))
- expr
- (let ((enew (apply-patterns plist expr)))
- (if (eq? enew expr)
- ; expr didn't change; move to subexpressions
- (cons (car expr)
- (map (lambda (subex) (pattern-expand plist subex)) (cdr expr)))
- ; expr changed; iterate
- (pattern-expand plist enew)))))
--- a/test/ast/rpasses.lsp
+++ b/test/ast/rpasses.lsp
@@ -8,13 +8,13 @@
(define (assigned-var e)
(and (cons? e)
- (or (eq (car e) '<-) (eq (car e) 'ref=))
+ (or (eq? (car e) '<-) (eq? (car e) 'ref=))
(symbol? (cadr e))
(cadr e)))
(define (func-argnames f)
(let ((argl (cadr f)))
- (if (eq argl '*r-null*) ()
+ (if (eq? argl '*r-null*) ()
(map cadr argl))))
; transformations
@@ -64,16 +64,16 @@
(default (caddr arg)))
`(when (missing ,name)
(<- ,name ,default))))
- (filter (lambda (arg) (not (eq (caddr arg) missing-arg-tag))) arglist)))
+ (filter (lambda (arg) (not (eq? (caddr arg) missing-arg-tag))) arglist)))
; convert r function expressions to lambda
(define (normalize-r-functions e)
(maptree-post (lambda (n)
- (if (and (cons? n) (eq (car n) 'function))
+ (if (and (cons? n) (eq? (car n) 'function))
`(lambda ,(func-argnames n)
(r-block ,@(gen-default-inits (cadr n))
,@(if (and (cons? (caddr n))
- (eq (car (caddr n)) 'r-block))
+ (eq? (car (caddr n)) 'r-block))
(cdr (caddr n))
(list (caddr n)))))
n))
@@ -83,8 +83,8 @@
(let ((vars ()))
(maptree-pre (lambda (s)
(if (not (cons? s)) s
- (cond ((eq (car s) 'lambda) ())
- ((eq (car s) '<-)
+ (cond ((eq? (car s) 'lambda) ())
+ ((eq? (car s) '<-)
(set! vars (list-adjoin (cadr s) vars))
(cddr s))
(#t s))))
@@ -94,7 +94,7 @@
; introduce let based on assignment statements
(define (letbind-locals e)
(maptree-post (lambda (n)
- (if (and (cons? n) (eq (car n) 'lambda))
+ (if (and (cons? n) (eq? (car n) 'lambda))
(let ((vars (find-assigned-vars (cddr n))))
`(lambda ,(cadr n) (let ,(map (lambda (v) (list v ()))
vars)
--- a/test/equal.scm
+++ /dev/null
@@ -1,68 +1,0 @@
-; Terminating equal predicate
-; by Jeff Bezanson
-;
-; This version only considers pairs and simple atoms.
-
-; equal?, with bounded recursion. returns 0 if we suspect
-; nontermination, otherwise #t or #f for the correct answer.
-(define (bounded-equal a b N)
- (cond ((<= N 0) 0)
- ((and (cons? a) (cons? b))
- (let ((as
- (bounded-equal (car a) (car b) (- N 1))))
- (if (number? as)
- 0
- (and as
- (bounded-equal (cdr a) (cdr b) (- N 1))))))
- (else (eq? a b))))
-
-; union-find algorithm
-
-; find equivalence class of a cons cell, or #f if not yet known
-; the root of a class is a cons that is its own class
-(define (class table key)
- (let ((c (hashtable-ref table key #f)))
- (if (or (not c) (eq? c key))
- c
- (class table c))))
-
-; move a and b to the same equivalence class, given c and cb
-; as the current values of (class table a) and (class table b)
-; Note: this is not quite optimal. We blindly pick 'a' as the
-; root of the new class, but we should pick whichever class is
-; larger.
-(define (union! table a b c cb)
- (let ((ca (if c c a)))
- (if cb
- (hashtable-set! table cb ca))
- (hashtable-set! table a ca)
- (hashtable-set! table b ca)))
-
-; cyclic equal. first, attempt to compare a and b as best
-; we can without recurring. if we can't prove them different,
-; set them equal and move on.
-(define (cyc-equal a b table)
- (cond ((eq? a b) #t)
- ((not (and (cons? a) (cons? b))) (eq? a b))
- (else
- (let ((aa (car a)) (da (cdr a))
- (ab (car b)) (db (cdr b)))
- (cond ((or (not (eq? (atom? aa) (atom? ab)))
- (not (eq? (atom? da) (atom? db)))) #f)
- ((and (atom? aa)
- (not (eq? aa ab))) #f)
- ((and (atom? da)
- (not (eq? da db))) #f)
- (else
- (let ((ca (class table a))
- (cb (class table b)))
- (if (and ca cb (eq? ca cb))
- #t
- (begin (union! table a b ca cb)
- (and (cyc-equal aa ab table)
- (cyc-equal da db table)))))))))))
-
-(define (equal a b)
- (let ((guess (bounded-equal a b 2048)))
- (if (boolean? guess) guess
- (cyc-equal a b (make-eq-hashtable)))))
--- a/test/mkfile
+++ b/test/mkfile
@@ -9,7 +9,7 @@
tme.lsp\
mp.lsp\
perf.lsp\
- torture.scm
+ torture.lsp
test:QV:
for(t in $TESTS){--- a/test/perf.lsp
+++ b/test/perf.lsp
@@ -28,7 +28,6 @@
(set! L (map-int (λ (x) (map-int identity 20)) 20))
(time (dotimes (n 1000) (apply my-append L)))
-#| FIXME(sigrid): broken
(path-cwd "ast")
(princ "p-lambda: ")
(load "rpasses.lsp")
@@ -36,4 +35,3 @@
(time (set! *output* (compile-ish *input*)))
(assert (equal? *output* (load "rpasses-out.lsp")))
(path-cwd "..")
-|#
--- a/test/pisum.lsp
+++ /dev/null
@@ -1,8 +1,0 @@
-(define (pisum)
- (dotimes (j 500)
- ((label sumloop
- (λ (i sum)
- (if (> i 10000)
- sum
- (sumloop (+ i 1) (+ sum (/ (* i i)))))))
- 1.0 0.0)))
--- a/test/printcases.lsp
+++ /dev/null
@@ -1,26 +1,0 @@
-expand
-append
-bq-process
-
-(define (syntax-environment)
- (map (λ (s) (cons s (symbol-syntax s)))
- (filter symbol-syntax (environment))))
-
-(syntax-environment)
-
-(symbol-syntax 'try)
-
-(map-int (λ (x) `(a b c d e)) 90)
-
-(list->vector (map-int (λ (x) `(a b c d e)) 90))
-
-'((λ (x y) (if (< x y) x y)) (a b c) (d e f) 2 3 (r t y))
-
-'((λ (x y) (if (< x y) x yffffffffffffffffffff)) (a b c) (d e f) 2 3 (r t y))
-
-'((λ (x y) (if (< x y) x y)) (a b c) (d (e zz zzz) f) 2 3 (r t y))
-
-'((23 . a) (9 . a) (22 . b) (17 . d) (14 . d) (8 . b) (21 . e)
- (19 . b) (16 . c) (13 . c) (11 . b) (7 . e) (24 . c) (20 . d)
- (18 . e) (15 . a) (12 . a) (10 . e) (6 . d) (5 . c) (4 . e)
- (3 . d) (2 . c) (0 . b) (1 . a))
--- /dev/null
+++ b/test/torture.lsp
@@ -1,0 +1,20 @@
+(define ones (map (λ (x) 1) (iota 10000000)))
+
+(write (apply + ones))
+(newline)
+
+(define (big n)
+ (if (<= n 0)
+ 0
+ `(+ 1 1 1 1 1 1 1 1 1 1 ,(big (- n 1)))))
+
+; https://todo.sr.ht/~ft/femtolisp/2
+;(define nst (big 100000))
+;(write (eval nst))
+;(newline)
+
+(define longg (cons '+ ones))
+(write (eval longg))
+(newline)
+
+(vm-stats)
--- a/test/torture.scm
+++ /dev/null
@@ -1,20 +1,0 @@
-(define ones (map (λ (x) 1) (iota 10000000)))
-
-(write (apply + ones))
-(newline)
-
-(define (big n)
- (if (<= n 0)
- 0
- `(+ 1 1 1 1 1 1 1 1 1 1 ,(big (- n 1)))))
-
-; https://todo.sr.ht/~ft/femtolisp/2
-;(define nst (big 100000))
-;(write (eval nst))
-;(newline)
-
-(define longg (cons '+ ones))
-(write (eval longg))
-(newline)
-
-(vm-stats)
--- a/test/wt.lsp
+++ /dev/null
@@ -1,28 +1,0 @@
-(define-macro (while- test . forms)
- `((label -loop- (λ ()
- (if ,test
- (begin ,@forms
- (-loop-))
- ())))))
-
-(define (tw)
- (set! i 0)
- (while (< i 10000000) (set! i (+ i 1))))
-
-(define (tw2)
- (letrec ((loop (λ ()
- (if (< i 10000000)
- (begin (set! i (+ i 1))
- (loop))
- ()))))
- (loop)))
-
-#|
-interpreter:
-while: 1.82sec
-macro: 2.98sec
-
-compiler:
-while: 0.72sec
-macro: 1.24sec
-|#
--
⑨