Artifact ebd057d2e8f788ae04924369e6e3100e23191f4415f9567b5c6bbd46c0f8defc:
- File
psl-1983/3-1/tests/psl-timer.sl
— part of check-in
[eb17ceb7f6]
at
2020-04-21 19:40:01
on branch master
— Add Reduce 3.0 to the historical section of the archive, and some more
files relating to version sof PSL from the early 1980s. Thanks are due to
Paul McJones and Nelson Beebe for these, as well as to all the original
authors.git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/historical@5328 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 5679) [annotate] [blame] [check-ins using] [more...]
% PSL-TIMER.SL Source of PSL "spectral" tests % Compile this file to produce psl-timer.b % then LAPIN the file "time-psl.sl" '( (sstatus translink t) (declare (localf tak gtak)) (def de (macro (x) (cons 'defun (cdr x)))) (def igreaterp (macro (x) (cons '> (cdr x)))) (def ilessp (macro (x) (cons '< (cdr x)))) (def iadd1 (macro (x) (cons '1+ (cdr x)))) (def isub1 (macro (x) (cons '1- (cdr x)))) (def itimes2 (macro (x) (cons '* (cdr x)))) (allocate 'fixnum 2000) (allocate 'list 500) (setq $gcprint t) (defun time () (* (car (ptime)) 17)) (defun reclaim () (gc)) ) (fluid '(TestList TestList2 LongList EvalForm)) (de TestSetup () (progn (setq TestList (PrepareTest 1000)) (setq TestList2 (PrepareTest 2000)) (MakeLongList) (setq EvalForm '(setq Foo (cadr '(1 2 3)))))) (de MakeLongList () (prog (I) (setq LongList '(a b c d e f g h i j k l m n o p q r s t u v w x y z)) (setq I 0) loop (cond ((igreaterp I 5) (return nil))) (setq LongList (append LongList LongList)) (setq I (iadd1 I)) (go loop))) (de PrepareTest (n) (prog (l i) (setq i -1 l nil) top (cond ((ilessp n i) (return l))) (setq i (iadd1 i) l (cons nil l)) (go top))) (de Cdr1Test (N) (prog (I L) (setq I -1) loop (setq I (iadd1 I)) (setq L LongList) (cond ((igreaterp I N) (return nil))) loop1 (cond ((atom (setq L (cdr L))) (go loop))) (go loop1))) (de Cdr2Test (N) (prog (I L) (setq I -1) loop (setq I (iadd1 I)) (setq L LongList) (cond ((igreaterp I N) (return nil))) loop1 (cond ((null (setq L (cdr L))) (go loop))) (go loop1))) (de CddrTest (N) (prog (I L) (setq I -1) loop (setq I (iadd1 I)) (setq L LongList) (cond ((igreaterp I N) (return nil))) loop1 (cond ((null (setq L (cddr L))) (go loop))) (go loop1))) (de ListOnlyCdrTest1 () (prog (l1 l2) (setq l1 TestList) top (setq l2 TestList) again (cond ((null (setq l2 (cdr l2))) (cond ((null (setq l1 (cdr l1))) (return nil)) (t (go top)))) (t (go again))))) (de ListOnlyCddrTest1 () (prog (l1 l2) (setq l1 TestList2) top (setq l2 TestList2) again (cond ((null (setq l2 (cddr l2))) (cond ((null (setq l1 (cddr l1))) (return nil)) (t (go top)))) (t (go again))))) (de ListOnlyCdrTest2 () (prog (l1 l2) (setq l1 TestList) top (setq l2 TestList) again (cond ((atom (setq l2 (cdr l2))) (cond ((atom (setq l1 (cdr l1))) (return nil)) (t (go top)))) (t (go again))))) (de ListOnlyCddrTest2 () (prog (l1 l2) (setq l1 TestList2) top (setq l2 TestList2) again (cond ((atom (setq l2 (cddr l2))) (cond ((atom (setq l1 (cddr l1))) (return nil)) (t (go top)))) (t (go again))))) (de EmptyTest (N) (prog (I) (setq I 0) loop (cond ((igreaterp I N) (return nil))) (setq I (iadd1 I)) (go loop))) (de SlowEmptyTest (N) (prog (I) (setq I 0) loop (cond ((greaterp I N) (return nil))) (setq I (add1 I)) (go loop))) (de ReverseTest (N) (prog (I) (setq I 0) loop (cond ((igreaterp I N) (return nil))) (reverse LongList) (setq I (iadd1 I)) (go loop))) (de MyReverse1Test (N) (prog (I) (setq I 0) loop (cond ((igreaterp I N) (return nil))) (myreverse1 LongList) (setq I (iadd1 I)) (go loop))) (de myreverse1 (L) (prog (M) loop (cond ((atom L) (return M))) (setq M (cons (car L) M)) (setq L (cdr L)) (go loop))) (de MyReverse2Test (N) (prog (I) (setq I 0) loop (cond ((igreaterp I N) (return nil))) (myreverse2 LongList) (setq I (iadd1 I)) (go loop))) (de myreverse2 (L) (prog (M) loop (cond ((null L) (return M))) (setq M (cons (car L) M)) (setq L (cdr L)) (go loop))) (de LengthTest (N) (prog (I) (setq I 0) loop (cond ((igreaterp I N) (return nil))) (length LongList) (setq I (iadd1 I)) (go loop))) (de Fact (N) (cond ((ilessp N 2) 1) (t (itimes2 N (Fact (isub1 N)))))) (de ArithmeticTest (N) (prog (I) (setq I 0) loop (cond ((igreaterp I N) (return nil))) (Fact 9) (setq I (iadd1 I)) (go loop))) (de EvalTest (N) (prog (I) (setq I 0) loop (cond ((igreaterp I N) (return nil))) (eval EvalForm) (setq I (iadd1 I)) (go loop))) (de TimeEval (Form) (prog (I) (setq I (time)) (eval Form) (return (difference (time) I)))) (de topleveltak (x y z) (tak x y z)) (de tak (x y z) (cond ((null (ilessp y x)) z) (t (tak (tak (isub1 x) y z) (tak (isub1 y) z x) (tak (isub1 z) x y))))) (de toplevelgtak (x y z) (gtak x y z)) (de gtak (x y z) (cond ((null (lessp y x)) z) (t (gtak (gtak (sub1 x) y z) (gtak (sub1 y) z x) (gtak (sub1 z) x y))))) (de gtsta (F) (prog (I) (setq I 1) Loop (cond ((igreaterp I 100000) (return nil))) (apply F (list I)) (setq I (iadd1 I)) (go Loop))) (de gtstb (F) (prog (I) (setq I 1) Loop (cond ((igreaterp I 100000) (return nil))) (funcall F I) (setq I (iadd1 I)) (go Loop))) (de g0 (X) X) (de g1 (X) (iadd1 X)) (de nreverse (x) (nreconc x nil)) (de nreconc (x y) (prog (z) L (cond ((atom x) (return y))) (setq z x) (setq x (cdr x)) (setq y (rplacd z y)) (go L))) (de nnils (N) (prog (LST i) (setq i 0) loop (cond ((igreaterp i N) (return LST))) (setq LST (cons nil LST)) (setq i (iadd1 i)) (go loop))) (global '(TestGlobalVar)) (de nils (N) (setq TESTGLOBALVAR (nnils N)) N) (de nr () (setq TESTGLOBALVAR (nreverse TESTGLOBALVAR)) nil)