From: Bdale Garbee Date: Mon, 11 Dec 2017 17:16:24 +0000 (-0700) Subject: Merge branch 'master' of ssh://git.gag.com/scm/git/fw/altos X-Git-Tag: 1.8.3~1^2~21 X-Git-Url: https://git.gag.com/?p=fw%2Faltos;a=commitdiff_plain;h=d1d98e408311c5ba18138a18f4c88448e4254626;hp=2f8fce1cf6ce4bd12a836cc8ee15f4edbc95c95e Merge branch 'master' of ssh://git.gag.com/scm/git/fw/altos --- diff --git a/altoslib/AltosTelemetryMegaData.java b/altoslib/AltosTelemetryMegaData.java index 7ef9c637..f5961c8c 100644 --- a/altoslib/AltosTelemetryMegaData.java +++ b/altoslib/AltosTelemetryMegaData.java @@ -24,7 +24,9 @@ public class AltosTelemetryMegaData extends AltosTelemetryStandard { int v_batt() { return int16(6); } int v_pyro() { return int16(8); } - int sense(int i) { int v = uint8(10+i); return v << 4 | v >> 8; } + + /* pyro sense values are sent in 8 bits, expand to 12 bits */ + int sense(int i) { int v = uint8(10+i); return (v << 4) | (v >> 4); } int ground_pres() { return int32(16); } int ground_accel() { return int16(20); } diff --git a/src/scheme/Makefile b/src/scheme/Makefile index ea94c1c0..dc36dde1 100644 --- a/src/scheme/Makefile +++ b/src/scheme/Makefile @@ -5,8 +5,8 @@ clean: +cd test && make clean rm -f ao_scheme_const.h ao_scheme_builtin.h -ao_scheme_const.h: ao_scheme_const.lisp make-const/ao_scheme_make_const - make-const/ao_scheme_make_const -o $@ ao_scheme_const.lisp +ao_scheme_const.h: ao_scheme_const.scheme make-const/ao_scheme_make_const + make-const/ao_scheme_make_const -o $@ ao_scheme_const.scheme ao_scheme_builtin.h: ao_scheme_make_builtin ao_scheme_builtin.txt nickle ao_scheme_make_builtin ao_scheme_builtin.txt > $@ diff --git a/src/scheme/Makefile-inc b/src/scheme/Makefile-inc index d23ee3d7..1a080a4e 100644 --- a/src/scheme/Makefile-inc +++ b/src/scheme/Makefile-inc @@ -15,7 +15,8 @@ SCHEME_SRCS=\ ao_scheme_rep.c \ ao_scheme_save.c \ ao_scheme_stack.c \ - ao_scheme_error.c + ao_scheme_error.c \ + ao_scheme_vector.c SCHEME_HDRS=\ ao_scheme.h \ diff --git a/src/scheme/README b/src/scheme/README index 98932b44..a18457fd 100644 --- a/src/scheme/README +++ b/src/scheme/README @@ -5,6 +5,6 @@ This follows the R7RS with the following known exceptions: * No dynamic-wind or exceptions * No environments * No ports -* No syntax-rules; (have classic macros) +* No syntax-rules * No record types * No libraries diff --git a/src/scheme/ao_scheme.h b/src/scheme/ao_scheme.h index 4589f8a5..89616617 100644 --- a/src/scheme/ao_scheme.h +++ b/src/scheme/ao_scheme.h @@ -31,7 +31,7 @@ typedef uint16_t ao_poly; typedef int16_t ao_signed_poly; -#ifdef AO_SCHEME_SAVE +#if AO_SCHEME_SAVE struct ao_scheme_os_save { ao_poly atoms; @@ -77,6 +77,9 @@ extern uint8_t ao_scheme_const[AO_SCHEME_POOL_CONST] __attribute__((aligned(4))) #ifndef AO_SCHEME_POOL #define AO_SCHEME_POOL 3072 #endif +#ifndef AO_SCHEME_POOL_EXTRA +#define AO_SCHEME_POOL_EXTRA 0 +#endif extern uint8_t ao_scheme_pool[AO_SCHEME_POOL + AO_SCHEME_POOL_EXTRA] __attribute__((aligned(4))); #endif @@ -101,7 +104,8 @@ extern uint8_t ao_scheme_pool[AO_SCHEME_POOL + AO_SCHEME_POOL_EXTRA] __attribut #define AO_SCHEME_BOOL 10 #define AO_SCHEME_BIGINT 11 #define AO_SCHEME_FLOAT 12 -#define AO_SCHEME_NUM_TYPE 13 +#define AO_SCHEME_VECTOR 13 +#define AO_SCHEME_NUM_TYPE 14 /* Leave two bits for types to use as they please */ #define AO_SCHEME_OTHER_TYPE_MASK 0x3f @@ -189,6 +193,13 @@ struct ao_scheme_float { float value; }; +struct ao_scheme_vector { + uint8_t type; + uint8_t pad1; + uint16_t length; + ao_poly vals[]; +}; + #if __BYTE_ORDER == __LITTLE_ENDIAN static inline uint32_t ao_scheme_int_bigint(int32_t i) { @@ -497,6 +508,18 @@ ao_scheme_poly_float(ao_poly poly) float ao_scheme_poly_number(ao_poly p); +static inline ao_poly +ao_scheme_vector_poly(struct ao_scheme_vector *v) +{ + return ao_scheme_poly(v, AO_SCHEME_OTHER); +} + +static inline struct ao_scheme_vector * +ao_scheme_poly_vector(ao_poly poly) +{ + return ao_scheme_ref(poly); +} + /* memory functions */ extern int ao_scheme_collects[2]; @@ -677,6 +700,32 @@ void ao_scheme_bigint_write(ao_poly i); extern const struct ao_scheme_type ao_scheme_bigint_type; + +/* vector */ + +void +ao_scheme_vector_write(ao_poly v); + +void +ao_scheme_vector_display(ao_poly v); + +struct ao_scheme_vector * +ao_scheme_vector_alloc(uint16_t length, ao_poly fill); + +ao_poly +ao_scheme_vector_get(ao_poly v, ao_poly i); + +ao_poly +ao_scheme_vector_set(ao_poly v, ao_poly i, ao_poly p); + +struct ao_scheme_vector * +ao_scheme_list_to_vector(struct ao_scheme_cons *cons); + +struct ao_scheme_cons * +ao_scheme_vector_to_list(struct ao_scheme_vector *vector); + +extern const struct ao_scheme_type ao_scheme_vector_type; + /* prim */ void ao_scheme_poly_write(ao_poly p); @@ -745,6 +794,7 @@ char * ao_scheme_args_name(uint8_t args); /* read */ +extern int ao_scheme_read_list; extern struct ao_scheme_cons *ao_scheme_read_cons; extern struct ao_scheme_cons *ao_scheme_read_cons_tail; extern struct ao_scheme_cons *ao_scheme_read_stack; diff --git a/src/scheme/ao_scheme_builtin.c b/src/scheme/ao_scheme_builtin.c index 49f218f6..ae96df7f 100644 --- a/src/scheme/ao_scheme_builtin.c +++ b/src/scheme/ao_scheme_builtin.c @@ -267,7 +267,6 @@ ao_scheme_do_write(struct ao_scheme_cons *cons) if (cons) printf(" "); } - printf("\n"); return _ao_scheme_bool_true; } @@ -636,7 +635,7 @@ ao_scheme_do_collect(struct ao_scheme_cons *cons) int free; (void) cons; free = ao_scheme_collect(AO_SCHEME_COLLECT_FULL); - return ao_scheme_int_poly(free); + return ao_scheme_integer_poly(free); } ao_poly @@ -751,7 +750,7 @@ ao_poly ao_scheme_do_listp(struct ao_scheme_cons *cons) { ao_poly v; - if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) + if (!ao_scheme_check_argc(_ao_scheme_atom_list3f, cons, 1, 1)) return AO_SCHEME_NIL; v = ao_scheme_arg(cons, 0); for (;;) { @@ -864,5 +863,67 @@ ao_scheme_do_jiffies_per_second(struct ao_scheme_cons *cons) return (ao_scheme_int_poly(AO_SCHEME_JIFFIES_PER_SECOND)); } +ao_poly +ao_scheme_do_vector(struct ao_scheme_cons *cons) +{ + return ao_scheme_vector_poly(ao_scheme_list_to_vector(cons)); +} + +ao_poly +ao_scheme_do_vector_ref(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_vector2dref, cons, 2, 2)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_argt(_ao_scheme_atom_vector2dref, cons, 0, AO_SCHEME_VECTOR, 0)) + return AO_SCHEME_NIL; + return ao_scheme_vector_get(ao_scheme_arg(cons, 0), ao_scheme_arg(cons, 1)); +} + +ao_poly +ao_scheme_do_vector_set(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_vector2dset21, cons, 3, 3)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_argt(_ao_scheme_atom_vector2dset21, cons, 0, AO_SCHEME_VECTOR, 0)) + return AO_SCHEME_NIL; + return ao_scheme_vector_set(ao_scheme_arg(cons, 0), ao_scheme_arg(cons, 1), ao_scheme_arg(cons, 2)); +} + +ao_poly +ao_scheme_do_list_to_vector(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_list2d3evector, cons, 1, 1)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_argt(_ao_scheme_atom_list2d3evector, cons, 0, AO_SCHEME_CONS, 0)) + return AO_SCHEME_NIL; + return ao_scheme_vector_poly(ao_scheme_list_to_vector(ao_scheme_poly_cons(ao_scheme_arg(cons, 0)))); +} + +ao_poly +ao_scheme_do_vector_to_list(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_vector2d3elist, cons, 1, 1)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_argt(_ao_scheme_atom_vector2d3elist, cons, 0, AO_SCHEME_VECTOR, 0)) + return AO_SCHEME_NIL; + return ao_scheme_cons_poly(ao_scheme_vector_to_list(ao_scheme_poly_vector(ao_scheme_arg(cons, 0)))); +} + +ao_poly +ao_scheme_do_vector_length(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_vector2d3elist, cons, 1, 1)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_argt(_ao_scheme_atom_vector2d3elist, cons, 0, AO_SCHEME_VECTOR, 0)) + return AO_SCHEME_NIL; + return ao_scheme_integer_poly(ao_scheme_poly_vector(ao_scheme_arg(cons, 0))->length); +} + +ao_poly +ao_scheme_do_vectorp(struct ao_scheme_cons *cons) +{ + return ao_scheme_do_typep(AO_SCHEME_VECTOR, cons); +} + #define AO_SCHEME_BUILTIN_FUNCS #include "ao_scheme_builtin.h" diff --git a/src/scheme/ao_scheme_builtin.txt b/src/scheme/ao_scheme_builtin.txt index cb65e252..e7b3d75c 100644 --- a/src/scheme/ao_scheme_builtin.txt +++ b/src/scheme/ao_scheme_builtin.txt @@ -66,3 +66,10 @@ f_lambda finitep finite? f_lambda infinitep infinite? f_lambda inexactp inexact? f_lambda sqrt +f_lambda vector_ref vector-ref +f_lambda vector_set vector-set! +f_lambda vector +f_lambda list_to_vector list->vector +f_lambda vector_to_list vector->list +f_lambda vector_length vector-length +f_lambda vectorp vector? diff --git a/src/scheme/ao_scheme_cons.c b/src/scheme/ao_scheme_cons.c index 03dad956..21ee10cc 100644 --- a/src/scheme/ao_scheme_cons.c +++ b/src/scheme/ao_scheme_cons.c @@ -195,7 +195,7 @@ ao_scheme_cons_length(struct ao_scheme_cons *cons) int len = 0; while (cons) { len++; - cons = ao_scheme_poly_cons(cons->cdr); + cons = ao_scheme_cons_cdr(cons); } return len; } diff --git a/src/scheme/ao_scheme_const.lisp b/src/scheme/ao_scheme_const.lisp deleted file mode 100644 index 422bdd63..00000000 --- a/src/scheme/ao_scheme_const.lisp +++ /dev/null @@ -1,813 +0,0 @@ -; -; Copyright © 2016 Keith Packard -; -; 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. -; -; Lisp code placed in ROM - - ; return a list containing all of the arguments -(def (quote list) (lambda l l)) - -(def (quote def!) - (macro (name value) - (list - def - (list quote name) - value) - ) - ) - -(begin - (def! append - (lambda args - (def! append-list - (lambda (a b) - (cond ((null? a) b) - (else (cons (car a) (append-list (cdr a) b))) - ) - ) - ) - - (def! append-lists - (lambda (lists) - (cond ((null? lists) lists) - ((null? (cdr lists)) (car lists)) - (else (append-list (car lists) (append-lists (cdr lists)))) - ) - ) - ) - (append-lists args) - ) - ) - 'append) - -(append '(a b c) '(d e f) '(g h i)) - - ; boolean operators - -(begin - (def! or - (macro l - (def! _or - (lambda (l) - (cond ((null? l) #f) - ((null? (cdr l)) - (car l)) - (else - (list - cond - (list - (car l)) - (list - 'else - (_or (cdr l)) - ) - ) - ) - ) - ) - ) - (_or l))) - 'or) - - ; execute to resolve macros - -(or #f #t) - -(begin - (def! and - (macro l - (def! _and - (lambda (l) - (cond ((null? l) #t) - ((null? (cdr l)) - (car l)) - (else - (list - cond - (list - (car l) - (_and (cdr l)) - ) - ) - ) - ) - ) - ) - (_and l) - ) - ) - 'and) - - ; execute to resolve macros - -(and #t #f) - -(begin - (def! quasiquote - (macro (x) - (def! constant? - ; A constant value is either a pair starting with quote, - ; or anything which is neither a pair nor a symbol - - (lambda (exp) - (cond ((pair? exp) - (eq? (car exp) 'quote) - ) - (else - (not (symbol? exp)) - ) - ) - ) - ) - (def! combine-skeletons - (lambda (left right exp) - (cond - ((and (constant? left) (constant? right)) - (cond ((and (eqv? (eval left) (car exp)) - (eqv? (eval right) (cdr exp))) - (list 'quote exp) - ) - (else - (list 'quote (cons (eval left) (eval right))) - ) - ) - ) - ((null? right) - (list 'list left) - ) - ((and (pair? right) (eq? (car right) 'list)) - (cons 'list (cons left (cdr right))) - ) - (else - (list 'cons left right) - ) - ) - ) - ) - - (def! expand-quasiquote - (lambda (exp nesting) - (cond - - ; non cons -- constants - ; themselves, others are - ; quoted - - ((not (pair? exp)) - (cond ((constant? exp) - exp - ) - (else - (list 'quote exp) - ) - ) - ) - - ; check for an unquote exp and - ; add the param unquoted - - ((and (eq? (car exp) 'unquote) (= (length exp) 2)) - (cond ((= nesting 0) - (car (cdr exp)) - ) - (else - (combine-skeletons ''unquote - (expand-quasiquote (cdr exp) (- nesting 1)) - exp)) - ) - ) - - ; nested quasi-quote -- - ; construct the right - ; expression - - ((and (eq? (car exp) 'quasiquote) (= (length exp) 2)) - (combine-skeletons ''quasiquote - (expand-quasiquote (cdr exp) (+ nesting 1)) - exp)) - - ; check for an - ; unquote-splicing member, - ; compute the expansion of the - ; value and append the rest of - ; the quasiquote result to it - - ((and (pair? (car exp)) - (eq? (car (car exp)) 'unquote-splicing) - (= (length (car exp)) 2)) - (cond ((= nesting 0) - (list 'append (car (cdr (car exp))) - (expand-quasiquote (cdr exp) nesting)) - ) - (else - (combine-skeletons (expand-quasiquote (car exp) (- nesting 1)) - (expand-quasiquote (cdr exp) nesting) - exp)) - ) - ) - - ; for other lists, just glue - ; the expansion of the first - ; element to the expansion of - ; the rest of the list - - (else (combine-skeletons (expand-quasiquote (car exp) nesting) - (expand-quasiquote (cdr exp) nesting) - exp) - ) - ) - ) - ) - (def! result (expand-quasiquote x 0)) - result - ) - ) - 'quasiquote) - - ; - ; Define a variable without returning the value - ; Useful when defining functions to avoid - ; having lots of output generated. - ; - ; Also accepts the alternate - ; form for defining lambdas of - ; (define (name x y z) sexprs ...) - ; - -(begin - (def! define - (macro (first . rest) - ; check for alternate lambda definition form - - (cond ((list? first) - (set! rest - (append - (list - 'lambda - (cdr first)) - rest)) - (set! first (car first)) - ) - (else - (set! rest (car rest)) - ) - ) - (def! result `(,begin - (,def (,quote ,first) ,rest) - (,quote ,first)) - ) - result - ) - ) - 'define - ) - - ; basic list accessors - -(define (caar l) (car (car l))) - -(define (cadr l) (car (cdr l))) - -(define (cdar l) (cdr (car l))) - -(define (caddr l) (car (cdr (cdr l)))) - - ; (if ) - ; (if 3 2) 'yes) -(if (> 3 2) 'yes 'no) -(if (> 2 3) 'no 'yes) -(if (> 2 3) 'no) - - ; simple math operators - -(define zero? (macro (value) `(eq? ,value 0))) - -(zero? 1) -(zero? 0) -(zero? "hello") - -(define positive? (macro (value) `(> ,value 0))) - -(positive? 12) -(positive? -12) - -(define negative? (macro (value) `(< ,value 0))) - -(negative? 12) -(negative? -12) - -(define (abs x) (if (>= x 0) x (- x))) - -(abs 12) -(abs -12) - -(define max (lambda (first . rest) - (while (not (null? rest)) - (cond ((< first (car rest)) - (set! first (car rest))) - ) - (set! rest (cdr rest)) - ) - first) - ) - -(max 1 2 3) -(max 3 2 1) - -(define min (lambda (first . rest) - (while (not (null? rest)) - (cond ((> first (car rest)) - (set! first (car rest))) - ) - (set! rest (cdr rest)) - ) - first) - ) - -(min 1 2 3) -(min 3 2 1) - -(define (even? x) (zero? (% x 2))) - -(even? 2) -(even? -2) -(even? 3) -(even? -1) - -(define (odd? x) (not (even? x))) - -(odd? 2) -(odd? -2) -(odd? 3) -(odd? -1) - - -(define (list-tail x k) - (if (zero? k) - x - (list-tail (cdr x (- k 1))) - ) - ) - -(define (list-ref x k) - (car (list-tail x k)) - ) - - ; define a set of local - ; variables all at once and - ; then evaluate a list of - ; sexprs - ; - ; (let (var-defines) sexprs) - ; - ; where var-defines are either - ; - ; (name value) - ; - ; or - ; - ; (name) - ; - ; e.g. - ; - ; (let ((x 1) (y)) (set! y (+ x 1)) y) - -(define let - (macro (vars . exprs) - (define (make-names vars) - (cond ((not (null? vars)) - (cons (car (car vars)) - (make-names (cdr vars)))) - (else ()) - ) - ) - - ; the parameters to the lambda is a list - ; of nils of the right length - - (define (make-vals vars) - (cond ((not (null? vars)) - (cons (cond ((null? (cdr (car vars))) ()) - (else - (car (cdr (car vars)))) - ) - (make-vals (cdr vars)))) - (else ()) - ) - ) - ; prepend the set operations - ; to the expressions - - ; build the lambda. - - `((lambda ,(make-names vars) ,@exprs) ,@(make-vals vars)) - ) - ) - - -(let ((x 1) (y)) (set! y 2) (+ x y)) - - ; define a set of local - ; variables one at a time and - ; then evaluate a list of - ; sexprs - ; - ; (let* (var-defines) sexprs) - ; - ; where var-defines are either - ; - ; (name value) - ; - ; or - ; - ; (name) - ; - ; e.g. - ; - ; (let* ((x 1) (y)) (set! y (+ x 1)) y) - -(define let* - (macro (vars . exprs) - - ; - ; make the list of names in the let - ; - - (define (make-names vars) - (cond ((not (null? vars)) - (cons (car (car vars)) - (make-names (cdr vars)))) - (else ()) - ) - ) - - ; the set of expressions is - ; the list of set expressions - ; pre-pended to the - ; expressions to evaluate - - (define (make-exprs vars exprs) - (cond ((null? vars) exprs) - (else - (cons - (list set - (list quote - (car (car vars)) - ) - (cond ((null? (cdr (car vars))) ()) - (else (cadr (car vars)))) - ) - (make-exprs (cdr vars) exprs) - ) - ) - ) - ) - - ; the parameters to the lambda is a list - ; of nils of the right length - - (define (make-nils vars) - (cond ((null? vars) ()) - (else (cons () (make-nils (cdr vars)))) - ) - ) - ; build the lambda. - - `((lambda ,(make-names vars) ,@(make-exprs vars exprs)) ,@(make-nils vars)) - ) - ) - -(let* ((x 1) (y x)) (+ x y)) - -(define when (macro (test . l) `(cond (,test ,@l)))) - -(when #t (write 'when)) - -(define unless (macro (test . l) `(cond ((not ,test) ,@l)))) - -(unless #f (write 'unless)) - -(define (reverse list) - (let ((result ())) - (while (not (null? list)) - (set! result (cons (car list) result)) - (set! list (cdr list)) - ) - result) - ) - -(reverse '(1 2 3)) - -(define (list-tail x k) - (if (zero? k) - x - (list-tail (cdr x) (- k 1)))) - -(list-tail '(1 2 3) 2) - -(define (list-ref x k) (car (list-tail x k))) - -(list-ref '(1 2 3) 2) - - ; recursive equality - -(define (equal? a b) - (cond ((eq? a b) #t) - ((and (pair? a) (pair? b)) - (and (equal? (car a) (car b)) - (equal? (cdr a) (cdr b))) - ) - (else #f) - ) - ) - -(equal? '(a b c) '(a b c)) -(equal? '(a b c) '(a b b)) - -(define member (lambda (obj list . test?) - (cond ((null? list) - #f - ) - (else - (if (null? test?) (set! test? equal?) (set! test? (car test?))) - (if (test? obj (car list)) - list - (member obj (cdr list) test?)) - ) - ) - ) - ) - -(member '(2) '((1) (2) (3))) - -(member '(4) '((1) (2) (3))) - -(define (memq obj list) (member obj list eq?)) - -(memq 2 '(1 2 3)) - -(memq 4 '(1 2 3)) - -(memq '(2) '((1) (2) (3))) - -(define (memv obj list) (member obj list eqv?)) - -(memv 2 '(1 2 3)) - -(memv 4 '(1 2 3)) - -(memv '(2) '((1) (2) (3))) - -(define (_assoc obj list test?) - (if (null? list) - #f - (if (test? obj (caar list)) - (car list) - (_assoc obj (cdr list) test?) - ) - ) - ) - -(define (assq obj list) (_assoc obj list eq?)) -(define (assv obj list) (_assoc obj list eqv?)) -(define (assoc obj list) (_assoc obj list equal?)) - -(assq 'a '((a 1) (b 2) (c 3))) -(assv 'b '((a 1) (b 2) (c 3))) -(assoc '(c) '((a 1) (b 2) ((c) 3))) - -(define char? integer?) - -(char? #\q) -(char? "h") - -(define (char-upper-case? c) (<= #\A c #\Z)) - -(char-upper-case? #\a) -(char-upper-case? #\B) -(char-upper-case? #\0) -(char-upper-case? #\space) - -(define (char-lower-case? c) (<= #\a c #\a)) - -(char-lower-case? #\a) -(char-lower-case? #\B) -(char-lower-case? #\0) -(char-lower-case? #\space) - -(define (char-alphabetic? c) (or (char-upper-case? c) (char-lower-case? c))) - -(char-alphabetic? #\a) -(char-alphabetic? #\B) -(char-alphabetic? #\0) -(char-alphabetic? #\space) - -(define (char-numeric? c) (<= #\0 c #\9)) - -(char-numeric? #\a) -(char-numeric? #\B) -(char-numeric? #\0) -(char-numeric? #\space) - -(define (char-whitespace? c) (or (<= #\tab c #\return) (= #\space c))) - -(char-whitespace? #\a) -(char-whitespace? #\B) -(char-whitespace? #\0) -(char-whitespace? #\space) - -(define (char->integer c) c) -(define (integer->char c) char-integer) - -(define (char-upcase c) (if (char-lower-case? c) (+ c (- #\A #\a)) c)) - -(char-upcase #\a) -(char-upcase #\B) -(char-upcase #\0) -(char-upcase #\space) - -(define (char-downcase c) (if (char-upper-case? c) (+ c (- #\a #\A)) c)) - -(char-downcase #\a) -(char-downcase #\B) -(char-downcase #\0) -(char-downcase #\space) - -(define string (lambda chars (list->string chars))) - -(display "apply\n") -(apply cons '(a b)) - -(define map - (lambda (proc . lists) - (define (args lists) - (cond ((null? lists) ()) - (else - (cons (caar lists) (args (cdr lists))) - ) - ) - ) - (define (next lists) - (cond ((null? lists) ()) - (else - (cons (cdr (car lists)) (next (cdr lists))) - ) - ) - ) - (define (domap lists) - (cond ((null? (car lists)) ()) - (else - (cons (apply proc (args lists)) (domap (next lists))) - ) - ) - ) - (domap lists) - ) - ) - -(map cadr '((a b) (d e) (g h))) - -(define for-each (lambda (proc . lists) - (apply map proc lists) - #t)) - -(for-each display '("hello" " " "world" "\n")) - -(define (_string-ml strings) - (if (null? strings) () - (cons (string->list (car strings)) (_string-ml (cdr strings))) - ) - ) - -(define string-map (lambda (proc . strings) - (list->string (apply map proc (_string-ml strings)))))) - -(string-map (lambda (x) (+ 1 x)) "HAL") - -(define string-for-each (lambda (proc . strings) - (apply for-each proc (_string-ml strings)))) - -(string-for-each write-char "IBM\n") - -(define (newline) (write-char #\newline)) - -(newline) - -(call-with-current-continuation - (lambda (exit) - (for-each (lambda (x) - (write "test" x) - (if (negative? x) - (exit x))) - '(54 0 37 -3 245 19)) - #t)) - - - ; `q -> (quote q) - ; `(q) -> (append (quote (q))) - ; `(a ,(+ 1 2)) -> (append (quote (a)) (list (+ 1 2))) - ; `(a ,@(list 1 2 3) -> (append (quote (a)) (list 1 2 3)) - - - -`(hello ,(+ 1 2) ,@(list 1 2 3) `foo) - - -(define repeat - (macro (count . rest) - (define counter '__count__) - (cond ((pair? count) - (set! counter (car count)) - (set! count (cadr count)) - ) - ) - `(let ((,counter 0) - (__max__ ,count) - ) - (while (< ,counter __max__) - ,@rest - (set! ,counter (+ ,counter 1)) - ) - ) - ) - ) - -(repeat 2 (write 'hello)) -(repeat (x 3) (write 'goodbye x)) - -(define case - (macro (test . l) - ; construct the body of the - ; case, dealing with the - ; lambda version ( => lambda) - - (define (_unarrow l) - (cond ((null? l) l) - ((eq? (car l) '=>) `(( ,(cadr l) __key__))) - (else l)) - ) - - ; Build the case elements, which is - ; simply a list of cond clauses - - (define (_case l) - - (cond ((null? l) ()) - - ; else case - - ((eq? (caar l) 'else) - `((else ,@(_unarrow (cdr (car l)))))) - - ; regular case - - (else - (cons - `((eqv? ,(caar l) __key__) - ,@(_unarrow (cdr (car l)))) - (_case (cdr l))) - ) - ) - ) - - ; now construct the overall - ; expression, using a lambda - ; to hold the computed value - ; of the test expression - - `((lambda (__key__) - (cond ,@(_case l))) ,test) - ) - ) - -(case 12 (1 "one") (2 "two") (3 => (lambda (x) (write "the value is" x))) (12 "twelve") (else "else")) - -;(define number->string (lambda (arg . opt) -; (let ((base (if (null? opt) 10 (car opt))) - ; -; - diff --git a/src/scheme/ao_scheme_const.scheme b/src/scheme/ao_scheme_const.scheme new file mode 100644 index 00000000..ab6a309a --- /dev/null +++ b/src/scheme/ao_scheme_const.scheme @@ -0,0 +1,813 @@ +; +; Copyright © 2016 Keith Packard +; +; 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. +; +; Lisp code placed in ROM + + ; return a list containing all of the arguments +(def (quote list) (lambda l l)) + +(def (quote def!) + (macro (name value) + (list + def + (list quote name) + value) + ) + ) + +(begin + (def! append + (lambda args + (def! append-list + (lambda (a b) + (cond ((null? a) b) + (else (cons (car a) (append-list (cdr a) b))) + ) + ) + ) + + (def! append-lists + (lambda (lists) + (cond ((null? lists) lists) + ((null? (cdr lists)) (car lists)) + (else (append-list (car lists) (append-lists (cdr lists)))) + ) + ) + ) + (append-lists args) + ) + ) + 'append) + +(append '(a b c) '(d e f) '(g h i)) + + ; boolean operators + +(begin + (def! or + (macro l + (def! _or + (lambda (l) + (cond ((null? l) #f) + ((null? (cdr l)) + (car l)) + (else + (list + cond + (list + (car l)) + (list + 'else + (_or (cdr l)) + ) + ) + ) + ) + ) + ) + (_or l))) + 'or) + + ; execute to resolve macros + +(or #f #t) + +(begin + (def! and + (macro l + (def! _and + (lambda (l) + (cond ((null? l) #t) + ((null? (cdr l)) + (car l)) + (else + (list + cond + (list + (car l) + (_and (cdr l)) + ) + ) + ) + ) + ) + ) + (_and l) + ) + ) + 'and) + + ; execute to resolve macros + +(and #t #f) + +(begin + (def! quasiquote + (macro (x) + (def! constant? + ; A constant value is either a pair starting with quote, + ; or anything which is neither a pair nor a symbol + + (lambda (exp) + (cond ((pair? exp) + (eq? (car exp) 'quote) + ) + (else + (not (symbol? exp)) + ) + ) + ) + ) + (def! combine-skeletons + (lambda (left right exp) + (cond + ((and (constant? left) (constant? right)) + (cond ((and (eqv? (eval left) (car exp)) + (eqv? (eval right) (cdr exp))) + (list 'quote exp) + ) + (else + (list 'quote (cons (eval left) (eval right))) + ) + ) + ) + ((null? right) + (list 'list left) + ) + ((and (pair? right) (eq? (car right) 'list)) + (cons 'list (cons left (cdr right))) + ) + (else + (list 'cons left right) + ) + ) + ) + ) + + (def! expand-quasiquote + (lambda (exp nesting) + (cond + + ; non cons -- constants + ; themselves, others are + ; quoted + + ((not (pair? exp)) + (cond ((constant? exp) + exp + ) + (else + (list 'quote exp) + ) + ) + ) + + ; check for an unquote exp and + ; add the param unquoted + + ((and (eq? (car exp) 'unquote) (= (length exp) 2)) + (cond ((= nesting 0) + (car (cdr exp)) + ) + (else + (combine-skeletons ''unquote + (expand-quasiquote (cdr exp) (- nesting 1)) + exp)) + ) + ) + + ; nested quasi-quote -- + ; construct the right + ; expression + + ((and (eq? (car exp) 'quasiquote) (= (length exp) 2)) + (combine-skeletons ''quasiquote + (expand-quasiquote (cdr exp) (+ nesting 1)) + exp)) + + ; check for an + ; unquote-splicing member, + ; compute the expansion of the + ; value and append the rest of + ; the quasiquote result to it + + ((and (pair? (car exp)) + (eq? (car (car exp)) 'unquote-splicing) + (= (length (car exp)) 2)) + (cond ((= nesting 0) + (list 'append (car (cdr (car exp))) + (expand-quasiquote (cdr exp) nesting)) + ) + (else + (combine-skeletons (expand-quasiquote (car exp) (- nesting 1)) + (expand-quasiquote (cdr exp) nesting) + exp)) + ) + ) + + ; for other lists, just glue + ; the expansion of the first + ; element to the expansion of + ; the rest of the list + + (else (combine-skeletons (expand-quasiquote (car exp) nesting) + (expand-quasiquote (cdr exp) nesting) + exp) + ) + ) + ) + ) + (def! result (expand-quasiquote x 0)) + result + ) + ) + 'quasiquote) + + ; + ; Define a variable without returning the value + ; Useful when defining functions to avoid + ; having lots of output generated. + ; + ; Also accepts the alternate + ; form for defining lambdas of + ; (define (name x y z) sexprs ...) + ; + +(begin + (def! define + (macro (first . rest) + ; check for alternate lambda definition form + + (cond ((list? first) + (set! rest + (append + (list + 'lambda + (cdr first)) + rest)) + (set! first (car first)) + ) + (else + (set! rest (car rest)) + ) + ) + (def! result `(,begin + (,def (,quote ,first) ,rest) + (,quote ,first)) + ) + result + ) + ) + 'define + ) + + ; basic list accessors + +(define (caar l) (car (car l))) + +(define (cadr l) (car (cdr l))) + +(define (cdar l) (cdr (car l))) + +(define (caddr l) (car (cdr (cdr l)))) + + ; (if ) + ; (if 3 2) 'yes) +(if (> 3 2) 'yes 'no) +(if (> 2 3) 'no 'yes) +(if (> 2 3) 'no) + + ; simple math operators + +(define zero? (macro (value) `(eq? ,value 0))) + +(zero? 1) +(zero? 0) +(zero? "hello") + +(define positive? (macro (value) `(> ,value 0))) + +(positive? 12) +(positive? -12) + +(define negative? (macro (value) `(< ,value 0))) + +(negative? 12) +(negative? -12) + +(define (abs x) (if (>= x 0) x (- x))) + +(abs 12) +(abs -12) + +(define max (lambda (first . rest) + (while (not (null? rest)) + (cond ((< first (car rest)) + (set! first (car rest))) + ) + (set! rest (cdr rest)) + ) + first) + ) + +(max 1 2 3) +(max 3 2 1) + +(define min (lambda (first . rest) + (while (not (null? rest)) + (cond ((> first (car rest)) + (set! first (car rest))) + ) + (set! rest (cdr rest)) + ) + first) + ) + +(min 1 2 3) +(min 3 2 1) + +(define (even? x) (zero? (% x 2))) + +(even? 2) +(even? -2) +(even? 3) +(even? -1) + +(define (odd? x) (not (even? x))) + +(odd? 2) +(odd? -2) +(odd? 3) +(odd? -1) + + +(define (list-tail x k) + (if (zero? k) + x + (list-tail (cdr x (- k 1))) + ) + ) + +(define (list-ref x k) + (car (list-tail x k)) + ) + + ; define a set of local + ; variables all at once and + ; then evaluate a list of + ; sexprs + ; + ; (let (var-defines) sexprs) + ; + ; where var-defines are either + ; + ; (name value) + ; + ; or + ; + ; (name) + ; + ; e.g. + ; + ; (let ((x 1) (y)) (set! y (+ x 1)) y) + +(define let + (macro (vars . exprs) + (define (make-names vars) + (cond ((not (null? vars)) + (cons (car (car vars)) + (make-names (cdr vars)))) + (else ()) + ) + ) + + ; the parameters to the lambda is a list + ; of nils of the right length + + (define (make-vals vars) + (cond ((not (null? vars)) + (cons (cond ((null? (cdr (car vars))) ()) + (else + (car (cdr (car vars)))) + ) + (make-vals (cdr vars)))) + (else ()) + ) + ) + ; prepend the set operations + ; to the expressions + + ; build the lambda. + + `((lambda ,(make-names vars) ,@exprs) ,@(make-vals vars)) + ) + ) + + +(let ((x 1) (y)) (set! y 2) (+ x y)) + + ; define a set of local + ; variables one at a time and + ; then evaluate a list of + ; sexprs + ; + ; (let* (var-defines) sexprs) + ; + ; where var-defines are either + ; + ; (name value) + ; + ; or + ; + ; (name) + ; + ; e.g. + ; + ; (let* ((x 1) (y)) (set! y (+ x 1)) y) + +(define let* + (macro (vars . exprs) + + ; + ; make the list of names in the let + ; + + (define (make-names vars) + (cond ((not (null? vars)) + (cons (car (car vars)) + (make-names (cdr vars)))) + (else ()) + ) + ) + + ; the set of expressions is + ; the list of set expressions + ; pre-pended to the + ; expressions to evaluate + + (define (make-exprs vars exprs) + (cond ((null? vars) exprs) + (else + (cons + (list set + (list quote + (car (car vars)) + ) + (cond ((null? (cdr (car vars))) ()) + (else (cadr (car vars)))) + ) + (make-exprs (cdr vars) exprs) + ) + ) + ) + ) + + ; the parameters to the lambda is a list + ; of nils of the right length + + (define (make-nils vars) + (cond ((null? vars) ()) + (else (cons () (make-nils (cdr vars)))) + ) + ) + ; build the lambda. + + `((lambda ,(make-names vars) ,@(make-exprs vars exprs)) ,@(make-nils vars)) + ) + ) + +(let* ((x 1) (y x)) (+ x y)) + +(define when (macro (test . l) `(cond (,test ,@l)))) + +(when #t (write 'when)) + +(define unless (macro (test . l) `(cond ((not ,test) ,@l)))) + +(unless #f (write 'unless)) + +(define (reverse list) + (let ((result ())) + (while (not (null? list)) + (set! result (cons (car list) result)) + (set! list (cdr list)) + ) + result) + ) + +(reverse '(1 2 3)) + +(define (list-tail x k) + (if (zero? k) + x + (list-tail (cdr x) (- k 1)))) + +(list-tail '(1 2 3) 2) + +(define (list-ref x k) (car (list-tail x k))) + +(list-ref '(1 2 3) 2) + + ; recursive equality + +(define (equal? a b) + (cond ((eq? a b) #t) + ((and (pair? a) (pair? b)) + (and (equal? (car a) (car b)) + (equal? (cdr a) (cdr b))) + ) + (else #f) + ) + ) + +(equal? '(a b c) '(a b c)) +(equal? '(a b c) '(a b b)) + +(define member (lambda (obj list . test?) + (cond ((null? list) + #f + ) + (else + (if (null? test?) (set! test? equal?) (set! test? (car test?))) + (if (test? obj (car list)) + list + (member obj (cdr list) test?)) + ) + ) + ) + ) + +(member '(2) '((1) (2) (3))) + +(member '(4) '((1) (2) (3))) + +(define (memq obj list) (member obj list eq?)) + +(memq 2 '(1 2 3)) + +(memq 4 '(1 2 3)) + +(memq '(2) '((1) (2) (3))) + +(define (memv obj list) (member obj list eqv?)) + +(memv 2 '(1 2 3)) + +(memv 4 '(1 2 3)) + +(memv '(2) '((1) (2) (3))) + +(define (_assoc obj list test?) + (if (null? list) + #f + (if (test? obj (caar list)) + (car list) + (_assoc obj (cdr list) test?) + ) + ) + ) + +(define (assq obj list) (_assoc obj list eq?)) +(define (assv obj list) (_assoc obj list eqv?)) +(define (assoc obj list) (_assoc obj list equal?)) + +(assq 'a '((a 1) (b 2) (c 3))) +(assv 'b '((a 1) (b 2) (c 3))) +(assoc '(c) '((a 1) (b 2) ((c) 3))) + +(define char? integer?) + +(char? #\q) +(char? "h") + +(define (char-upper-case? c) (<= #\A c #\Z)) + +(char-upper-case? #\a) +(char-upper-case? #\B) +(char-upper-case? #\0) +(char-upper-case? #\space) + +(define (char-lower-case? c) (<= #\a c #\a)) + +(char-lower-case? #\a) +(char-lower-case? #\B) +(char-lower-case? #\0) +(char-lower-case? #\space) + +(define (char-alphabetic? c) (or (char-upper-case? c) (char-lower-case? c))) + +(char-alphabetic? #\a) +(char-alphabetic? #\B) +(char-alphabetic? #\0) +(char-alphabetic? #\space) + +(define (char-numeric? c) (<= #\0 c #\9)) + +(char-numeric? #\a) +(char-numeric? #\B) +(char-numeric? #\0) +(char-numeric? #\space) + +(define (char-whitespace? c) (or (<= #\tab c #\return) (= #\space c))) + +(char-whitespace? #\a) +(char-whitespace? #\B) +(char-whitespace? #\0) +(char-whitespace? #\space) + +(define (char->integer c) c) +(define integer->char char->integer) + +(define (char-upcase c) (if (char-lower-case? c) (+ c (- #\A #\a)) c)) + +(char-upcase #\a) +(char-upcase #\B) +(char-upcase #\0) +(char-upcase #\space) + +(define (char-downcase c) (if (char-upper-case? c) (+ c (- #\a #\A)) c)) + +(char-downcase #\a) +(char-downcase #\B) +(char-downcase #\0) +(char-downcase #\space) + +(define string (lambda chars (list->string chars))) + +(display "apply\n") +(apply cons '(a b)) + +(define map + (lambda (proc . lists) + (define (args lists) + (cond ((null? lists) ()) + (else + (cons (caar lists) (args (cdr lists))) + ) + ) + ) + (define (next lists) + (cond ((null? lists) ()) + (else + (cons (cdr (car lists)) (next (cdr lists))) + ) + ) + ) + (define (domap lists) + (cond ((null? (car lists)) ()) + (else + (cons (apply proc (args lists)) (domap (next lists))) + ) + ) + ) + (domap lists) + ) + ) + +(map cadr '((a b) (d e) (g h))) + +(define for-each (lambda (proc . lists) + (apply map proc lists) + #t)) + +(for-each display '("hello" " " "world" "\n")) + +(define (_string-ml strings) + (if (null? strings) () + (cons (string->list (car strings)) (_string-ml (cdr strings))) + ) + ) + +(define string-map (lambda (proc . strings) + (list->string (apply map proc (_string-ml strings)))))) + +(string-map (lambda (x) (+ 1 x)) "HAL") + +(define string-for-each (lambda (proc . strings) + (apply for-each proc (_string-ml strings)))) + +(string-for-each write-char "IBM\n") + +(define (newline) (write-char #\newline)) + +(newline) + +(call-with-current-continuation + (lambda (exit) + (for-each (lambda (x) + (write "test" x) + (if (negative? x) + (exit x))) + '(54 0 37 -3 245 19)) + #t)) + + + ; `q -> (quote q) + ; `(q) -> (append (quote (q))) + ; `(a ,(+ 1 2)) -> (append (quote (a)) (list (+ 1 2))) + ; `(a ,@(list 1 2 3) -> (append (quote (a)) (list 1 2 3)) + + + +`(hello ,(+ 1 2) ,@(list 1 2 3) `foo) + + +(define repeat + (macro (count . rest) + (define counter '__count__) + (cond ((pair? count) + (set! counter (car count)) + (set! count (cadr count)) + ) + ) + `(let ((,counter 0) + (__max__ ,count) + ) + (while (< ,counter __max__) + ,@rest + (set! ,counter (+ ,counter 1)) + ) + ) + ) + ) + +(repeat 2 (write 'hello)) +(repeat (x 3) (write 'goodbye x)) + +(define case + (macro (test . l) + ; construct the body of the + ; case, dealing with the + ; lambda version ( => lambda) + + (define (_unarrow l) + (cond ((null? l) l) + ((eq? (car l) '=>) `(( ,(cadr l) __key__))) + (else l)) + ) + + ; Build the case elements, which is + ; simply a list of cond clauses + + (define (_case l) + + (cond ((null? l) ()) + + ; else case + + ((eq? (caar l) 'else) + `((else ,@(_unarrow (cdr (car l)))))) + + ; regular case + + (else + (cons + `((eqv? ,(caar l) __key__) + ,@(_unarrow (cdr (car l)))) + (_case (cdr l))) + ) + ) + ) + + ; now construct the overall + ; expression, using a lambda + ; to hold the computed value + ; of the test expression + + `((lambda (__key__) + (cond ,@(_case l))) ,test) + ) + ) + +(case 12 (1 "one") (2 "two") (3 => (lambda (x) (write "the value is" x))) (12 "twelve") (else "else")) + +;(define number->string (lambda (arg . opt) +; (let ((base (if (null? opt) 10 (car opt))) + ; +; + diff --git a/src/scheme/ao_scheme_eval.c b/src/scheme/ao_scheme_eval.c index 9b3cf63e..907ecf0b 100644 --- a/src/scheme/ao_scheme_eval.c +++ b/src/scheme/ao_scheme_eval.c @@ -108,13 +108,7 @@ ao_scheme_eval_sexpr(void) DBGI("..frame "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n"); ao_scheme_v = ao_scheme_atom_get(ao_scheme_v); /* fall through */ - case AO_SCHEME_BOOL: - case AO_SCHEME_INT: - case AO_SCHEME_BIGINT: - case AO_SCHEME_FLOAT: - case AO_SCHEME_STRING: - case AO_SCHEME_BUILTIN: - case AO_SCHEME_LAMBDA: + default: ao_scheme_stack->state = eval_val; break; } diff --git a/src/scheme/ao_scheme_float.c b/src/scheme/ao_scheme_float.c index 541f0264..99249030 100644 --- a/src/scheme/ao_scheme_float.c +++ b/src/scheme/ao_scheme_float.c @@ -39,6 +39,10 @@ const struct ao_scheme_type ao_scheme_float_type = { .name = "float", }; +#ifndef FLOAT_FORMAT +#define FLOAT_FORMAT "%g" +#endif + void ao_scheme_float_write(ao_poly p) { @@ -54,7 +58,7 @@ ao_scheme_float_write(ao_poly p) printf("+"); printf("inf.0"); } else - printf ("%g", f->value); + printf (FLOAT_FORMAT, v); } float diff --git a/src/scheme/ao_scheme_mem.c b/src/scheme/ao_scheme_mem.c index acc726c8..fe4bc4f5 100644 --- a/src/scheme/ao_scheme_mem.c +++ b/src/scheme/ao_scheme_mem.c @@ -467,6 +467,7 @@ static const struct ao_scheme_type * const ao_scheme_types[AO_SCHEME_NUM_TYPE] = [AO_SCHEME_BOOL] = &ao_scheme_bool_type, [AO_SCHEME_BIGINT] = &ao_scheme_bigint_type, [AO_SCHEME_FLOAT] = &ao_scheme_float_type, + [AO_SCHEME_VECTOR] = &ao_scheme_vector_type, }; static int diff --git a/src/scheme/ao_scheme_poly.c b/src/scheme/ao_scheme_poly.c index d726321c..553585db 100644 --- a/src/scheme/ao_scheme_poly.c +++ b/src/scheme/ao_scheme_poly.c @@ -68,6 +68,10 @@ static const struct ao_scheme_funcs ao_scheme_funcs[AO_SCHEME_NUM_TYPE] = { .write = ao_scheme_float_write, .display = ao_scheme_float_write, }, + [AO_SCHEME_VECTOR] = { + .write = ao_scheme_vector_write, + .display = ao_scheme_vector_display + }, }; static const struct ao_scheme_funcs * diff --git a/src/scheme/ao_scheme_read.c b/src/scheme/ao_scheme_read.c index 6b1e9d66..9ed54b9f 100644 --- a/src/scheme/ao_scheme_read.c +++ b/src/scheme/ao_scheme_read.c @@ -151,7 +151,7 @@ static const uint16_t lex_classes[128] = { static int lex_unget_c; static inline int -lex_get() +lex_get(void) { int c; if (lex_unget_c) { @@ -244,7 +244,7 @@ lex_quoted(void) } } -#define AO_SCHEME_TOKEN_MAX 32 +#define AO_SCHEME_TOKEN_MAX 128 static char token_string[AO_SCHEME_TOKEN_MAX]; static int32_t token_int; @@ -340,6 +340,8 @@ _lex(void) add_token(c); end_token(); return BOOL; + case '(': + return OPEN_VECTOR; case '\\': for (;;) { int alphabetic; @@ -470,36 +472,40 @@ static inline int lex(void) static int parse_token; +int ao_scheme_read_list; struct ao_scheme_cons *ao_scheme_read_cons; struct ao_scheme_cons *ao_scheme_read_cons_tail; struct ao_scheme_cons *ao_scheme_read_stack; +static int ao_scheme_read_state; #define READ_IN_QUOTE 0x01 #define READ_SAW_DOT 0x02 #define READ_DONE_DOT 0x04 +#define READ_SAW_VECTOR 0x08 static int -push_read_stack(int cons, int read_state) +push_read_stack(int read_state) { RDBGI("push read stack %p 0x%x\n", ao_scheme_read_cons, read_state); RDBG_IN(); - if (cons) { + if (ao_scheme_read_list) { ao_scheme_read_stack = ao_scheme_cons_cons(ao_scheme_cons_poly(ao_scheme_read_cons), ao_scheme__cons(ao_scheme_int_poly(read_state), ao_scheme_cons_poly(ao_scheme_read_stack))); if (!ao_scheme_read_stack) return 0; - } + } else + ao_scheme_read_state = read_state; ao_scheme_read_cons = NULL; ao_scheme_read_cons_tail = NULL; return 1; } static int -pop_read_stack(int cons) +pop_read_stack(void) { int read_state = 0; - if (cons) { + if (ao_scheme_read_list) { ao_scheme_read_cons = ao_scheme_poly_cons(ao_scheme_read_stack->car); ao_scheme_read_stack = ao_scheme_poly_cons(ao_scheme_read_stack->cdr); read_state = ao_scheme_poly_int(ao_scheme_read_stack->car); @@ -512,6 +518,7 @@ pop_read_stack(int cons) ao_scheme_read_cons = 0; ao_scheme_read_cons_tail = 0; ao_scheme_read_stack = 0; + read_state = ao_scheme_read_state; } RDBG_OUT(); RDBGI("pop read stack %p %d\n", ao_scheme_read_cons, read_state); @@ -523,19 +530,20 @@ ao_scheme_read(void) { struct ao_scheme_atom *atom; char *string; - int cons; int read_state; ao_poly v = AO_SCHEME_NIL; - cons = 0; + ao_scheme_read_list = 0; read_state = 0; ao_scheme_read_cons = ao_scheme_read_cons_tail = ao_scheme_read_stack = 0; for (;;) { parse_token = lex(); - while (parse_token == OPEN) { - if (!push_read_stack(cons, read_state)) + while (parse_token == OPEN || parse_token == OPEN_VECTOR) { + if (parse_token == OPEN_VECTOR) + read_state |= READ_SAW_VECTOR; + if (!push_read_stack(read_state)) return AO_SCHEME_NIL; - cons++; + ao_scheme_read_list++; read_state = 0; parse_token = lex(); } @@ -543,7 +551,7 @@ ao_scheme_read(void) switch (parse_token) { case END: default: - if (cons) + if (ao_scheme_read_list) ao_scheme_error(AO_SCHEME_EOF, "unexpected end of file"); return _ao_scheme_atom_eof; break; @@ -577,9 +585,9 @@ ao_scheme_read(void) case QUASIQUOTE: case UNQUOTE: case UNQUOTE_SPLICING: - if (!push_read_stack(cons, read_state)) + if (!push_read_stack(read_state)) return AO_SCHEME_NIL; - cons++; + ao_scheme_read_list++; read_state = READ_IN_QUOTE; switch (parse_token) { case QUOTE: @@ -597,16 +605,18 @@ ao_scheme_read(void) } break; case CLOSE: - if (!cons) { + if (!ao_scheme_read_list) { v = AO_SCHEME_NIL; break; } v = ao_scheme_cons_poly(ao_scheme_read_cons); - --cons; - read_state = pop_read_stack(cons); + --ao_scheme_read_list; + read_state = pop_read_stack(); + if (read_state & READ_SAW_VECTOR) + v = ao_scheme_vector_poly(ao_scheme_list_to_vector(ao_scheme_poly_cons(v))); break; case DOT: - if (!cons) { + if (!ao_scheme_read_list) { ao_scheme_error(AO_SCHEME_INVALID, ". outside of cons"); return AO_SCHEME_NIL; } @@ -620,7 +630,7 @@ ao_scheme_read(void) /* loop over QUOTE ends */ for (;;) { - if (!cons) + if (!ao_scheme_read_list) return v; if (read_state & READ_DONE_DOT) { @@ -647,8 +657,8 @@ ao_scheme_read(void) break; v = ao_scheme_cons_poly(ao_scheme_read_cons); - --cons; - read_state = pop_read_stack(cons); + --ao_scheme_read_list; + read_state = pop_read_stack(); } } return v; diff --git a/src/scheme/ao_scheme_read.h b/src/scheme/ao_scheme_read.h index e9508835..e10a7d05 100644 --- a/src/scheme/ao_scheme_read.h +++ b/src/scheme/ao_scheme_read.h @@ -32,6 +32,7 @@ # define FLOAT 10 # define DOT 11 # define BOOL 12 +# define OPEN_VECTOR 13 /* * character classes diff --git a/src/scheme/test/ao_scheme_test.c b/src/scheme/test/ao_scheme_test.c index 15c71203..686e7169 100644 --- a/src/scheme/test/ao_scheme_test.c +++ b/src/scheme/test/ao_scheme_test.c @@ -78,7 +78,7 @@ ao_scheme_getc(void) return getc(ao_scheme_file); if (newline) { - if (ao_scheme_read_stack) + if (ao_scheme_read_list) printf("+ "); else printf("> ");