diff options
Diffstat (limited to 'src/scheme/test')
| -rw-r--r-- | src/scheme/test/.gitignore | 1 | ||||
| -rw-r--r-- | src/scheme/test/Makefile | 33 | ||||
| -rw-r--r-- | src/scheme/test/ao_scheme_os.h | 53 | ||||
| -rw-r--r-- | src/scheme/test/ao_scheme_test.c | 188 | ||||
| -rw-r--r-- | src/scheme/test/ao_scheme_test.scheme | 175 | ||||
| -rwxr-xr-x | src/scheme/test/hanoi.scheme | 177 |
6 files changed, 0 insertions, 627 deletions
diff --git a/src/scheme/test/.gitignore b/src/scheme/test/.gitignore deleted file mode 100644 index 3622bc1d..00000000 --- a/src/scheme/test/.gitignore +++ /dev/null @@ -1 +0,0 @@ -ao-scheme diff --git a/src/scheme/test/Makefile b/src/scheme/test/Makefile deleted file mode 100644 index a8129217..00000000 --- a/src/scheme/test/Makefile +++ /dev/null @@ -1,33 +0,0 @@ -include ../Makefile-inc - -vpath %.o . -vpath %.c .. -vpath %.h .. -vpath %.scheme .. -vpath ao_scheme_make_const ../make-const - -SRCS=$(SCHEME_SRCS) ao_scheme_test.c -HDRS=$(SCHEME_HDRS) ao_scheme_const.h - -OBJS=$(SRCS:.c=.o) - -#PGFLAGS=-pg -no-pie -OFLAGS=-O3 -#DFLAGS=-O0 - -CFLAGS=$(DFLAGS) $(OFLAGS) $(PGFLAGS) -g -Wall -Wextra -I. -I.. -Wpointer-arith -Wmissing-declarations -Wformat=2 -Wstrict-prototypes -Wmissing-prototypes -Wnested-externs -Wbad-function-cast -Wold-style-definition -Wdeclaration-after-statement -Wunused -Wuninitialized -Wshadow -Wmissing-noreturn -Wmissing-format-attribute -Wredundant-decls -Wlogical-op -Werror=implicit -Werror=nonnull -Werror=init-self -Werror=main -Werror=missing-braces -Werror=sequence-point -Werror=return-type -Werror=trigraphs -Werror=array-bounds -Werror=write-strings -Werror=address -Werror=int-to-pointer-cast -Werror=pointer-to-int-cast - -ao-scheme: $(OBJS) - cc $(CFLAGS) -o $@ $(OBJS) -lm - ./ao-scheme ao_scheme_test.scheme - -$(OBJS): $(HDRS) - -ao_scheme_const.h: ao_scheme_make_const $(SCHEME_SCHEME) - $^ -o $@ -d GPIO - -clean:: - rm -f $(OBJS) ao-scheme ao_scheme_const.h - -install: ao-scheme - install -t $$HOME/bin $^ diff --git a/src/scheme/test/ao_scheme_os.h b/src/scheme/test/ao_scheme_os.h deleted file mode 100644 index 9836d534..00000000 --- a/src/scheme/test/ao_scheme_os.h +++ /dev/null @@ -1,53 +0,0 @@ -/* - * Copyright © 2016 Keith Packard <keithp@keithp.com> - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; version 2 of the License. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - * - * You should have received a copy of the GNU General Public License along - * with this program; if not, write to the Free Software Foundation, Inc., - * 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA. - */ - -#ifndef _AO_SCHEME_OS_H_ -#define _AO_SCHEME_OS_H_ - -#include <stdio.h> -#include <stdlib.h> -#include <time.h> - -#define AO_SCHEME_POOL_TOTAL 32768 - -static inline void -ao_scheme_abort(void) -{ - abort(); -} - -#define AO_SCHEME_JIFFIES_PER_SECOND 100 - -static inline void -ao_scheme_os_delay(int jiffies) -{ - struct timespec ts = { - .tv_sec = jiffies / AO_SCHEME_JIFFIES_PER_SECOND, - .tv_nsec = (jiffies % AO_SCHEME_JIFFIES_PER_SECOND) * (1000000000L / AO_SCHEME_JIFFIES_PER_SECOND) - }; - nanosleep(&ts, NULL); -} - -static inline int -ao_scheme_os_jiffy(void) -{ - struct timespec tp; - clock_gettime(CLOCK_MONOTONIC, &tp); - return tp.tv_sec * AO_SCHEME_JIFFIES_PER_SECOND + (tp.tv_nsec / (1000000000L / AO_SCHEME_JIFFIES_PER_SECOND)); -} - -#endif diff --git a/src/scheme/test/ao_scheme_test.c b/src/scheme/test/ao_scheme_test.c deleted file mode 100644 index 195b8b46..00000000 --- a/src/scheme/test/ao_scheme_test.c +++ /dev/null @@ -1,188 +0,0 @@ -/* - * Copyright © 2016 Keith Packard <keithp@keithp.com> - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#include "ao_scheme.h" -#include <stdio.h> -#include <unistd.h> -#include <getopt.h> - -static char save_file[] = "scheme.image"; - -int -ao_scheme_os_save(void) -{ - FILE *save = fopen(save_file, "w"); - - if (!save) { - perror(save_file); - return 0; - } - fwrite(ao_scheme_pool, 1, AO_SCHEME_POOL_TOTAL, save); - fclose(save); - return 1; -} - -int -ao_scheme_os_restore_save(struct ao_scheme_os_save *save, int offset) -{ - FILE *restore = fopen(save_file, "r"); - size_t ret; - - if (!restore) { - perror(save_file); - return 0; - } - fseek(restore, offset, SEEK_SET); - ret = fread(save, sizeof (struct ao_scheme_os_save), 1, restore); - fclose(restore); - if (ret != 1) - return 0; - return 1; -} - -int -ao_scheme_os_restore(void) -{ - FILE *restore = fopen(save_file, "r"); - size_t ret; - - if (!restore) { - perror(save_file); - return 0; - } - ret = fread(ao_scheme_pool, 1, AO_SCHEME_POOL_TOTAL, restore); - fclose(restore); - if (ret != AO_SCHEME_POOL_TOTAL) - return 0; - return 1; -} - -static const struct option options[] = { - { .name = "load", .has_arg = 1, .val = 'l' }, - { 0, 0, 0, 0 }, -}; - -static void usage(char *program) -{ - fprintf(stderr, "usage: %s [--load=<library> ...] <program ...>\n", program); -} - -static void -check_exit(ao_poly v) -{ - if (ao_scheme_exception & AO_SCHEME_EXIT) { - int ret; - - if (v == _ao_scheme_bool_true) - ret = 0; - else { - ret = 1; - if (ao_scheme_is_integer(v)) - ret = ao_scheme_poly_integer(v); - } - exit(ret); - } -} - -static void -run_file(char *name) -{ - FILE *in; - int c; - ao_poly v; - - in = fopen(name, "r"); - if (!in) { - perror(name); - exit(1); - } - c = getc(in); - if (c == '#') { - do { - c = getc(in); - } while (c != EOF && c != '\n'); - } else { - ungetc(c, in); - } - v = ao_scheme_read_eval_print(in, NULL, false); - fclose(in); - check_exit(v); -} - -int -main (int argc, char **argv) -{ - int o; - - while ((o = getopt_long(argc, argv, "?l:", options, NULL)) != -1) { - switch (o) { - case '?': - usage(argv[0]); - exit(0); - case 'l': -#ifdef AO_SCHEME_FEATURE_POSIX - ao_scheme_set_argv(&argv[argc]); -#endif - run_file(optarg); - break; - default: - usage(argv[0]); - exit(1); - } - } -#ifdef AO_SCHEME_FEATURE_POSIX - ao_scheme_set_argv(argv + optind); -#endif - if (argv[optind]) { - run_file(argv[optind]); - } else { - ao_poly v; - v = ao_scheme_read_eval_print(stdin, stdout, true); - check_exit(v); - putchar('\n'); - } - -#ifdef DBG_MEM_STATS - printf ("collects: full: %lu incremental %lu\n", - ao_scheme_collects[AO_SCHEME_COLLECT_FULL], - ao_scheme_collects[AO_SCHEME_COLLECT_INCREMENTAL]); - - printf ("freed: full %lu incremental %lu\n", - ao_scheme_freed[AO_SCHEME_COLLECT_FULL], - ao_scheme_freed[AO_SCHEME_COLLECT_INCREMENTAL]); - - printf("loops: full %lu incremental %lu\n", - ao_scheme_loops[AO_SCHEME_COLLECT_FULL], - ao_scheme_loops[AO_SCHEME_COLLECT_INCREMENTAL]); - - printf("loops per collect: full %f incremental %f\n", - (double) ao_scheme_loops[AO_SCHEME_COLLECT_FULL] / - (double) ao_scheme_collects[AO_SCHEME_COLLECT_FULL], - (double) ao_scheme_loops[AO_SCHEME_COLLECT_INCREMENTAL] / - (double) ao_scheme_collects[AO_SCHEME_COLLECT_INCREMENTAL]); - - printf("freed per collect: full %f incremental %f\n", - (double) ao_scheme_freed[AO_SCHEME_COLLECT_FULL] / - (double) ao_scheme_collects[AO_SCHEME_COLLECT_FULL], - (double) ao_scheme_freed[AO_SCHEME_COLLECT_INCREMENTAL] / - (double) ao_scheme_collects[AO_SCHEME_COLLECT_INCREMENTAL]); - - printf("freed per loop: full %f incremental %f\n", - (double) ao_scheme_freed[AO_SCHEME_COLLECT_FULL] / - (double) ao_scheme_loops[AO_SCHEME_COLLECT_FULL], - (double) ao_scheme_freed[AO_SCHEME_COLLECT_INCREMENTAL] / - (double) ao_scheme_loops[AO_SCHEME_COLLECT_INCREMENTAL]); -#endif - return 0; -} diff --git a/src/scheme/test/ao_scheme_test.scheme b/src/scheme/test/ao_scheme_test.scheme deleted file mode 100644 index 41aaeda1..00000000 --- a/src/scheme/test/ao_scheme_test.scheme +++ /dev/null @@ -1,175 +0,0 @@ - ; Basic syntax tests - -(define _assert-eq_ - (macro (a b) - (list cond - (list (list eq? a b) - ) - (list 'else - (list display "failed: ") - (list write (list quote a)) - (list newline) - (list exit 1) - ) - ) - ) - ) - -(define _assert-equal_ - (macro (a b) - (list cond - (list (list equal? a b) - ) - (list 'else - (list display "failed: ") - (list write (list quote a)) - (list newline) - (list exit 1) - ) - ) - ) - ) - -(_assert-eq_ (or #f #t) #t) -(_assert-eq_ (and #t #f) #f) -(_assert-eq_ (if (> 3 2) 'yes) 'yes) -(_assert-eq_ (if (> 3 2) 'yes 'no) 'yes) -(_assert-eq_ (if (> 2 3) 'no 'yes) 'yes) -(_assert-eq_ (if (> 2 3) 'no) #f) - -(_assert-eq_ (letrec ((a 1) (b a)) (+ a b)) 2) - -(_assert-eq_ (equal? '(a b c) '(a b c)) #t) -(_assert-eq_ (equal? '(a b c) '(a b b)) #f) - -(_assert-equal_ (cdar '((1 2) (3 4))) '(2)) - -(_assert-equal_ (cddr '(1 2 3)) '(3)) - -(_assert-equal_ (caddr '(1 2 3 4)) 3) - -(_assert-equal_ (member '(2) '((1) (2) (3))) '((2) (3))) -(_assert-equal_ (member '(4) '((1) (2) (3))) #f) - -(_assert-equal_ (memq 2 '(1 2 3)) '(2 3)) -(_assert-equal_ (memq 4 '(1 2 3)) #f) -(_assert-equal_ (memq '(2) '((1) (2) (3))) #f) - -(_assert-equal_ (assq 'a '((a 1) (b 2) (c 3))) '(a 1)) -(_assert-equal_ (assv 'b '((a 1) (b 2) (c 3))) '(b 2)) -(_assert-equal_ (assoc '(c) '((a 1) (b 2) ((c) 3))) '((c) 3)) - -(_assert-equal_ (map cadr '((a b) (d e) (g h))) '(b e h)) - -(_assert-equal_ `(hello ,(+ 1 2) ,@(list 1 2 3) `foo) '(hello 3 1 2 3 (quasiquote foo))) - - ; Advanced syntax tests - -(_assert-eq_ (equal? '(a b c) '(a b c)) #t) -(_assert-eq_ (equal? '(a b c) '(a b b)) #f) -(_assert-eq_ (equal? #(1 2 3) #(1 2 3)) #t) -(_assert-eq_ (equal? #(1 2 3) #(4 5 6)) #f) -(_assert-equal_ `(hello ,(+ 1 2) ,@(list 1 2 3) `foo) '(hello 3 1 2 3 (quasiquote foo))) -(_assert-equal_ (let ((x 1) (y)) (set! y 2) (+ x y)) 3) -(_assert-equal_ (when #t (+ 1 2)) 3) -(_assert-equal_ (when #f (+ 1 2)) #f) -(_assert-equal_ (unless #f (+ 2 3)) 5) -(_assert-equal_ (unless #t (+ 2 3)) #f) -(_assert-equal_ (cdar '((1 2) (3 4))) '(2)) -(_assert-equal_ (cddr '(1 2 3)) '(3)) -(_assert-equal_ (caddr '(1 2 3 4)) 3) -(_assert-equal_ (reverse '(1 2 3)) '(3 2 1)) -(_assert-equal_ (make-list 10 'a) '(a a a a a a a a a a)) -(_assert-equal_ (make-list 10) '(#f #f #f #f #f #f #f #f #f #f)) -(_assert-equal_ (let ((a 0)) - (for-each (lambda (b) (set! a (+ a b))) '(1 2 3)) - a - ) - 6) -(_assert-equal_ (call-with-current-continuation - (lambda (exit) - (for-each (lambda (x) - (if (negative? x) - (exit x))) - '(54 0 37 -3 245 19)) - ) - ) - -3) -(_assert-equal_ (case 1 (1 "one") (2 "two") (3 => (lambda (x) "three")) (12 "twelve") (else "else")) "one") -(_assert-equal_ (case 2 (1 "one") (2 "two") (3 => (lambda (x) "three")) (12 "twelve") (else "else")) "two") -(_assert-equal_ (case 3 (1 "one") (2 "two") (3 => (lambda (x) "three")) (12 "twelve") (else "else")) "three") -(_assert-equal_ (case 4 (1 "one") (2 "two") (3 => (lambda (x) "three")) (12 "twelve") (else "else")) "else") -(_assert-equal_ (case 12 (1 "one") (2 "two") (3 => (lambda (x) "three")) (12 "twelve") (else "else")) "twelve") -(_assert-equal_ (do ((x 1 (+ x 1)) - (y 0) - ) - ((= x 10) y) - (set! y (+ y x)) - ) - 45) - -(_assert-equal_ (do ((vec (make-vector 5)) - (i 0 (+ i 1))) - ((= i 5) vec) - (vector-set! vec i i)) - #(0 1 2 3 4)) - - ; vector tests - -(_assert-equal_ (vector->string #(#\a #\b #\c) 0 2) "ab") -(_assert-equal_ (string->vector "hello" 0 2) #(#\h #\e)) -(_assert-equal_ (vector-copy! (make-vector 10 "t") 0 (make-vector 5 "f") 0 5) #("f" "f" "f" "f" "f" "t" "t" "t" "t" "t")) -(_assert-equal_ (vector-copy #(1 2 3) 0 3) #(1 2 3)) -(_assert-equal_ (vector-append #(1 2 3) #(4 5 6) #(7 8 9)) #(1 2 3 4 5 6 7 8 9)) -(_assert-equal_ (vector-fill! (make-vector 3) #t 1 2) #(#f #t #f)) -(_assert-equal_ (vector-map + #(1 2 3) #(4 5 6)) #(5 7 9)) - - ; string tests - -(_assert-equal_ (string #\a #\b #\c) "abc") -(_assert-equal_ (string-map (lambda (x) (+ 1 x)) "HAL") "IBM") -(_assert-equal_ (string-copy! (make-string 10) 0 "hello" 0 5) "hello ") -(_assert-equal_ (string-copy! (make-string 10) 1 "hello" 0 5) " hello ") -(_assert-equal_ (string-copy! (make-string 10) 0 "hello" 0 5) "hello ") -(_assert-equal_ (string-copy "hello" 0 1) "h") -(_assert-equal_ (string-copy "hello" 1) "ello") -(_assert-equal_ (string-copy "hello") "hello") -(_assert-equal_ (string-fill! (make-string 10) #\a) "aaaaaaaaaa") -(_assert-equal_ (string-fill! (make-string 10) #\a 1 2) " a ") -;(_assert-equal_ (string-for-each write-char "IBM\n") #t) - - ; char tests - -(_assert-equal_ (char? #\q) #t) -(_assert-equal_ (char? "h") #f) -(_assert-equal_ (char-upper-case? #\a) #f) -(_assert-equal_ (char-upper-case? #\B) #t) -(_assert-equal_ (char-upper-case? #\0) #f) -(_assert-equal_ (char-upper-case? #\space) #f) -(_assert-equal_ (char-lower-case? #\a) #t) -(_assert-equal_ (char-lower-case? #\B) #f) -(_assert-equal_ (char-lower-case? #\0) #f) -(_assert-equal_ (char-lower-case? #\space) #f) -(_assert-equal_ (char-alphabetic? #\a) #t) -(_assert-equal_ (char-alphabetic? #\B) #t) -(_assert-equal_ (char-alphabetic? #\0) #f) -(_assert-equal_ (char-alphabetic? #\space) #f) -(_assert-equal_ (char-numeric? #\a) #f) -(_assert-equal_ (char-numeric? #\B) #f) -(_assert-equal_ (char-numeric? #\0) #t) -(_assert-equal_ (char-numeric? #\space) #f) -(_assert-equal_ (char-whitespace? #\a) #f) -(_assert-equal_ (char-whitespace? #\B) #f) -(_assert-equal_ (char-whitespace? #\0) #f) -(_assert-equal_ (char-whitespace? #\space) #t) -(_assert-equal_ (char-upcase #\a) #\A) -(_assert-equal_ (char-upcase #\B) #\B) -(_assert-equal_ (char-upcase #\0) #\0) -(_assert-equal_ (char-upcase #\space) #\space) -(_assert-equal_ (char-downcase #\a) #\a) -(_assert-equal_ (char-downcase #\B) #\b) -(_assert-equal_ (char-downcase #\0) #\0) -(_assert-equal_ (char-downcase #\space) #\space) -(_assert-equal_ (digit-value #\1) 1) -(_assert-equal_ (digit-value #\a) #f) - diff --git a/src/scheme/test/hanoi.scheme b/src/scheme/test/hanoi.scheme deleted file mode 100755 index 0180de1e..00000000 --- a/src/scheme/test/hanoi.scheme +++ /dev/null @@ -1,177 +0,0 @@ -#!/home/keithp/bin/ao-scheme -; -; Towers of Hanoi -; -; Copyright © 2016 Keith Packard <keithp@keithp.com> -; -; This program is free software; you can redistribute it and/or modify -; it under the terms of the GNU General Public License as published by -; the Free Software Foundation, either version 2 of the License, or -; (at your option) any later version. -; -; This program is distributed in the hope that it will be useful, but -; WITHOUT ANY WARRANTY; without even the implied warranty of -; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -; General Public License for more details. -; - - ; ANSI control sequences - -(define (move-to col row) - (for-each display (list "\033[" row ";" col "H")) - ) - -(define (clear) - (display "\033[2J") - ) - -(define (display-string x y str) - (move-to x y) - (display str) - ) - -(define (make-piece num max) - ; A piece for position 'num' - ; is num + 1 + num stars - ; centered in a field of max * - ; 2 + 1 characters with spaces - ; on either side. This way, - ; every piece is the same - ; number of characters - - (define (chars n c) - (if (zero? n) "" - (+ c (chars (- n 1) c)) - ) - ) - (+ (chars (- max num 1) " ") - (chars (+ (* num 2) 1) "*") - (chars (- max num 1) " ") - ) - ) - -(define (make-pieces max) - ; Make a list of numbers from 0 to max-1 - (define (nums cur max) - (if (= cur max) () - (cons cur (nums (+ cur 1) max)) - ) - ) - ; Create a list of pieces - - (map (lambda (x) (make-piece x max)) (nums 0 max)) - ) - - ; Here's all of the towers of pieces - ; This is generated when the program is run - -(define towers ()) - - ; position of the bottom of - ; the stacks set at runtime -(define bottom-y 0) -(define left-x 0) - -(define move-delay 25) - - ; Display one tower, clearing any - ; space above it - -(define (display-tower x y clear tower) - (cond ((= 0 clear) - (cond ((not (null? tower)) - (display-string x y (car tower)) - (display-tower x (+ y 1) 0 (cdr tower)) - ) - ) - ) - (else - (display-string x y " ") - (display-tower x (+ y 1) (- clear 1) tower) - ) - ) - ) - - ; Position of the top of the tower on the screen - ; Shorter towers start further down the screen - -(define (tower-pos tower) - (- bottom-y (length tower)) - ) - - ; Display all of the towers, spaced 20 columns apart - -(define (display-towers x towers) - (cond ((not (null? towers)) - (display-tower x 0 (tower-pos (car towers)) (car towers)) - (display-towers (+ x 20) (cdr towers))) - ) - ) - - ; Display all of the towers, then move the cursor - ; out of the way and flush the output - -(define (display-hanoi) - (display-towers left-x towers) - (move-to 1 23) - (flush-output) - (delay move-delay) - ) - - ; Reset towers to the starting state, with - ; all of the pieces in the first tower and the - ; other two empty - -(define (reset-towers len) - (set! towers (list (make-pieces len) () ())) - (set! bottom-y (+ len 3)) - ) - - ; Move a piece from the top of one tower - ; to the top of another - -(define (move-piece from to) - - ; references to the cons holding the two towers - - (define from-tower (list-tail towers from)) - (define to-tower (list-tail towers to)) - - ; stick the car of from-tower onto to-tower - - (set-car! to-tower (cons (caar from-tower) (car to-tower))) - - ; remove the car of from-tower - - (set-car! from-tower (cdar from-tower)) - ) - - ; The implementation of the game - -(define (_hanoi n from to use) - (cond ((= 1 n) - (move-piece from to) - (display-hanoi) - ) - (else - (_hanoi (- n 1) from use to) - (_hanoi 1 from to use) - (_hanoi (- n 1) use to from) - ) - ) - ) - - ; A pretty interface which - ; resets the state of the game, - ; clears the screen and runs - ; the program - -(define (hanoi len) - (reset-towers len) - (clear) - (display-hanoi) - (_hanoi len 0 1 2) - #t - ) - -(unless (null? (command-line)) (hanoi 6)) |