ref: 377087f52df398745bee200286c38cc0177b1632
parent: a633177c14382eeb647f6dc0857d255548e9ea8b
author: Sigrid Solveig Haflínudóttir <sigrid@ftrv.se>
date: Tue Feb 11 15:22:26 EST 2025
remove unused stuff from .lsp files
--- a/test/ast/asttools.lsp
+++ b/test/ast/asttools.lsp
@@ -1,4 +1,3 @@
-; -*- scheme -*-
; utilities for AST processing
(def (symconcat s1 s2)
--- a/test/ast/match.lsp
+++ b/test/ast/match.lsp
@@ -1,4 +1,3 @@
-; -*- scheme -*-
; tree regular expression pattern matching
; by Jeff Bezanson
--- a/test/ast/rpasses.lsp
+++ b/test/ast/rpasses.lsp
@@ -1,4 +1,3 @@
-; -*- scheme -*-
(load "match.lsp")
(load "asttools.lsp")
--- a/test/color.lsp
+++ b/test/color.lsp
@@ -1,5 +1,3 @@
-; -*- scheme -*-
-
; dictionaries ----------------------------------------------------------------
(def (dict-new) ())
--- a/test/perf.lsp
+++ b/test/perf.lsp
@@ -1,5 +1,19 @@
(load "test.lsp")
+(def Y
+ (λ (f)
+ ((λ (h)
+ (f (λ (x) ((h h) x))))
+ (λ (h)
+ (f (λ (x) ((h h) x)))))))
+
+(def yfib
+ (Y (λ (fib)
+ (λ (n)
+ (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2))))))))
+
+(def (fib n) (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2)))))
+
(princ "colorgraph: ")
(load "tcolor.lsp")
--- a/test/tcolor.lsp
+++ b/test/tcolor.lsp
@@ -1,4 +1,3 @@
-; -*- scheme -*-
; color for performance
(load "color.lsp")
--- a/test/test.lsp
+++ b/test/test.lsp
@@ -1,195 +1,3 @@
-; make label self-evaluating, but evaluating the lambda in the process
-;(defmacro labl (name f)
-; (list list ''labl (list 'quote name) f))
-
-(defmacro (labl name f)
- `(let (,name) (set! ,name ,f)))
-
-;(def (reverse lst)
-; ((label rev-help (λ (lst result)
-; (if (not lst) result
-; (rev-help (cdr lst) (cons (car lst) result)))))
-; lst ()))
-
-(def (append- . lsts)
- ((label append-h
- (λ (lsts)
- (cond ((not lsts) ())
- ((not (cdr lsts)) (car lsts))
- (t ((label append2 (λ (l d)
- (if (not l) d
- (cons (car l)
- (append2 (cdr l) d)))))
- (car lsts) (append-h (cdr lsts)))))))
- lsts))
-
-;(princ 'Hello '| | 'world! "\n")
-;(filter (λ (x) (not (< x 0))) '(1 -1 -2 5 10 -8 0))
-(def (fib n) (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2)))))
-;(princ (time (fib 34)) "\n")
-;(dotimes (i 20000) (map-int (λ (x) (list 'quote x)) 8))
-;(dotimes (i 40000) (append '(a b) '(1 2 3 4) () '(c) () '(5 6)))
-;(dotimes (i 80000) (list 1 2 3 4 5))
-;(set! a (map-int identity 10000))
-;(dotimes (i 200) (rfoldl cons () a))
-
-#|
-(defmacro (dotimes var . body)
- (let ((v (car var))
- (cnt (cadr var)))
- `(let ((,v 0))
- (while (< ,v ,cnt)
- (prog1
- ,(cons 'begin body)
- (set! ,v (+ ,v 1)))))))
-
-(def (map-int f n)
- (if (<= n 0)
- ()
- (let ((first (cons (f 0) ())))
- ((label map-int-
- (λ (acc i n)
- (if (= i n)
- first
- (begin (set-cdr! acc (cons (f i) ()))
- (map-int- (cdr acc) (+ i 1) n)))))
- first 1 n))))
-|#
-
-(defmacro (labl name fn)
- `((λ (,name) (set! ,name ,fn)) ()))
-
-; like eval-when-compile
-(defmacro (literal expr)
- (let ((v (eval expr)))
- (if (self-evaluating? v) v (list quote v))))
-
-(def (cardepth l)
- (if (atom? l) 0
- (+ 1 (cardepth (car l)))))
-
-(def (nestlist f zero n)
- (if (<= n 0) ()
- (cons zero (nestlist f (f zero) (- n 1)))))
-
-(def (mapl f . lsts)
- ((label mapl-
- (λ (lsts)
- (if (not (car lsts)) ()
- (begin (apply f lsts) (mapl- (map cdr lsts))))))
- lsts))
-
-; test to see if a symbol begins with :
-(def (keywordp s)
- (and (>= s '|:|) (<= s '|:~|)))
-
-; swap the cars and cdrs of every cons in a structure
-(def (swapad c)
- (if (atom? c) c
- (set-cdr! c (K (swapad (car c))
- (set-car! c (swapad (cdr c)))))))
-
-(def (without x l)
- (filter (λ (e) (not (eq e x))) l))
-
-(def (conscount c)
- (if (cons? c) (+ 1
- (conscount (car c))
- (conscount (cdr c)))
- 0))
-
-; _ Welcome to
-; (_ _ _ |_ _ | . _ _ 2
-; | (-||||_(_)|__|_)|_)
-; ==================|==
-
-;[` _ ,_ |- | . _ 2
-;| (/_||||_()|_|_\|)
-; |
-
-(defmacro (while- test . forms)
- `((label -loop- (λ ()
- (if ,test
- (begin ,@forms
- (-loop-))
- ())))))
-
-; this would be a cool use of thunking to handle 'finally' clauses, but
-; this code doesn't work in the case where the user manually re-raises
-; inside a catch block. one way to handle it would be to replace all
-; their uses of 'raise' with '*_try_finally_raise_*' which calls the thunk.
-; (try expr
-; (catch (TypeError e) . exprs)
-; (catch (IOError e) . exprs)
-; (finally . exprs))
-(defmacro (try expr . forms)
- (let ((final (f-body (cdr (or (assq 'finally forms) '(())))))
- (body (foldr
- ; create a function to check for and handle one exception
- ; type, and pass off control to the next when no match
- (λ (catc next)
- (let ((var (cadr (cadr catc)))
- (extype (caadr catc))
- (todo (f-body (cddr catc))))
- `(λ (,var)
- (if (or (eq ,var ',extype)
- (and (cons? ,var)
- (eq (car ,var) ',extype)))
- ,todo
- (,next ,var)))))
-
- ; default function; no matches so re-raise
- '(λ (e) (begin (*_try_finally_thunk_*) (raise e)))
-
- ; make list of catch forms
- (filter (λ (f) (eq (car f) 'catch)) forms))))
- `(let ((*_try_finally_thunk_* (λ () ,final)))
- (prog1 (attempt ,expr ,body)
- (*_try_finally_thunk_*)))))
-
-(def Y
- (λ (f)
- ((λ (h)
- (f (λ (x) ((h h) x))))
- (λ (h)
- (f (λ (x) ((h h) x)))))))
-
-(def yfib
- (Y (λ (fib)
- (λ (n)
- (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2))))))))
-
-;(defun tt () (time (dotimes (i 500000) (* 0x1fffffff 1) )))
-;(tt)
-;(tt)
-;(tt)
-
-(defmacro (accumulate-while cnd what . body)
- `(let ((acc# (list ())))
- (cdr
- (prog1 acc#
- (while ,cnd
- (begin (set! acc#
- (cdr (set-cdr! acc# (cons ,what ()))))
- ,@body))))))
-
-(defmacro (accumulate-for var lo hi what . body)
- `(let ((acc# (list ())))
- (cdr
- (prog1 acc#
- (for ,lo ,hi
- (λ (,var)
- (begin (set! acc#
- (cdr (set-cdr! acc# (cons ,what ()))))
- ,@body)))))))
-
-(def (map-indexed f lst)
- (if (atom? lst) lst
- (let ((i 0))
- (accumulate-while (cons? lst) (f (car lst) i)
- (begin (set! lst (cdr lst))
- (set! i (1+ i)))))))
-
(let ((*profiles* (table)))
(set! profile
(λ (s)
@@ -246,24 +54,3 @@
lastcdr to-proper reverse reverse! list->vector
taboreach list-head list-tail assq memq assoc member
assv memv nreconc bq-process))
-
-(def (filt1 pred lst)
- (def (filt1- pred lst accum)
- (if (not lst) accum
- (if (pred (car lst))
- (filt1- pred (cdr lst) (cons (car lst) accum))
- (filt1- pred (cdr lst) accum))))
- (filt1- pred lst ()))
-
-(def (filto pred lst (accum ()))
- (if (atom? lst) accum
- (if (pred (car lst))
- (filto pred (cdr lst) (cons (car lst) accum))
- (filto pred (cdr lst) accum))))
-
-; (pairwise? p a b c d) == (and (p a b) (p b c) (p c d))
-(def (pairwise? pred . args)
- (or (not args)
- (let f ((a (car args)) (d (cdr args)))
- (or (not d)
- (and (pred a (car d)) (f (car d) (cdr d)))))))
--- a/test/torus.lsp
+++ b/test/torus.lsp
@@ -1,4 +1,3 @@
-; -*- scheme -*-
(def (maplist f l)
(if (not l)
nil
--- a/test/unittest.lsp
+++ b/test/unittest.lsp
@@ -1,4 +1,3 @@
-; -*- scheme -*-
(defmacro (assert-fail expr . what)
`(assert (trycatch (begin ,expr nil)
(λ (e) ,(if (not what) t
@@ -290,10 +289,6 @@
(assert (not (eq? (gensym) (gensym))))
(assert (not (equal? (string (gensym)) (string (gensym)))))
(let ((gs (gensym))) (assert (eq? gs gs)))
-
-; ok, a couple end-to-end tests as well
-(def (fib n) (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2)))))
-(assert (equal? (fib 20) 6765))
(load "color.lsp")
(assert (equal? (color-pairs (generate-5x5-pairs) '(a b c d e))
--- a/tools/mkboot0.lsp
+++ b/tools/mkboot0.lsp
@@ -1,5 +1,3 @@
-; -*- scheme -*-
-
(def update-compiler
(let ((C ()))
(with-bindings
--- a/tools/mkboot1.lsp
+++ b/tools/mkboot1.lsp
@@ -1,5 +1,3 @@
-; -*- scheme -*-
-
(load "../src/builtins.lsp")
(load "../src/instructions.lsp")
(load "../src/system.lsp")