(define (sharp-plus str) ;; str here is "+", we assume either a symbol or an expression involving symbols follows (let ((e (if (string=? str "+") (read) ; must be #+(...) (string->symbol (substring str 1)))) ; #+feature (expr (read))) ; this is the expression following #+ (if (symbol? e) (if (provided? e) expr (values)) (if (not (pair? e)) (error 'wrong-type-arg "strange #+ chooser: ~S~%" e) (begin ; evaluate the #+(...) expression as in cond-expand (define (traverse tree) (if (pair? tree) (cons (traverse (car tree)) (case (cdr tree) ((())) (else => traverse))) (if (memq tree '(and or not)) tree (and (symbol? tree) (provided? tree))))) (if (eval (traverse e)) expr (values)))))))
See also the #n= reader below.
(make-list length (initial-element #f)) returns a list of 'length' elements defaulting to 'initial-element'.
(char-position char-or-string searched-string (start 0)) (string-position substring searched-string (start 0))
char-position and string-position search a string for the occurrence of a character, any of a set of characters, or a string. They return either #f if none is found, or the position within the searched string of the first occurrence. The optional third argument sets where the search starts in the second argument.
If char-position's first argument is a string, it is treated as a set of characters, and char-position looks for the first occurrence of any member of that set. Currently, the strings involved are assumed to be C strings (don't expect embedded nulls to work right in this context).
(call-with-input-file "s7.c" ; report any lines with "static " but no following open paren (lambda (file) (let loop ((line (read-line file #t))) (or (eof-object? line) (let ((pos (string-position "static " line))) (if (and pos (not (char-position #\( (substring line pos)))) (if (> (length line) 80) (begin (display (substring line 0 80)) (newline)) (display line)))) (loop (read-line file #t)))))))
Keywords exist mainly for define*'s benefit. The keyword functions are: keyword?, string->keyword, symbol->keyword, and keyword->symbol. A keyword is a symbol that starts or ends with a colon. The colon is considered to be a part of the symbol name. A keyword is a constant that evaluates to itself.
(symbol-table) (symbol->value sym (env (curlet))) (symbol->dynamic-value sym) (defined? sym (env (curlet)) ignore-rootlet)
defined?
returns #t if the symbol is defined in the environment:
(define-macro (defvar name value) `(unless (defined? ',name) (define ,name ,value)))
If ignore-rootlet is #t, the search is confined to the given environment.
symbol->value
returns the value (lexically) bound to the symbol, whereas symbol->dynamic-value
returns the value dynamically bound to it.
symbol-table
returns a vector containing the symbols currently in the symbol-table.
Here we scan the symbol table looking for any function that doesn't have documentation:
(for-each (lambda (sym) (if (defined? sym) (let ((val (symbol->value sym))) (if (and (procedure? val) (string=? "" (documentation val))) (format *stderr* "~S " sym))))) (symbol-table))
Or get a list of gensyms:
(map (lambda (sym) (if (gensym? sym) sym (values))) (symbol-table))
An automatic software tester (see also tauto.scm and auto-tester.scm in the tools directory):
(for-each (lambda (sym) (if (defined? sym) (let ((val (symbol->value sym))) (if (procedure? val) (let ((max-args (cdr (arity val)))) (if (or (> max-args 4) (memq sym '(exit abort))) (format () ";skip ~S for now~%" sym) (begin (format () ";whack on ~S...~%" sym) (let ((constants (list #f #t pi () 1 1.5 3/2 1.5+i))) (let autotest ((args ()) (args-left max-args)) (catch #t (lambda () (apply func args)) (lambda any #f)) (if (> args-left 0) (for-each (lambda (c) (autotest (cons c args) (- args-left 1))) constants))))))))))) (symbol-table))
help tries to find information about its argument.
> (help 'caadar) "(caadar lst) returns (car (car (cdr (car lst)))): (caadar '((1 (2 3)))) -> 2"
gc calls the garbage collector. (gc #f)
turns off the GC, and (gc #t)
turns it on.
If you get an error complaining about a "free cell", this is usually a sign that the GC freed some object that it should have left alone. In straight scheme code, it's an s7 bug; please send me mail about it! In foreign code, it probably indicates that you need to protect some s7_pointer with s7_gc_protect.
(equivalent? x y)
Say we want to check that two different computations came to the same result, and that result might involve circular structures. Will equal? be our friend?
> (equal? 2 2.0) #f > (let ((x +nan.0)) (equal? x x)) #f > (equal? .1 1/10) #f > (= .1 1/10) #f > (= 0.0 0+1e-300i) #f
No! We need an equality check that ignores epsilonic differences in real and complex numbers, and knows that NaNs are equal for all practical purposes. Leaving aside numbers, closed ports are not equal, yet nothing can be done with them. #() is not equal to #2d(). And two closures are never equal, even if their arguments, environments, and bodies are equal. Since there might be circles, it is not easy to write a replacement for equal? in Scheme. So, in s7, if one thing is basically the same as some other thing, they satisfy the function equivalent?.
> (equivalent? 2 2.0) #t > (equivalent? 1/0 1/0) ; NaN #t > (equivalent? .1 1/10) #t ; floating-point epsilon here is 1.0e-15 or thereabouts > (equivalent? 0.0 1e-300) #t > (equivalent? 0.0 1e-14) #f ; its not always #t! > (equivalent? (lambda () #f) (lambda () #f)) #t
The *s7* field equivalent-float-epsilon sets the floating-point fudge factor. I can't decide how bignums should interact with equivalent?. Currently, if a bignum is involved, either here or in a hash-table, s7 uses equal?. Finally, if either argument is an environment with an 'equivalent? method, that method is invoked.
define-expansion defines a macro that expands at read-time. It has the same syntax as define-macro, and (in normal use) the same result, but it is much faster because it expands only once. Similarly, define-expansion* defines a read-time macro*. (See also define-with-macros in s7test.scm for a way to expand macros in a function body at definition time). Since the reader knows almost nothing about the code it is reading, you need to make sure the expansion is defined at the top level and that its name is unique. The reader does know about global variables, so:
(define *debugging* #t) (define-expansion (assert assertion) (if *debugging* ; or maybe better, (eq? (symbol->value '*debugging*) #t) `(unless ,assertion (format *stderr* "~A: ~A failed~%" (*function*) ',assertion)) (values)))
Now the assertion code is only present in the function body (or wherever) if *debugging* is #t; otherwise assert expands into nothing. Another very handy use is to embed a source file line number into a message; see for example lint-format in lint.scm. Leaving aside read-time expansion and splicing, the real difference between define-macro and define-expansion is that the expansion's result is not evaluated. I'm no historian, but I believe that means that define-expansion creates a (gasp!) f*xpr. In fact:
(define-macro (define-f*xpr name-and-args . body) `(define ,(car name-and-args) (apply define-expansion (append (list (append (list (gensym)) ',(cdr name-and-args))) ',body)))) > (define-f*xpr (mac a) `(+ ,a 1)) mac > (mac (* 2 3)) (+ (* 2 3) 1)
You can do something similar with a normal macro, or make the indirection explicit:
> (define-macro (fx x) `'(+ 1 ,x)) ; quote result to avoid evaluation fx > (let ((a 3)) (fx a)) (+ 1 a) > (define-expansion (ex x) `(+ 1 ,x)) ex > (let ((x ex) (a 3)) (x a)) ; avoid read-time splicing (+ 1 a) > (let ((a 3)) (ex a)) ; spliced in at read-time 4
As this example shows, the reader knows nothing about the program context,
so if it does not see a list whose first element is a expansion name, it does
not do anything special. In the (x a)
case above, the
expansion happens when the code is evaluated, and the expansion result
is simply returned, unevaluated.
You can also use macroexpand to cancel the evaluation of a macro's expansion:
(define-macro (rmac . args) (if (null? args) () (if (null? (cdr args)) `(display ',(car args)) (list 'begin `(display ',(car args)) (apply macroexpand (list (cons 'rmac (cdr args)))))))) > (macroexpand (rmac a b c)) (begin (display 'a) (begin (display 'b) (display 'c))) > (begin (rmac a b c d) (newline)) abcd
The main built-in expansion is reader-cond. The syntax is based on cond: the car of each clause is evaluated (in the read-time context), and if it is not false, the remainder of that clause is spliced into the code as if you had typed it from the start.
> '(1 2 (reader-cond ((> 1 0) 3) (else 4)) 5 6) (1 2 3 5 6) > ((reader-cond ((> 1 0) list 1 2) (else cons)) 5 6) (1 2 5 6)
Whenever (*s7* 'profile) is positive, profiling is turned on. As the program runs, the profiler collects data about each function it can identify. At any time, you can call show-profile to see that data. The first timing is inclusive (it includes the time spent in any nested calls), the second is exclusive (it is the time spent just in the current function). In Linux and *BSD, we use clock_gettime() which is reasonably fast, but there is some profiler overhead. In other systems, we use clock() which is amazingly slow. The optimizer sometimes recasts tail recursion and similar cases as while loops, so the number of calls listed may be less than you'd expect, but the overall time should be correct. To clear out the current data, call clear-profile.
*s7* is a let that gives access to some of s7's internal state:
version a string describing the current s7: e.g. "s7 10.0, 13-Jan-2022" major-version an integer (10 in the example above) minor-version an integer (0 in the example above) print-length number of elements to print of a non-string sequence max-string-length maximum size arg to make-string and read-string max-format-length maximum size arg to ~N or the width and precision fields for floats in format max-list-length maximum size arg to make-list max-port-data-size maximum size of a port data buffer max-vector-length maximum size arg to make-vector and make-hash-table max-vector-dimensions make-vector dimensions limit default-hash-table-length default size for make-hash-table (8, tables resize as needed) initial-string-port-length 128, initial size of a input string port's buffer output-port-data-size 2048, size of an output port's buffer history a circular buffer of recent eval entries stored backwards (use set! to add an entry) history-size eval history buffer size if s7 built WITH_HISTORY=1 history-enabled is history buffer receiving additions (if WITH_HISTORY=1 as above) debug determines debugging level (see debug.scm), default=0 profile profile switch (0=default, 1=gather profiling info) profile-info the current profiling data; see profile.scm profile-prefix name (a symbol) used to identify the current environment in profile data default-rationalize-error 1e-12 equivalent-float-epsilon 1e-15 hash-table-float-epsilon 1e-12 (currently limited to less than 1e-3). bignum-precision bits for bignum floats (128) float-format-precision digits to print for floats (16) default-random-state the default arg for random most-positive-fixnum if not using gmp, the most positive integer ("fixnum" comes from CL) most-negative-fixnum as above, but negative number-separator #\null safety 0 (see below) undefined-identifier-warnings #f undefined-constant-warnings #f accept-all-keyword-arguments #f autoloading? #t openlets #t, whether any let can be open globally (this overrides all openlets) expansions? #t, whether expansions are handled at read-time muffle-warnings? #f, if #t s7_warn does not output anything cpu-time run time so far (proportional to cpu cycles consumed, not wall-clock seconds) file-names or filenames currently loaded files (a list) catches a list of the currently active catch tags c-types a list of c-object type names (from s7_make_c_type, etc) stack the current stack entries stack-top current stack location stack-size current stack size max-stack-size maximum stack size stacktrace-defaults stacktrace formatting info for error handler rootlet-size the number of globals heap-size total cells currently available max-heap-size maximum heap size free-heap-size the number of currently unused cells gc-stats 0 (or #f), 1: show GC activity, 2: heap, 4: stack, 8: protected_objects, #t = 1 gc-freed number of cells freed by the last GC pass gc-total-freed number of cells freed so far by the GC; the total allocated is probably close to (with-let *s7* (+ (- heap-size free-heap-size) gc-total-freed)) gc-info a list: calls total-time ticks-per-second (see profile.scm) gc-temps-size number of cells just allocated that are protected from the GC (256) gc-resize-heap-fraction when to resize the heap (0.8); these two are aimed at GC experiments gc-resize-heap-by-4-fraction when to get panicky about resizing the heap gc-protected-objects vector of the objects permanently protected from the GC memory-usage a let (environment) describing current s7 memory allocations
Use the standard environment syntax to access these fields:
(*s7* 'stack-top)
. stuff.scm has the function
*s7*->list that returns most of these fields in a list.
The compile-time defaults for some of these fields can be set:
heap-size: INITIAL_HEAP_SIZE (64000) stack-size: INITIAL_STACK_SIZE (4096) gc-temps-size: GC_TEMPS_SIZE (256) bignum-precision: DEFAULT_BIGNUM_PRECISION (128) history-size: DEFAULT_HISTORY_SIZE (8) print-length: DEFAULT_PRINT_LENGTH (12) gc-resize-heap-fraction: GC_RESIZE_HEAP_FRACTION (0.8) output-port-data-size: OUTPUT_PORT_DATA_SIZE (2048) See also WITH_WARNINGS, S7_ALIGNED, and GC_TRIGGER_SIZE.
(set! (*s7* 'autoloading) #f)
turns off the autoloader.
The 'safety variable is an integer. Currently:
0: default. 1: no remove_from_heap (a GC optimization) infinite loop check in eval, sort! and some iterators immutable object check in reverse!, sort!, and fill! more info in (*s7* 'history) for s7_apply_function, s7_call and s7_eval less aggressive optimization in with-let and lambda warnings about syntax redefinition incoming s7_pointer checks in some FFI functions bignum int to s7_int conversion checks 2: vector, string, and pair constants are immutable (but checks for this are currently sparse)
The debug variable controls where debug.scm is active. If it is (if debug > 0), it inserts
trace calls in functions and so on. It uses dynamic-unwind
to establish a catcher for the return value. (dynamic-unwind function arg)
causes
function
to be called after the traced function has returned, passing it arg
and the returned value.
(*s7* 'stacktrace-defaults)
is a list of four integers and a boolean that tell the error
handler how to format stacktrace information. The four integers are:
how many frames to display,
how many columns are devoted to code display,
how many columns are available for a line of data,
and where to place comments.
The boolean sets whether the entire output should be displayed as a comment.
The defaults are '(3 45 80 45 #t).
This will display s7 memory usage sort of like the top program:
(format *stderr* "~C[~D;~DH" #\escape 0 0) (format *stderr* "~C[J" #\escape) (display (with-output-to-string (lambda() (*s7* 'memory-usage))))
(Ideally we'd only redisplay the changed fields).
The standard time macro:
(define-macro (time expr) `(let ((start (*s7* 'cpu-time))) (let ((res (list ,expr))) ; expr might return multiple values (list (car res) (- (*s7* 'cpu-time) start)))))
Add automatic log10 recalculation to (*s7* 'bignum-precision):
(define log10 (log (bignum 10))) (define bignum-precision (dilambda (lambda () (*s7* 'bignum-precision)) (lambda (val) (set! (*s7* 'bignum-precision) val) (set! log10 (log (bignum 10))) val)))
The stack, history and gc-protected-objects fields are intended for debugging. Don't keep these hanging around and expect good things to happen!
The *s7* field 'number-separator refers to what some languages call "numeric literal separator", a character that can appear in a number as a separator to make it more readable: "123,321" as opposed to "123321". If the compile time flag WITH_NUMBER_SEPARATOR is set, and (*s7* 'number-separator) is not #\null (the default), then that character can appear anywhere in a number (as long as it is between two digits), and the reader will ignore it. The *features* list will have the entry 'number-separator if s7 was compiled with WITH_NUMBER_SEPARATOR defined. (Number separators don't work with bignums).
(c-object? obj) (c-object-type obj) (c-pointer? obj) (c-pointer int type info weak1 weak2) (c-pointer-type obj) (c-pointer-info obj) (c-pointer-weak1 obj) ; also weak2 (c-pointer->list obj)
c-object? returns #t is its argument is a c-object. c-object-type returns the object's type tag (otherwise #f of course). This tag is also the position of the object's type in the (*s7* 'c-types) list. (*s7* 'c-types) returns a list of the types created by s7_make_c_type.
You can wrap up raw C pointers and
pass them around in s7 code. The function c-pointer returns a wrapped pointer,
and c-pointer? returns #t if passed one. (define NULL (c-pointer 0))
.
If the type field is a symbol, it is used to check types in s7_c_pointer with_type.
If the 'info field of a c-pointer is a let, that pointer can participate in
the generic functions mechanism, much like a c-object:
> (let ((ptr (c-pointer 1 'abc (inlet 'object->string (lambda (obj . args) (let ((lt (object->let obj))) (format #f "I am pointer ~A of type '~A!" (lt 'c-pointer) ; we need c-pointer-type etc (lt 'c-type)))))))) (openlet ptr) (object->string ptr)) "I am pointer 1 of type 'abc!"
c-pointer->list returns (list pointer-as-int type info). The "weak1" and "weak2" fields are intended for custom "weak" references. The weak fields values are not marked during the GC sweep, much like a key in a weak-hash-table. If either value is GC'd, that field is set to #f by the GC. The weak fields are ignored by equal? and equivalent? when comparing c-pointers, and by object->string of a c-pointer even if :readable is specified.
There are several tree-oriented functions currently built into s7:
(tree-cyclic? tree) returns #t if tree contains a cycle. (tree-leaves tree) returns the number of leaves in tree. (tree-memq obj tree) returns #t if obj is in tree (using eq?). (tree-set-memq set tree) returns #t if any member of the set (a list of symbols) is in tree. (tree-count obj tree) returns how many times obj is in tree.
s7 originally had Scheme-level multithreading support, but I removed it in August, 2011. It turned out to be less useful than I hoped, mainly because s7 threads shared the heap and therefore had to coordinate all cell allocations. It was faster and simpler to use multiple processes each running a separate s7 interpreter, rather than one s7 running multiple s7 threads. In CLM, there was also contention for access to the output stream. In GUI-related situations, threads were not useful mainly because the GUI toolkits are not thread safe. Last but not least, the effort to make the non-threaded s7 faster messed up parts of the threaded version. Rather than waste a lot of time fixing this, I chose to flush multithreading. s7 is thread-safe:
#include <stdio.h> #include <stdlib.h> #include <pthread.h> #include "s7.h" #define NUM_THREADS 16 static pthread_t threads[NUM_THREADS]; static pthread_mutex_t lock = PTHREAD_MUTEX_INITIALIZER; static void *run_thread(void *obj) { s7_scheme *sc = (s7_scheme *)obj; const char *str = s7_object_to_c_string(sc, s7_make_integer(sc, 123)); s7_eval_c_string(sc, "(let () \ (define (f) \ (do ((i 0 (+ i 1))) ((= i 10)) \ (do ((k 0 (+ k 1))) ((= k 1000000))) \ (format *stderr* \"~D \" i))) \ (f))"); pthread_mutex_lock(&lock); fprintf(stderr, "%s\n", str); pthread_mutex_unlock(&lock); } int main(int argc, char **argv) { for (int32_t i = 0; i < NUM_THREADS; i++) pthread_create(&threads[i], NULL, run_thread, (void *)s7_init()); for (int32_t i = 0; i < NUM_THREADS; i++) pthread_join(threads[i], NULL); exit(0); } /* linux: gcc -o threads threads.c s7.o -Wl,-export-dynamic -pthread -lm -I. -ldl * mac: clang -o threads threads.c s7.o -pthread -lm -I. -ldl */
Some other differences from r5rs:
- no force or delay (see below).
- no syntax-rules or any of its friends.
- no scheme-report-environment, null-environment, or interaction-environment (use curlet).
- no transcript-on or transcript-off.
- begin returns the value of the last form; it can contain both definitions and other statements.
- #<unspecified>, #<eof>, and #<undefined> are first-class objects.
- for-each and map accept different length arguments; the operation stops when any argument reaches its end.
- for-each and map accept any applicable object as the first argument, and any sequence or iterator as a trailing argument.
- letrec*, but without conviction.
- set! and *-set! return the new value (modulo setter), not #<unspecified>.
- define and its friends return the new value.
- port-closed?
- list? means "pair or null", proper-list? is r5rs list?, float? = real and not rational, sequence? = length, byte? = unsigned byte.
- the default IO ports are named *stdin*, *stdout*, and *stderr*.
- #f as an output port means nothing is output (#f is /dev/null, I guess).
- member and assoc accept an optional third argument, the comparison function (equal? is the default).
- case accepts => much like cond (the function argument is the selector).
- if WITH_SYSTEM_EXTRAS is 1, the following are built-in: directory?, file-exists?, delete-file, system, directory->list, getenv.
- s7 is case sensitive.
- when and unless (for r7rs), returning the value of the last form.
- the "d", "f", "s", and "l" exponent markers are not supported by default (use "e", "E", or "@").
- quasiquoted vector constants are not supported (use the normal list expansions wrapped in list->vector).
- type-of returns a type indicator for its argument.
In s7 if a built-in function like gcd is referred to in a function body, the optimizer is free to replace it with #_function. That is,
(gcd ...)
can be changed to(#_gcd ...)
at s7's whim, if gcd has its original value at the time the optimizer sees the expression using it. A subsequent(set! gcd +)
does not affect this optimized call. I think I could wave my hands and mumble about "aggressive lexical scope" or something, but actually the choice here is that speed trumps that ol' hobgoblin consistency. If you want to change gcd to +, do it before loading code that calls gcd. I think most Schemes handle macros this way: the macro call is replaced by its expansion using its current definition, and a later redefinition does not affect earlier uses. Guile behaves like s7:(define (add1 x) (+ x 1)) (set! + -) (display (add1 3))) ; 4 in both s7 and Guile 3.0.4But if a Scheme function is involved, things get messy:
(define (fib n) (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2))))) (define oldfib fib) (set! fib 32) (display (oldfib 10))) ; s7 says 55, Guile says "wrong type to apply: 32"I can't decide which way is correct: s7 looks more consistent, but:
(define (fib n) 32) (set! fib (lambda (n) (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2)))))) (define oldfib fib) (set! fib 32) (display (oldfib 10)) ; "attempt to apply an integer 32 to..."So s7 is inconsistent too! (Actually this was consistent until Jan 2021 when I suddenly thought it was a mistake and "fixed" it; now I'm having second thoughts).
Here are some changes I'd make to s7 if I didn't care about compatibility with other Schemes:
- remove the exact/inexact distinction including #i and #e (done! #i means int-vector constant).
- remove call-with-values and its friends
- remove char-ready?
- change eof-object? to eof? or just omit it (you can use eq? #<eof>)
- change make-rectangular to complex (done!), and remove make-polar.
- remove unquote (the name, not the functionality).
- remove cond-expand.
- remove *-ci functions
- remove #d (done!)
(most of these are removed if you set the compiler flag WITH_PURE_S7), and perhaps:
- remove even? and odd?, gcd and lcm.
- remove string-length and vector-length.
- remove list-ref|set!, string-ref|set!, vector-ref|set!, hash-table-ref|set!, set-car!|cdr!, and set-current-output|input|error-port.
- change file-exists? to file? (or omit it and assume the use of libc.scm — why reinvent the wheel?).
- remove all the conversion and copy functions like vector->list and vector-copy (use copy or map).
- change string->symbol to symbol (what to do with symbol->string in that case?)
- change with-output-to-* and with-input-from-* to omit the pointless lambda.
- remove the with-* IO functions (e.g. with-input-from-string), keeping the call-with-* versions (call-with-input-string).
- remove assq, assv, memq, and memv (these are pointless now that assoc and member can be passed eq? and eqv?).
- move all the "*var*" names to *s7*: *load-hook* becomes (*s7* 'load-hook) for example.
Currently WITH_PURE_S7:
- places 'pure-s7 in *features*
- omits char-ready, char-ci*, string-ci*
- omits string-fill!, vector-fill!, vector-append
- omits list->string, list->vector, string->list, vector->list, let->list
- omits string-length and vector-length
- omits cond-expand, multiple-values-bind|set!, call-with-values
- omits unquote (the name)
- omits d/f/s/l exponents
- omits make-polar and make-rectangular (use complex)
- omits exact?, inexact?, exact->inexact, inexact->exact
- omits set-current-output-port and set-current-input-port
With the move to s7_setter and s7_set_setter (setter in Scheme), dilambda and dilambda? have been reduced to trivial conveniences, so perhaps they can also be removed.
string-copy has 3 extra arguments to allow strings to be copied directly into other strings. In vectors, we can use subvector, but substring returns a new string (copying its argument) unless the optimizer notices that the copy is not needed. Copy almost works, but its start and end arguments refer to the source, not the destination. substring should be like subvector, but that is not backwards compatible.
There are several less-than-ideal names. get-output-string should be current-output-string. write-char behaves like display, not write. provided? should be feature? or *features* should be *provisions*. list-ref, list-set!, and list-tail actually only apply to pairs. let-temporarily should be templet, or maybe set-temporarily. define-expansion should be define-reader-macro, but that name collides with reader macros in Common Lisp. There should not be two names for the same thing: call/cc and call-with-current-continuation: flush the latter! The CL-inspired "log*" names such as logand look very old-fashioned. Standard scheme opts for the name "bitwise*"; why not "integerwise" or "bytevectorwise"? The "wise" business is just noise; are they thinking of The Hobbit?
(define & logand) (define | logior) (define ~ lognot)
, but ^ for logxor (as in C) is not ideal; ^ should be expt. Finally, I think the notion of a current input or output port is a mistake: the IO functions should always get an explicit port.cond-expand is dumb and its name is dumber. Take libgsl.scm; different versions of the GSL library have different functions. We need to know when we're building the FFI what GSL version we're dealing with. It would be nuts to start pushing and checking dozens of library version symbols when all we actually want is
(> version 23.19)
. In place of cond-expand, s7 uses reader-cond, so the read-time decision involves normal Scheme evaluation.Then there's the case case: a case clause without a result appears to be an error in r7rs. But the notation used to indicate that is the same as that used for begin, so if we allow
(begin)
, we should allow case clauses to have no explicit result. In cond, the "implicit progn" (in CL terminology) includes the test expression, so a clause without a result returns the test result (if true of course). In the case case, s7 returns the selector.(case x ((0 1)))
is equivalent to(case x ((0 1) => values))
, just as(cond (A))
is equivalent to(cond (A => values))
. One application is method lookup:((case (obj 'abs) ((#<undefined>) abs) (else)) ...)
; we would otherwise have to save the lookup result or do it twice. This choice has a ripple effect on do: if no result is specified for do, s7 returns the test result. It also affects hash-tables. Currently hash-table-ref returns #f if the key is not in the table, mimicking assoc and aimed at cond with =>, but if we also use case and #<undefined>, it seems more useful and maybe intuitive to mimic let-ref instead. But if hash-table-ref returns #<undefined>, it's harder to use hash-tables as sets. Hmm. In any case, the fall-through value of case should be (and is in s7) #<unspecified>: case is a form of if, so(if #f #f)
,(cond (#f #f))
, and(case #t ((#f) #f))
should be equal.Better ideas are always welcome!
Here are the built-in s7 variables:
- *features* ; a list of symbols
- *libraries* ; a list of (filename . let) pairs
- *load-path* ; a list of directories
- *cload-directory* ; directory for cload output
- *autoload* ; autoload info
- *#readers* ; a list of (char . handler) pairs
And the built-in constants:
- pi
- *stdin* *stdout* *stderr*
- *s7*
- +nan.0 -nan.0 +inf.0 -inf.0 (what crappy names! +nan.0 is a positive inexact integer that is not a number?)
- *unbound-variable-hook* *missing-close-paren-hook* *load-hook* *autoload-hook*
- *error-hook* *read-error-hook* *rootlet-redefinition-hook*
Is it odd that the "+" in +nan.0 can't be omitted, but as used in a complex number, someone drops a "+": 1+nan.0i?
(*function*) returns the name (or name and location) of the function currently being called.
(define (example) (*function*))
returns'example
. Here is an example using a bacro (to access the call-time environment) and an openlet to implement a probe; it reports any operation that the probe participates in, using *function* to get the calling function name:(define (probe-eval val) (let ((all-let (inlet))) (for-each (lambda (sym) (unless (immutable? sym) ; apply-values etc (let ((func (symbol->value sym (rootlet)))) (when (procedure? func) (varlet all-let sym (apply bacro 'args `((let-temporarily (((*s7* 'openlets) #f)) (let ((clean-args (map (lambda (arg) (if (eq? arg probe-eval) (probe-eval 'value) arg)) args))) (format *stderr* "(~S ~{~S~^ ~}) ; ~S~%" ,sym clean-args (*function* (outlet (outlet (curlet))))) (apply ,func clean-args)))))))))) (symbol-table)) (varlet all-let 'value val) (openlet all-let))) (define (call-any x) (+ x 21)) (call-any (probe-eval 42)) ; prints "(+ 42 21) ; call-any", returns 63The second argument to *function* is the let from which to start searching for a function. In the example above, we start the search from the let outside the bacro, since we hope to find the bacro's caller. As a convenience, *function* takes an optional third argument specifying what information you want about the current function. An example:
(*function* (curlet) 'name)
.name
returns the name (a symbol) of the current function.line
returns the function's definition line number.file
returns the function's definition file. Other possibilities aresignature
,documentation
,arity
,arglist
,value
, andsource
.funclet
returns the current function's funclet.Schemes vary in their treatment of (). s7 considers it a constant that evaluates to itself, so you don't need to quote it.
(eq? () '())
is #t. This is consistent with, for example,(eq? #f '#f)
which is also #t. The standard says "the empty list is a special object of its own type", so surely either choice is acceptable in that regard (but, sigh, the standard stupidly goes on to deny that () can evaluate to itself). (I'm told that "is an error" means "is not portable" in the standard's weasely abuse of English; if they mean "is not portable" why not say so?). Some of the confusion appears to be caused by the word "list". I would describe the evaluator: "if it gets a constant (and () is a constant) it returns that constant; if a symbol, it returns the value associated with that symbol; if a pair, it looks at the pair's car to decide what to do". It's kinda looney to insist on looking at the car of a list when you know () has no car!Similarly, in s7, vector constants do not have to be quoted. A list constant is quoted to keep it from being evaluated, but #(1 2 3) is as unproblematic as "123" or 123.
These examples bring up another odd corner of scheme: else. In
(cond (else 1))
the 'else is evaluated (like any cond test), so its value might be #f; in(case 0 (else 1))
it is not evaluated (like any case key), so it's just a symbol. Since setters are local in s7, someone can(let ((else #f)) (cond (else 1)))
even if we protect the rootlet 'else. Of course, in scheme this kind of trouble is pervasive, so rather than make 'else a constant I think the best path is to use unlet:(let ((else #f)) (cond (#_else 1)))
. This is 1 (not ()) because the initial value of 'else can't be changed.s7 handles circular lists and vectors and dotted lists with its customary aplomb. You can pass them to memq, or print them, for example; you can even evaluate them. The print syntax is borrowed from CL:
> (let ((lst (list 1 2 3))) (set! (cdr (cdr (cdr lst))) lst) lst) #1=(1 2 3 . #1#) > (let* ((x (cons 1 2)) (y (cons 3 x))) (list x y)) (#1=(1 . 2) (3 . #1#))But should this syntax be readable as well? I'm inclined to say no because then it is part of the language, and it doesn't look like the rest of the language. (I think it's kind of ugly). Perhaps we could implement it via *#readers*:
(define circular-list-reader (let ((known-vals #f) (top-n -1)) (lambda (str) (define (replace-syms lst) ;; walk through the new list, replacing our special keywords ;; with the associated locations (define (replace-sym tree getter) (if (keyword? (getter tree)) (let ((n (string->number (symbol->string (keyword->symbol (getter tree)))))) (if (integer? n) (let ((lst (assoc n known-vals))) (if lst (set! (getter tree) (cdr lst)) (format *stderr* "#~D# is not defined~%" n))))))) (let walk-tree ((tree (cdr lst))) (if (pair? tree) (begin (if (pair? (car tree)) (walk-tree (car tree)) (replace-sym tree car)) (if (pair? (cdr tree)) (walk-tree (cdr tree)) (replace-sym tree cdr)))) tree)) ;; str is whatever followed the #, first char is a digit (let* ((len (length str)) (last-char (str (- len 1)))) (and (memv last-char '(#\= #\#)) ; is it #n= or #n#? (let ((n (string->number (substring str 0 (- len 1))))) (and (integer? n) (begin (if (not known-vals) ; save n so we know when we're done (begin (set! known-vals ()) (set! top-n n))) (if (char=? last-char #\=) ; #n= (and (eqv? (peek-char) #\() ; eqv? since peek-char can return #<eof> (let ((cur-val (assoc n known-vals))) ;; associate the number and the list it points to ;; if cur-val, perhaps complain? (#n# redefined) (let ((lst (catch #t read (lambda args ; a read error (set! known-vals #f) ; so clear our state (apply throw args))))) ; and pass the error on up (if cur-val (set! (cdr cur-val) lst) (set! known-vals (cons (set! cur-val (cons n lst)) known-vals)))) (if (= n top-n) ; replace our special keywords (let ((result (replace-syms cur-val))) (set! known-vals #f) ; '#1=(#+gsl #1#) -> '(:1)! result) (cdr cur-val)))) ; #n=<not a list>? ;; else it's #n# — set a marker for now since we may not ;; have its associated value yet. We use a symbol name that ;; string->number accepts. (symbol->keyword (symbol (number->string n) (string #\null) " ")))))) ; #n<not an integer>? ))))) ; #n<something else>? (do ((i 0 (+ i 1))) ((= i 10)) ;; load up all the #n cases (set! *#readers* (cons (cons (integer->char (+ i (char->integer #\0))) circular-list-reader) *#readers*))) > '#1=(1 2 . #1#) #1=(1 2 . #1#) > '#1=(1 #2=(2 . #2#) . #1#) #2=(1 #1=(2 . #1#) . #2#)And of course, we can treat these as labels:
(let ((ctr 0)) #1=(begin (format () "~D " ctr) (set! ctr (+ ctr 1)) (if (< ctr 4) #1# (newline))))which prints "0 1 2 3" and a newline.
Length returns +inf.0 if passed a circular list, and returns a negative number if passed a dotted list. In the dotted case, the absolute value of the length is the list length not counting the final cdr.
(define (circular? lst) (infinite? (length lst)))
.cyclic-sequences returns a list of the cyclic sequences in its argument, or nil.
(define (cyclic? obj) (pair? (cyclic-sequences obj)))
.Here's an amusing use of circular lists:
(define (for-each-permutation func vals) ;; apply func to every permutation of vals: ;; (for-each-permutation (lambda args (format () "~{~A~^ ~}~%" args)) '(1 2 3)) (define (pinner cur nvals len) (if (= len 1) (apply func (car nvals) cur) (do ((i 0 (+ i 1))) ; I suppose a named let would be more Schemish ((= i len)) (let ((start nvals)) (set! nvals (cdr nvals)) (let ((cur1 (cons (car nvals) cur))) ; add (car nvals) to our arg list (set! (cdr start) (cdr nvals)) ; splice out that element and (pinner cur1 (cdr start) (- len 1)) ; pass a smaller circle on down, "wheels within wheels" (set! (cdr start) nvals)))))) ; restore original circle (let ((len (length vals))) (set-cdr! (list-tail vals (- len 1)) vals) ; make vals into a circle (pinner () vals len) (set-cdr! (list-tail vals (- len 1)) ()))) ; restore its original shapes7 and Snd use "*" in a variable name, *features* for example, to indicate that the variable is predefined. It may occur unprotected in a macro, for example. The "*" doesn't mean that the variable is special in the CL sense of dynamic scope, but some clear marker is needed for a global variable so that the programmer doesn't accidentally step on it.
Although a variable name's first character is more restricted, currently only #\null, #\newline, #\tab, #\space, #\), #\(, #\", and #\; can't occur within the name. I did not originally include double-quote in this set, so wild stuff like
(let ((nam""e 1)) nam""e)
would work, but that means that'(1 ."hi")
is parsed as a 1 and the symbol."hi"
, and(string-set! x"hi")
is an error. The first character should not be #\#, #\', #\`, #\,, #\:, or any of those mentioned above, and some characters can't occur by themselves. For example, "." is not a legal variable name, but ".." is. These weird symbols have to be printed sometimes:> (list 1 (string->symbol (string #\; #\" #\\)) 2) (1 ;"\ 2) > (list 1 (string->symbol (string #\.)) 2) (1 . 2)which is a mess. Guile prints the first as
(1 #{\;\"\\}# 2)
. In CL and some Schemes:[1]> (list 1 (intern (coerce (list #\; #\" #\\) 'string)) 2) ; thanks to Rob Warnock (1 |;"\\| 2) [2]> (equalp 'A '|A|) ; in CL case matters here TThis is clean, and has the weight of tradition behind it, but I think I'll use "symbol" instead:
> (list 1 (string->symbol (string #\; #\" #\\)) 2) (1 (symbol ";\"\\") 2)This output is readable, and does not eat up perfectly good characters like vertical bar, but it means we can't easily use variable names like "| e t c |". We could allow a name to contain any characters if it starts and ends with "|", but then one vertical bar is trouble.
The symbol function accepts any number of string arguments which it concatenates to form the new symbol name.
These symbols are not just an optimization of string comparison:
> (define-macro (hi a) (let ((funny-name (string->symbol ";"))) `(let ((,funny-name ,a)) (+ 1 ,funny-name)))) hi > (hi 2) 3 > (macroexpand (hi 2)) (let ((; 2)) (+ 1 ;)) ; for a good time, try (string #\") > (define-macro (hi a) (let ((funny-name (string->symbol "| e t c |"))) `(let ((,funny-name ,a)) (+ 1 ,funny-name)))) hi > (hi 2) 3 > (macroexpand (hi 2)) (let ((| e t c | 2)) (+ 1 | e t c |)) > (let ((funny-name (string->symbol "| e t c |"))) ; now use it as a keyword arg to a function (apply define* `((func (,funny-name 32)) (+ ,funny-name 1))) ;; (procedure-source func) is (lambda* ((| e t c | 32)) (+ | e t c | 1)) (apply func (list (symbol->keyword funny-name) 2))) 3I hope that makes you as happy as it makes me!
The built-in syntactic forms, such as "begin", are almost first-class citizens.
> (let ((progn begin)) (progn (define x 1) (set! x 3) (+ x 4))) 7 > (let ((function lambda)) ((function (a b) (list a b)) 3 4)) (3 4) > (apply begin '((define x 3) (+ x 2))) 5 > ((lambda (n) (apply n '(((x 1)) (+ x 2)))) let) 3 (define-macro (symbol-set! var val) ; like CL's set `(apply set! ,var ',val ())) ; trailing nil is just to make apply happy — apply*? (define-macro (progv vars vals . body) `(apply (apply lambda ,vars ',body) ,vals)) > (let ((s '(one two)) (v '(1 2))) (progv s v (+ one two))) 3We can snap together program fragments ("look Ma, no macros!"):
(let* ((x 3) (arg '(x)) (body `((+ ,x x 1)))) ((apply lambda arg body) 12)) ; "legolambda"? (define (engulph form) (let ((body `(let ((L ())) (do ((i 0 (+ i 1))) ((= i 10) (reverse L)) (set! L (cons ,form L)))))) (define function (apply lambda () (list (copy body)))) (function))) (let () (define (hi a) (+ a x)) ((apply let '((x 32)) (list (procedure-source hi))) 12)) ; one function, many closures? (let ((ctr -1)) ; (enum zero one two) but without using a macro (apply begin (map (lambda (symbol) (set! ctr (+ ctr 1)) (list 'define symbol ctr)) ; e.g. '(define zero 0) '(zero one two))) (+ zero one two))But there's a prettier way to implement enum ("transparent-for-each"):
> (define-macro (enum . args) `(for-each define ',args (iota (length ',args)))) enum > (enum a b c) #<unspecified> > b 1Now we notice that
(case 0.0 ((0.0) 1) (else 0))
is 1, but how to get pi into a key list?> (apply case 'pi `(((,pi) 1) (else 0))) 1 > (let ((lst '(1 2))) (apply case 'lst `(((,lst) 1) (else 0)))) 1 ; same trick puts a list in the keys > (apply case '+nan.0 `(((,+nan.0) 1) (else 0))) 0 ; (eqv? +nan.0 +nan.0) is #f
(apply define ...)
is similar to CL's set.> ((apply define-macro '((m a) `(+ 1 ,a))) 3) 4 > ((apply define '((hi a) (+ a 1))) 3) 4Apply let is very similar to eval:
> (apply let '((a 2) (b 3)) '((+ a b))) 5 > (eval '(+ a b) (inlet 'a 2 'b 3)) 5 > ((apply lambda '(a b) '((+ a b))) 2 3) 5 > (apply let '((a 2) (b 3)) '((list + a b))) ; a -> 2, b -> 3 (+ 2 3)The redundant-looking double lists are for apply's benefit. We could use a trailing null instead (mimicking apply* in some ancient lisps):
> (apply let '((a 2) (b 3)) '(list + a b) ()) (+ 2 3)Scheme claims that it evaluates the car of an expression, then calls the result with the rest of the expression. So
((if x + -) y z)
calls either(+ y z)
or(- y z)
depending on x. But only s7, as far as I know, handles((if x or and) y z)
.catch, dynamic-wind, and many of the other functions that take function arguments in standard Scheme, accept macros in s7, and dynamic-wind accepts #f as the initial and final entries.
Currently, you can't set! a built-in syntactic keyword to some new value:
(set! if 3)
. let-temporarily uses set!, so(let-temporarily ((if 3))...)
is also unlikely to work.Speaking of speed... It is widely believed that a Scheme with first class everything can't hope to compete with any "real" Scheme. Humph I say. Take this little example (which is not so misleading that I feel guilty about it):
(define (do-loop n) (do ((i 0 (+ i 1))) ((= i n)) (if (zero? (modulo i 1000)) (display "."))) (newline)) (for-each do-loop (list 1000 1000000 10000000))In s7, that takes 0.09 seconds on my home machine. In tinyScheme, from whence we sprang, it takes 85 seconds. In the chicken interpreter, 5.3 seconds, and after compilation (using -O2) of the chicken compiler output, 0.75 seconds. So, s7 is comparable to chicken in speed, even though chicken is compiling to C. I think Guile 2.0.9 takes about 1 second. The equivalent in CL: clisp interpreted 9.3 seconds, compiled 0.85 seconds; sbcl 0.21 seconds. Similarly, s7 computes (fib 40) in 0.8 seconds, approximately the same as sbcl. Guile 2.2.3 takes 7 seconds.
s7's timing tests are in its tools directory. The script valcall.scm runs them through callgrind. The results can be found at the end of s7.c. If you're interested in the standard Scheme benchmarks, it is possible to add s7 to that package. First, s7-prelude.scm and s7-postlude.scm need to be added to the benchmarks src directory. s7-postlude.scm can be empty. My version of s7-prelude.scm is:
(define (this-scheme-implementation-name) "s7") (define exact-integer? integer?) (define (exact-integer-sqrt i) (let ((sq (floor (sqrt i)))) (values sq (- i (* sq sq))))) (define inexact exact->inexact) (define exact inexact->exact) (define (square x) (* x x)) (define (vector-map f v) (copy v)) ; for quicksort.scm (define-macro (import . args) #f) (define (jiffies-per-second) 1000) (define (current-jiffy) (round (* (jiffies-per-second) (*s7* 'cpu-time)))) (define (current-second) (floor (*s7* 'cpu-time)))If you want to run gcbench, add the define-record-type macro from r7rs.scm. Here are the diffs for the bench script:
141a142 > S7=${S7:-"/home/bil/motif-snd/repl"} 187a189 > s7 for s7 406a409,421 > # Definitions specific to s7 > > s7_comp () > { > : > } > > s7_exec () > { > time ${S7} "$1" < "$2" > } > > # ----------------------------------------------------------------------------- 940a957,966 > > s7) NAME='s7' > COMP=s7_comp > EXEC=s7_exec > COMPOPTS="" > EXTENSION="scm" > EXTENSIONCOMP="scm" > COMPCOMMANDS="" > EXECCOMMANDS="" > ;;I call the standalone version of s7 "repl", so its path is /home/bil/motif-snd/repl. To build repl, get s7.tar.gz from https://ccrma.stanford.edu/software/s7/s7.tar.gz; if not using gcc or clang, add the empty file mus-config.h to the tarball's contents, then (in Linux):
gcc s7.c -o repl -DWITH_MAIN -I. -O2 -g -ldl -lm -Wl,-export-dynamic ;; tcc -o s7 s7.c -I. -lm -DWITH_MAIN -ldl -rdynamic -DWITH_C_LOADERFor timing tests, I add "-fomit-frame-pointer -funroll-loops -march=native". mus-config.h normally has
#define HAVE_COMPLEX_NUMBERS 1 #define HAVE_COMPLEX_TRIG 1but s7.c has defaults, so mus-config.h can be empty, or absent. Finally, go back to the benchmarks directory and
bench s7 allThe benchmark compiler.scm assumes that small integers can be compared with eq? (via assq), which is incorrect. pi.scm and chudnovsky.scm need the gmp version of s7. I ran the bench script on an AMD 3950X machine, and got these results (in seconds): ack: 6.6, array1: 6.4, browse: 11.2, bv2string: 4.1, cat: 0.4, compiler: 16.9, conform: 30.0, cpstak: 42.8, ctak: 16.6, deriv: 9.7, destruc: 8.6, diviter: 3.7, divrec: 4.6, dynamic: 12.6, earley: 25.5, equal: 0.3, fft: 12.5, fib: 6.1, fibc: 8.6, fibfp: 1.1, gcbench: 12.9, grahps: 72.5, lattice: 63.4, matrix: 21.0, maze: 11.4, mazefun: 9.8, mbrot: 12.6, mbrotZ: 8.0, mperm: 18.9, nboyer: 20.1, nqueens: 27.0, ntakl: 8.0, nucleic: 8.3, paraffins: 4.4, parsing: 20.7, peval: 15.2, pnpoly: 9.8, primes: 10.2, puzzle: 10.2, quicksort: 40.0, ray: 8.3, read1: 0.2, sboyer: 19.1, scheme: 29.5, simplex: 26.9, slatex: 4.2, string: 0.8, sum1: 0.2, sum: 4.1, sumfp: 2.2, tail: 0.1, tak: 7.1, takl: 8.1, triangl: 16.4, wc: 4.9. In the gmp case, chudnovsky: 0.017, pi: .01.
In s7, there is only one kind of begin statement, and it can contain both definitions and expressions. These are evaluated in the order in which they occur, and in the environment at the point of the evaluation. I think of it as being a little REPL. begin does not introduce a new frame in the current environment, so defines happen in the enclosing environment. Finally, begin, explicit or otherwise, does not pretend to emulate letrec*.
If we allow defines anywhere, the notion of "lexical scope" becomes problematic. Scheme is already a mess in that regard: take
(let ((x 1)) (do ((y x x) (x 3)) ((> y 1) y)))In
(y x x)
the first x is the outer one, and the second is the following do variable, so this returns 3! But sticking to define, in(let ((x 1)) (define y x) (define x 2) y)s7 returns 1 even though technically the second x is in y's environment. Since we treat this as a REPL, y gets its value from the only x defined at the point it is defined. However,
(let ((x 1)) (define y (lambda () x)) (define x 2) (y))returns 2 in s7 because the x in y's function body is not evaluated until after the second x is defined. The define propagates backwards, but:
(list x (define x 0))
, or(list x (begin (define x 0) x))
.The r7rs compatibility code is in r7rs.scm. I used to include it here, but as r7rs grew, this section got too large. In general, all the conversion routines in r7rs are handled in s7 via generic functions, records are classes, and so on.
"Life", a poem.
(+(*(+))(*)(+(+)(+)(*))) (((((lambda () (lambda () (lambda () (lambda () 1)))))))) (+ (((lambda () values)) 1 2 3)) (map apply (list map) (list map) (list (list *)) '((((1 2)) ((3 4 5))))) (do ((do do do)) (do do do)) (*(*)(*) (+)(+) 1)
s7 exists only to serve as an extension of some other application, so it is primarily a foreign function interface. s7.h has lots of comments about the individual functions. Here I'll collect some complete examples. s7.c depends on the following compile-time flags:
SIZEOF_VOID_P 8 (default) or 4. WITH_GMP 1 if you want multiprecision arithmetic (requires gmp, mpfr, and mpc, default is 0) HAVE_COMPLEX_NUMBERS 1 if your compiler supports complex numbers HAVE_COMPLEX_TRIG 1 if your math library has complex versions of the trig functions DISABLE_DEPRECATED 1 if you want to make sure you're not using any deprecated s7 stuff (default is 0) WITH_IMMUTATBLE_UNQUOTE 1 if you want "unquote" omitted (default is 0) WITH_EXTRA_EXPONENT_MARKERS 1 if you want "d", "f", "l", and "s" in addition to "e" as exponent markers (default is 0) if someone defends these exponent markers, ask him to read 1l11+11l1i (in 2 million lines of open-source Scheme, there is not one use of these silly things) WITH_SYSTEM_EXTRAS 1 if you want some additional OS-related functions built-in (default is 0) WITH_MAIN 1 if you want s7.c to include a main program section that runs a REPL. WITH_C_LOADER 1 if you want to be able to load shared object files with load.
See the comment at the start of s7.c for more information about these switches. s7.h defines the two main number types: s7_int and s7_double. The examples that follow show:
#include <stdlib.h> #include <stdio.h> #include <string.h> #include "s7.h" int main(int argc, char **argv) { s7_scheme *s7 = s7_init(); /* initialize the interpreter */ while (1) /* fire up a read-eval-print loop */ { char buffer[512]; fprintf(stdout, "\n> "); /* prompt for input */ fgets(buffer, 512, stdin); if ((buffer[0] != '\n') || (strlen(buffer) > 1)) { /* evaluate the input and print the result */ char response[1024]; snprintf(response, 1024, "(write %s)", buffer); s7_eval_c_string(s7, response); }} } /* if not using gcc or clang, make mus-config.h (it can be empty), then * * gcc -c s7.c -I. * gcc -o repl repl.c s7.o -lm -I. -ldl * * run it: * * repl * > (+ 1 2) * 3 * > (define (add1 x) (+ 1 x)) * add1 * > (add1 2) * 3 * > (exit) * * for long-term happiness in linux use: * gcc -o repl repl.c s7.o -Wl,-export-dynamic -lm -I. -ldl * clang also needs -fPIC I think * freebsd: * gcc -o repl repl.c s7.o -Wl,-export-dynamic -lm -I. * osx: * gcc -o repl repl.c s7.o -lm -I. * openbsd: * clang -o repl repl.c s7.o -I. -fPIC -Wl,-export-dynamic -lm */
Since this reads stdin and writes stdout, it can be run as a Scheme subjob of emacs. One (inconvenient) way to do this is to set the emacs variable scheme-program-name to the name of the exectuable created above ("repl"), then call the emacs function run-scheme: M-x eval-expression in emacs, followed by (setq scheme-program-name "repl"), then M-x run-scheme, and you're talking to s7 in emacs. Of course, this connection can be customized indefinitely. See, for example, inf-snd.el in the Snd package.
Here are the not-always-built-in indentations I use in emacs:
(put 'with-let 'scheme-indent-function 1) (put 'with-baffle 'scheme-indent-function 0) (put 'with-sound 'scheme-indent-function 1) (put 'catch 'scheme-indent-function 1) (put 'lambda* 'scheme-indent-function 1) (put 'when 'scheme-indent-function 1) (put 'let-temporarily 'scheme-indent-function 1) (put 'let*-temporarily 'scheme-indent-function 1) (put 'call-with-input-string 'scheme-indent-function 1) (put 'unless 'scheme-indent-function 1) (put 'letrec* 'scheme-indent-function 1) (put 'sublet 'scheme-indent-function 1) (put 'varlet 'scheme-indent-function 1) (put 'case* 'scheme-indent-function 1)
To read stdin while working in a GUI-based program is trickier. In glib, you can use something like this:
static gboolean read_stdin(GIOChannel *source, GIOCondition condition, gpointer data) { /* here read from g_io_channel_unix_get_fd(source) and call s7_eval_string */ return(true); } /* ... during initialization ... */ GIOChannel *channel; channel = g_io_channel_unix_new(STDIN_FILENO); /* watch stdin */ stdin_id = g_io_add_watch_full(channel, /* and call read_stdin above if input is noticed */ G_PRIORITY_DEFAULT, (GIOCondition)(G_IO_IN | G_IO_HUP | G_IO_ERR), read_stdin, NULL, NULL); g_io_channel_unref(channel);
Here's a version that uses libtecla for the line editor:
#include <stdlib.h> #include <stdio.h> #include <string.h> #include <libtecla.h> #include "s7.h" int main(int argc, char **argv) { GetLine *gl = new_GetLine(500, 5000); /* The tecla line editor */ s7_scheme *s7 = s7_init(); while (1) { char *buffer; buffer = gl_get_line(gl, "> ", NULL, 0); if ((buffer[0] != '\n') || (strlen(buffer) > 1)) { char response[1024]; snprintf(response, 1024, "(write %s)", buffer); s7_eval_c_string(s7, response); fprintf(stdout, "\n"); }} gl = del_GetLine(gl); } /* * gcc -c s7.c -I. -O2 -g3 * gcc -o ex1 ex1.c s7.o -lm -I. -ltecla -ldl */
A repl (based on repl.scm or nrepl.scm) is built into s7. Include the compiler flag -DWITH_MAIN:
gcc -o nrepl s7.c -O2 -I. -Wl,-export-dynamic -lm -ldl -DWITH_MAIN -DWITH_NOTCURSES -lnotcurses-core
Common Lisp has something called "evalhook" that makes it possible to insert your own function into the eval loop. In s7, we have a "begin_hook" which sits at the opening of many begin blocks (implicit or explicit). begin_hook is a (C) function; if it sets its bool argument to true, s7 interrupts the current evaluation. Here is a version of the REPL in which begin_hook watches for C-g to interrupt some long computation:
/* terminal-based REPL, * an expansion of the read-eval-print loop program above. * type C-g to interrupt an evaluation. */ #include <stdlib.h> #include <stdio.h> #include <string.h> #include <termios.h> #include <signal.h> #include "s7.h" static struct termios save_buf, buf; static void sigcatch(int n) { /* put things back the way they were */ tcsetattr(fileno(stdin), TCSAFLUSH, &save_buf); exit(0); } static char buffer[512]; static int type_ahead_point = 0; static void watch_for_c_g(s7_scheme *sc, bool *all_done) { char c; /* watch for C-g without blocking, save other chars as type-ahead */ tcsetattr(fileno(stdin), TCSAFLUSH, &buf); if (read(fileno(stdin), &c, 1) == 1) { if (c == 7) /* C-g */ { *all_done = true; type_ahead_point = 0; } else buffer[type_ahead_point++] = c; } tcsetattr(fileno(stdin), TCSAFLUSH, &save_buf); } int main(int argc, char **argv) { s7_scheme *s7; bool use_begin_hook = (tcgetattr(fileno(stdin), &save_buf) >= 0); if (use_begin_hook) { buf = save_buf; buf.c_lflag &= ~ICANON; buf.c_cc[VMIN] = 0; buf.c_cc[VTIME] = 0; signal(SIGINT, sigcatch); signal(SIGQUIT, sigcatch); signal(SIGTERM, sigcatch); } s7 = s7_init(); if (argc == 2) { fprintf(stderr, "load %s\n", argv[1]); if (!s7_load(s7, argv[1])) fprintf(stderr, "can't find %s\n", argv[1]); } else { while (1) { fprintf(stdout, "\n> "); fgets((char *)(buffer + type_ahead_point), 512 - type_ahead_point, stdin); type_ahead_point = 0; if ((buffer[0] != '\n') || (strlen(buffer) > 1)) { char response[1024]; snprintf(response, 1024, "(write %s)", buffer); if (use_begin_hook) s7_set_begin_hook(s7, watch_for_c_g); s7_eval_c_string(s7, response); if (use_begin_hook) s7_set_begin_hook(s7, NULL); }}} if (use_begin_hook) tcsetattr(fileno(stdin), TCSAFLUSH, &save_buf); }
#include <stdlib.h> #include <stdio.h> #include <string.h> #include "s7.h" static s7_pointer add1(s7_scheme *sc, s7_pointer args) { /* all added functions have this form, args is a list, * s7_car(args) is the first arg, etc */ if (s7_is_integer(s7_car(args))) return(s7_make_integer(sc, 1 + s7_integer(s7_car(args)))); return(s7_wrong_type_arg_error(sc, "add1", 1, s7_car(args), "an integer")); } int main(int argc, char **argv) { s7_scheme *s7 = s7_init(); s7_define_function(s7, "add1", add1, 1, 0, false, "(add1 int) adds 1 to int"); /* add the function "add1" to the interpreter. * 1, 0, false -> one required arg, * no optional args, * no "rest" arg */ s7_define_variable(s7, "my-pi", s7_make_real(s7, 3.14159265)); while (1) /* fire up a "repl" */ { char buffer[512]; fprintf(stdout, "\n> "); /* prompt for input */ fgets(buffer, 512, stdin); if ((buffer[0] != '\n') || (strlen(buffer) > 1)) { char response[1024]; snprintf(response, 1024, "(write %s)", buffer); s7_eval_c_string(s7, response); /* evaluate input and write the result */ }} } /* doc7 * > my-pi * 3.14159265 * > (+ 1 (add1 1)) * 3 * > (exit) */
#include <stdlib.h> #include <stdio.h> #include <string.h> #include "s7.h" int main(int argc, char **argv) { s7_scheme *s7 = s7_init(); s7_define_variable(s7, "an-integer", s7_make_integer(s7, 1)); s7_eval_c_string(s7, "(define (add1 a) (+ a 1))"); fprintf(stderr, "an-integer: %lld\n", s7_integer(s7_name_to_value(s7, "an-integer"))); s7_symbol_set_value(s7, s7_make_symbol(s7, "an-integer"), s7_make_integer(s7, 32)); fprintf(stderr, "now an-integer: %lld\n", s7_integer(s7_name_to_value(s7, "an-integer"))); fprintf(stderr, "(add1 2): %lld\n", s7_integer(s7_call(s7, s7_name_to_value(s7, "add1"), s7_cons(s7, s7_make_integer(s7, 2), s7_nil(s7))))); } /* * doc7 * an-integer: 1 * now an-integer: 32 * (add1 2): 3 */
In more complicated cases, it is probably easier use s7_eval_c_string_with_environment. As an example, say we want to have a C procedure that calls the pretty printer function pp in write.scm, returning a string to C. We need to make sure pp is loaded, and catch any errors that come up. And we need to pass the C-level s7 object to pp. So...
static const char *pp(s7_scheme *sc, s7_pointer obj) /* (pp obj) */ { return(s7_string( s7_eval_c_string_with_environment(sc, "(catch #t \ (lambda () \ (unless (defined? 'pp) \ (load \"write.scm\")) \ (pp obj)) \ (lambda (type info) \ (apply format #f info)))", s7_inlet(sc, s7_list(sc, 1, s7_cons(sc, s7_make_symbol(sc, "obj"), obj)))))); }
and now when we want a pretty-printed representation of something: pp(sc, obj);
The s7_inlet call is creating a local environment with the object "obj" bound
in scheme to the name "obj" so that (pp obj) will find the "obj" that actually
lives in C. You may need to give the full filename for write.scm, or add its path
to the load-path list. In the latter case, (require write.scm)
could
replace (unless (defined?...))
.
int main(int argc, const char* argv[]) { initialiseJuce_NonGUI(); s7_scheme *s7 = s7_init(); if (!s7) { std::cout << "Can't start S7!\n"; return -1; } while (true) { s7_pointer val; std::string str; std::cout << "\ns7> "; std::getline(std::cin, str); val = s7_eval_c_string(s7, str.c_str()); std::cout << s7_object_to_c_string(s7, val); } free(s7); std::cout << "Bye!\n"; return 0; }
#include <stdlib.h> #include <stdio.h> #include <string.h> #include <unistd.h> /* assume we've configured and built sndlib, so it has created a mus-config.h file. * also assume we've built s7 with WITH_SYSTEM_EXTRAS set, so we have file-exists? and delete-file */ #include "mus-config.h" #include "s7.h" #include "xen.h" #include "clm.h" #include "clm2xen.h" /* we need to redirect clm's mus_error calls to s7_error */ static void mus_error_to_s7(int type, char *msg) { s7_error(s7, /* s7 is declared in xen.h, defined in xen.c */ s7_make_symbol(s7, "mus-error"), s7_cons(s7, s7_make_string(s7, msg), s7_nil(s7))); } int main(int argc, char **argv) { s7 = s7_init(); /* initialize the interpreter */ s7_xen_initialize(s7); /* initialize the xen stuff (hooks and the xen s7 FFI used by sndlib) */ Init_sndlib(); /* initialize sndlib with all the functions linked into s7 */ mus_error_set_handler(mus_error_to_s7); /* catch low-level errors and pass them to s7-error */ while (1) /* fire up a "repl" */ { char buffer[512]; fprintf(stdout, "\n> "); /* prompt for input */ fgets(buffer, 512, stdin); if ((buffer[0] != '\n') || (strlen(buffer) > 1)) { char response[1024]; snprintf(response, 1024, "(write %s)", buffer); s7_eval_c_string(s7, response); /* evaluate input and write the result */ }} } /* gcc -o doc7 doc7.c -lm -I. /usr/local/lib/libsndlib.a -lasound -ldl * * (load "sndlib-ws.scm") * (with-sound () (outa 10 .1)) * (load "v.scm") * (with-sound () (fm-violin 0 .1 440 .1)) * * you might also need -lgsl -lgslcblas -lfftw3 */
If you built libsndlib.so, it is possible to use it directly in the s7 repl:
repl ; this is a bare s7 running repl.scm via -DWITH_MAIN=1 loading libc_s7.so > (load "/home/bil/test/sndlib/libsndlib.so" (inlet 'init_func 's7_init_sndlib)) #t ; s7_init_sndlib ties all the sndlib functions and variables into s7 > (load "sndlib-ws.scm") tmpnam > (set! *clm-player* (lambda (file) (system (format #f "sndplay ~A" file)))) > (load "v.scm") fm-violin > (with-sound (:play #t) (fm-violin 0 1 440 .1)) "test.snd"
You can use autoload to load libsndlib when needed:
(define (find-library name) (if (or (file-exists? name) (char=? (name 0) #\/)) name (call-with-exit (lambda (return) (for-each (lambda (path) (let ((new-name (string-append path "/" name))) (if (file-exists? new-name) (return new-name)))) *load-path*) (let ((libs (getenv "LD_LIBRARY_PATH")) ; colon separated directory names (start 0)) (do ((colon (char-position #\: libs) (char-position #\: libs start))) ((or (not colon) (let ((new-name (string-append (substring libs start colon) "/" name))) (and (file-exists? new-name) (return new-name))))) (set! start (+ colon 1)))) name)))) (autoload 'clm (lambda (e) (load (find-library "libsndlib.so") (inlet '(init_func . s7_init_sndlib))) (set! *features* (cons 'clm *features*)) (with-let (rootlet) (define clm #t)) (load "sndlib-ws.scm") (set! *clm-player* (lambda (file) (system (format #f "sndplay ~A" file))))))
and use the repl's vt100 stuff to (for example) post the current begin time as a note list computes:
(define (clm-notehook . args) ;; assume second arg is begin time (first is instrument name) (when (and (pair? args) (pair? (cdr args)) (number? (cadr args))) (with-let (sublet (*repl* 'repl-let) :begin-time (cadr args)) (let ((coords (cursor-coords)) (col (floor (/ last-col 2)))) (let ((str (number->string begin-time))) (format *stderr* "~C[~D;~DH" #\escape prompt-row col) (format *stderr* "~C[K~A" #\escape (if (> (length str) col) (substring str 0 (- col 1)) str))) (format *stderr* "~C[~D;~DH" #\escape (cdr coords) (car coords)))))) (set! *clm-notehook* clm-notehook)
#include <stdlib.h> #include <stdio.h> #include <string.h> #include "s7.h" /* define *listener-prompt* in scheme, add two accessors for C get/set */ static const char *listener_prompt(s7_scheme *sc) { return(s7_string(s7_name_to_value(sc, "*listener-prompt*"))); } static void set_listener_prompt(s7_scheme *sc, const char *new_prompt) { s7_symbol_set_value(sc, s7_make_symbol(sc, "*listener-prompt*"), s7_make_string(sc, new_prompt)); } /* now add a new type, a struct named "dax" with two fields, a real "x" and a list "data" */ /* since the data field is an s7 object, we'll need to mark it to protect it from the GC */ typedef struct { s7_double x; s7_pointer data; } dax; static int dax_type_tag = 0; static s7_pointer dax_to_string(s7_scheme *sc, s7_pointer args) { s7_pointer result; dax *o = (dax *)s7_c_object_value(s7_car(args)); char *data_str = s7_object_to_c_string(sc, o->data); int data_str_len = strlen(data_str); char *str = (char *)calloc(data_str_len + 32, sizeof(char)); snprintf(str, data_str_len + 32, "<dax %.3f %s>", o->x, data_str); free(data_str); result = s7_make_string(sc, str); free(str); return(result); } static s7_pointer free_dax(s7_scheme *sc, s7_pointer obj) { free(s7_c_object_value(obj)); return(NULL); } static s7_pointer mark_dax(s7_scheme *sc, s7_pointer obj) { dax *o = (dax *)s7_c_object_value(obj); s7_mark(o->data); return(NULL); } static s7_pointer make_dax(s7_scheme *sc, s7_pointer args) { dax *o = (dax *)malloc(sizeof(dax)); o->x = s7_real(s7_car(args)); if (s7_cdr(args) != s7_nil(sc)) o->data = s7_cadr(args); else o->data = s7_nil(sc); return(s7_make_c_object(sc, dax_type_tag, (void *)o)); } static s7_pointer is_dax(s7_scheme *sc, s7_pointer args) { return(s7_make_boolean(sc, s7_is_c_object(s7_car(args)) && s7_c_object_type(s7_car(args)) == dax_type_tag)); } static s7_pointer dax_x(s7_scheme *sc, s7_pointer args) { dax *o = (dax *)s7_c_object_value(s7_car(args)); return(s7_make_real(sc, o->x)); } static s7_pointer set_dax_x(s7_scheme *sc, s7_pointer args) { dax *o = (dax *)s7_c_object_value(s7_car(args)); o->x = s7_real(s7_cadr(args)); return(s7_cadr(args)); } static s7_pointer dax_data(s7_scheme *sc, s7_pointer args) { dax *o = (dax *)s7_c_object_value(s7_car(args)); return(o->data); } static s7_pointer set_dax_data(s7_scheme *sc, s7_pointer args) { dax *o = (dax *)s7_c_object_value(s7_car(args)); o->data = s7_cadr(args); return(o->data); } static s7_pointer dax_is_equal(s7_scheme *sc, s7_pointer args) { dax *d1, *d2; s7_pointer p1 = s7_car(args); s7_pointer p2 = s7_cadr(args); if (p1 == p2) return(s7_t(sc)); if ((!s7_is_c_object(p2)) || (s7_c_object_type(p2) != dax_type_tag)) return(s7_f(sc)); d1 = (dax *)s7_c_object_value(p1); d2 = (dax *)s7_c_object_value(p2); return(s7_make_boolean(sc, (d1->x == d2->x) && (s7_is_equal(sc, d1->data, d2->data)))); } int main(int argc, char **argv) { s7_scheme *s7 = s7_init(); s7_define_variable(s7, "*listener-prompt*", s7_make_string(s7, ">")); dax_type_tag = s7_make_c_type(s7, "dax"); s7_c_type_set_gc_free(s7, dax_type_tag, free_dax); s7_c_type_set_gc_mark(s7, dax_type_tag, mark_dax); s7_c_type_set_is_equal(s7, dax_type_tag, dax_is_equal); s7_c_type_set_to_string(s7, dax_type_tag, dax_to_string); s7_define_function(s7, "make-dax", make_dax, 2, 0, false, "(make-dax x data) makes a new dax"); s7_define_function(s7, "dax?", is_dax, 1, 0, false, "(dax? anything) returns #t if its argument is a dax object"); s7_define_variable(s7, "dax-x", s7_dilambda(s7, "dax-x", dax_x, 1, 0, set_dax_x, 2, 0, "dax x field")); s7_define_variable(s7, "dax-data", s7_dilambda(s7, "dax-data", dax_data, 1, 0, set_dax_data, 2, 0, "dax data field")); while (1) { char buffer[512]; fprintf(stdout, "\n%s ", listener_prompt(s7)); fgets(buffer, 512, stdin); if ((buffer[0] != '\n') || (strlen(buffer) > 1)) { char response[1024]; snprintf(response, 1024, "(write %s)", buffer); s7_eval_c_string(s7, response); /* evaluate input and write the result */ }} } /* (in Linux); * gcc dax.c -o dax -I. -O2 -g s7.o -ldl -lm -Wl,-export-dynamic -Wno-stringop-overflow * dax * > *listener-prompt* * ">" * > (set! *listener-prompt* ":") * ":" * : (define obj (make-dax 1.0 (list 1 2 3))) * obj * : obj * #<dax 1.000 (1 2 3)> * : (dax-x obj) * 1.0 * : (dax-data obj) * (1 2 3) * : (set! (dax-x obj) 123.0) * 123.0 * : obj * #<dax 123.000 (1 2 3)> * : (dax? obj) * #t * : (exit) */
#include <stdlib.h> #include <stdio.h> #include <string.h> #include "s7.h" static void my_print(s7_scheme *sc, uint8_t c, s7_pointer port) { fprintf(stderr, "[%c] ", c); } static s7_pointer my_read(s7_scheme *sc, s7_read_t peek, s7_pointer port) { return(s7_make_character(sc, fgetc(stdin))); } int main(int argc, char **argv) { s7_scheme *s7 = s7_init(); s7_set_current_output_port(s7, s7_open_output_function(s7, my_print)); s7_define_variable(s7, "io-port", s7_open_input_function(s7, my_read)); while (1) { char buffer[512]; fprintf(stdout, "\n> "); fgets(buffer, 512, stdin); if ((buffer[0] != '\n') || (strlen(buffer) > 1)) { char response[1024]; snprintf(response, 1024, "(write %s)", buffer); s7_eval_c_string(s7, response); }} } /* * > (+ 1 2) * [3] * > (display "hiho") * [h] [i] [h] [o] [#] [<] [u] [n] [s] [p] [e] [c] [i] [f] [i] [e] [d] [>] * > (define (add1 x) (+ 1 x)) * [a] [d] [d] [1] * > (add1 123) * [1] [2] [4] * > (read-char io-port) * a ; here I typed "a" in the shell * [#] [\] [a] */
In Snd, we want debug.scm (*debug-port*) output to go to the Snd listener text widget. The Snd function listener_append adds a string to that widget's text, so we define:
static void (listener_write)(s7_scheme *sc, uint8_t c, s7_pointer port) { char buf[2]; buf[0] = c; buf[1] = '\0'; listener_append(buf); }
Then we define a Scheme-side variable, *listener-port*, to be a function port:
s7_define_variable_with_documentation(s7, "*listener-port*", s7_open_output_function(s7, listener_write), "port to write to Snd's listener");
And tie it into *debug-port* via
(set! ((funclet trace-in) '*debug-port*) *listener-port*)
.
There are several ways to do this. In the first example, we save the original function, and replace it with ours, calling the original whenever possible:
#include <stdlib.h> #include <stdio.h> #include <string.h> #include "s7.h" static s7_pointer old_add; /* the original "+" function for non-string cases */ static s7_pointer old_string_append; /* same, for "string-append" */ static s7_pointer our_add(s7_scheme *sc, s7_pointer args) { /* this will replace the built-in "+" operator, extending it to include strings: * (+ "hi" "ho") -> "hiho" and (+ 3 4) -> 7 */ if ((s7_is_pair(args)) && (s7_is_string(s7_car(args)))) return(s7_apply_function(sc, old_string_append, args)); return(s7_apply_function(sc, old_add, args)); } int main(int argc, char **argv) { s7_scheme *s7 = s7_init(); /* get built-in + and string-append */ old_add = s7_name_to_value(s7, "+"); old_string_append = s7_name_to_value(s7, "string-append"); /* redefine "+" */ s7_define_function(s7, "+", our_add, 0, 0, true, "(+ ...) adds or appends its arguments"); while (1) { char buffer[512]; fprintf(stdout, "\n> "); fgets(buffer, 512, stdin); if ((buffer[0] != '\n') || (strlen(buffer) > 1)) { char response[1024]; snprintf(response, 1024, "(write %s)", buffer); s7_eval_c_string(s7, response); }} } /* > (+ 1 2) * 3 * > (+ "hi" "ho") * "hiho" */
In the next example, we use the method (inlet) machinery:
#include <stdlib.h> #include <stdio.h> #include <string.h> #include <math.h> #include "s7.h" static s7_pointer our_abs(s7_scheme *sc, s7_pointer args) { s7_pointer x = s7_car(args); if (!s7_is_number(x)) { s7_pointer method = s7_method(sc, x, s7_make_symbol(sc, "abs")); if (method == s7_undefined(sc)) /* no method found, so raise an error */ s7_wrong_type_arg_error(sc, "abs", 1, x, "a real"); return(s7_apply_function(sc, method, args)); /* else apply the method to the args */ } return(s7_make_real(sc, (s7_double)fabs(s7_number_to_real(sc, x)))); } int main(int argc, char **argv) { s7_scheme *s7 = s7_init(); s7_define_function(s7, "our-abs", our_abs, 1, 0, false, "abs replacement"); while (1) { char buffer[512]; fprintf(stdout, "\n> "); fgets(buffer, 512, stdin); if ((buffer[0] != '\n') || (strlen(buffer) > 1)) { char response[1024]; snprintf(response, 1024, "(write %s)", buffer); s7_eval_c_string(s7, response); }} } /* > (our-abs -1) * 1.0 * > (our-abs (openlet (inlet 'value -3.0 'abs (lambda (x) (abs (x 'value)))))) * 3.0 */
#include <stdlib.h> #include <stdio.h> #include <string.h> #include "s7.h" static s7_pointer plus(s7_scheme *sc, s7_pointer args) { /* (define* (plus (red 32) blue) (+ (* 2 red) blue)) */ return(s7_make_integer(sc, 2 * s7_integer(s7_car(args)) + s7_integer(s7_cadr(args)))); } int main(int argc, char **argv) { s7_scheme *s7 = s7_init(); s7_define_function_star(s7, "plus", plus, "(red 32) blue", "an example of define* from C"); while (1) { char buffer[512]; fprintf(stdout, "\n> "); fgets(buffer, 512, stdin); if ((buffer[0] != '\n') || (strlen(buffer) > 1)) { char response[1024]; snprintf(response, 1024, "(write %s)", buffer); s7_eval_c_string(s7, response); }} } /* * > (plus 2 3) * 7 * > (plus :blue 3) * 67 * > (plus :blue 1 :red 4) * 9 * > (plus 2 :blue 3) * 7 * > (plus :blue 3 :red 1) * 5 */
#include <stdlib.h> #include <stdio.h> #include <string.h> #include "s7.h" static s7_pointer plus(s7_scheme *sc, s7_pointer args) { /* (define-macro (plus a b) `(+ ,a ,b)) */ s7_pointer a = s7_car(args); s7_pointer b = s7_cadr(args); return(s7_list(sc, 3, s7_make_symbol(sc, "+"), a, b)); } int main(int argc, char **argv) { s7_scheme *s7 = s7_init(); s7_define_macro(s7, "plus", plus, 2, 0, false, "plus adds its two arguments"); while (1) { char buffer[512]; fprintf(stdout, "\n> "); fgets(buffer, 512, stdin); if ((buffer[0] != '\n') || (strlen(buffer) > 1)) { char response[1024]; snprintf(response, 1024, "(write %s)", buffer); s7_eval_c_string(s7, response); }} } /* * > (plus 2 3) * 5 */
In scheme, a function becomes generic simply by (apply ((car args) 'func) args)
.
To accomplish the same thing in C, we use s7_method and s7_apply_function:
#include <stdlib.h> #include <stdio.h> #include <string.h> #include "s7.h" static s7_pointer plus(s7_scheme *sc, s7_pointer args) { #define plus_help "(plus obj ...) applies obj's plus method to obj and any trailing arguments." s7_pointer obj = s7_car(args); s7_pointer method = s7_method(sc, obj, s7_make_symbol(sc, "plus")); if (s7_is_procedure(method)) return(s7_apply_function(sc, method, args)); return(s7_f(sc)); } int main(int argc, char **argv) { s7_scheme *s7 = s7_init(); s7_define_function(s7, "plus", plus, 1, 0, true, plus_help); while (1) { char buffer[512]; fprintf(stdout, "\n> "); fgets(buffer, 512, stdin); if ((buffer[0] != '\n') || (strlen(buffer) > 1)) { char response[1024]; snprintf(response, 1024, "(write %s)", buffer); s7_eval_c_string(s7, response); }} } /* gcc -c s7.c -I. * gcc -o ex15 ex15.c s7.o -I. -lm -ldl * * > (plus 1 2) * #f * > (define obj (openlet (inlet 'plus (lambda args (apply + 1 (cdr args)))))) * obj * > (plus obj 2 3) * 6 */
#include <stdlib.h> #include <stdio.h> #include <string.h> #include <signal.h> #include "s7.h" static s7_scheme *s7; struct sigaction new_act, old_act; static void handle_sigint(int ignored) { fprintf(stderr, "interrupted!\n"); s7_symbol_set_value(s7, s7_make_symbol(s7, "*interrupt*"), s7_make_continuation(s7)); /* save where we were interrupted */ sigaction(SIGINT, &new_act, NULL); s7_quit(s7); /* get out of the eval loop if possible */ } static s7_pointer our_sleep(s7_scheme *sc, s7_pointer args) { /* slow down our infinite loop for demo purposes */ sleep(1); return(s7_f(sc)); } int main(int argc, char **argv) { s7 = s7_init(); s7_define_function(s7, "sleep", our_sleep, 0, 0, false, "(sleep) sleeps"); s7_define_variable(s7, "*interrupt*", s7_f(s7)); /* Scheme variable *interrupt* holds the continuation at the point of the interrupt */ sigaction(SIGINT, NULL, &old_act); if (old_act.sa_handler != SIG_IGN) { memset(&new_act, 0, sizeof(new_act)); new_act.sa_handler = &handle_sigint; sigaction(SIGINT, &new_act, NULL); } while (1) { char buffer[512]; fprintf(stderr, "\n> "); fgets(buffer, 512, stdin); if ((buffer[0] != '\n') || (strlen(buffer) > 1)) { char response[1024]; snprintf(response, 1024, "(write %s)", buffer); s7_eval_c_string(s7, response); }} } /* * > (do ((i 0 (+ i 1))) ((= i -1)) (format () "~D " i) (sleep)) * ;;; now type C-C to break out of this loop * 0 1 2 ^Cinterrupted! * ;;; call the continuation to continue from where we were interrupted * > (*interrupt*) * 3 4 5 ^Cinterrupted! * > *interrupt* * #<continuation> * > (+ 1 2) * 3 */
#include <stdlib.h> #include <stdio.h> #include <string.h> #include "s7.h" static s7_pointer scheme_set_notification(s7_scheme *sc, s7_pointer args) { /* this function is called when the Scheme variable is set! */ fprintf(stderr, "%s set to %s\n", s7_object_to_c_string(sc, s7_car(args)), s7_object_to_c_string(sc, s7_cadr(args))); return(s7_cadr(args)); } int main(int argc, char **argv) { s7_scheme *s7 = s7_init(); s7_define_function(s7, "notify-C", scheme_set_notification, 2, 0, false, "called if notified-var is set!"); s7_define_variable(s7, "notified-var", s7_make_integer(s7, 0)); s7_set_setter(s7, s7_make_symbol(s7, "notified-var"), s7_name_to_value(s7, "notify-C")); if (argc == 2) { fprintf(stderr, "load %s\n", argv[1]); if (!s7_load(s7, argv[1])) fprintf(stderr, "can't find %s\n", argv[1]); } else { while (1) { char buffer[512]; fprintf(stdout, "\n> "); fgets(buffer, 512, stdin); if ((buffer[0] != '\n') || (strlen(buffer) > 1)) { char response[1024]; snprintf(response, 1024, "(write %s)", buffer); s7_eval_c_string(s7, response); }}} } /* > notified-var * 0 * > (set! notified-var 32) * notified-var set to 32 * 32 */
#include <stdlib.h> #include <stdio.h> #include <string.h> #include "s7.h" static s7_pointer func1(s7_scheme *sc, s7_pointer args) { return(s7_make_integer(sc, s7_integer(s7_car(args)) + 1)); } int main(int argc, char **argv) { s7_scheme *s7 = s7_init(); /* "func1" and "var1" will be placed in an anonymous environment, * accessible from Scheme via the global variable "lib-exports" */ s7_pointer new_env = s7_inlet(s7, s7_curlet(s7), s7_nil(s7)); /* make a private environment for func1 and var1 below (this is our "namespace") */ s7_gc_protect(s7, new_env); s7_define(s7, new_env, s7_make_symbol(s7, "func1"), s7_make_function(s7, "func1", func1, 1, 0, false, "func1 adds 1 to its argument")); s7_define(s7, new_env, s7_make_symbol(s7, "var1"), s7_make_integer(s7, 32)); /* those two symbols are now defined in the new environment */ /* add "lib-exports" to the global environment */ s7_define_variable(s7, "lib-exports", s7_let_to_list(s7, new_env)); if (argc == 2) { fprintf(stderr, "load %s\n", argv[1]); if (!s7_load(s7, argv[1])) fprintf(stderr, "can't find %s\n", argv[1]); } else { while (1) { char buffer[512]; fprintf(stdout, "\n> "); fgets(buffer, 512, stdin); if ((buffer[0] != '\n') || (strlen(buffer) > 1)) { char response[1024]; snprintf(response, 1024, "(write %s)", buffer); s7_eval_c_string(s7, response); }}} } /* > func1 * ;func1: unbound variable, line 1 * > lib-exports * ((var1 . 32) (func1 . func1)) * ;; so lib-exports has the C-defined names and values * ;; we can use these directly: * * > (define lib-env (apply sublet (curlet) lib-exports)) * lib-env * > (with-let lib-env (func1 var1)) * 33 * * ;; or rename them to prepend "lib:" * > (define lib-env (apply sublet (curlet) (map (lambda (binding) (cons (string->symbol (string-append "lib:" (symbol->string (car binding)))) (cdr binding))) lib-exports))) * lib-env * > (with-let lib-env (lib:func1 lib:var1)) * 33 * * ;;; now for convenience, place "func1" in the global environment under the name "func2" * > (define func2 (cdadr lib-exports)) * func2 * > (func2 1) * 2 */
#include <stdlib.h> #include <stdio.h> #include <string.h> #include "s7.h" static s7_pointer error_handler(s7_scheme *sc, s7_pointer args) { fprintf(stdout, "error: %s\n", s7_string(s7_car(args))); return(s7_f(sc)); } int main(int argc, char **argv) { s7_scheme *s7 = s7_init(); bool with_error_hook = false; s7_define_function(s7, "error-handler", error_handler, 1, 0, false, "our error handler"); if (with_error_hook) s7_eval_c_string(s7, "(set! (hook-functions *error-hook*) \n\ (list (lambda (hook) \n\ (error-handler \n\ (apply format #f (hook 'data))) \n\ (set! (hook 'result) 'our-error))))"); while (1) { char buffer[512]; fprintf(stdout, "\n> "); fgets(buffer, 512, stdin); if ((buffer[0] != '\n') || (strlen(buffer) > 1)) { s7_pointer result; int gc_loc = -1; const char *errmsg = NULL; /* trap error messages */ s7_pointer old_port = s7_set_current_error_port(s7, s7_open_output_string(s7)); if (old_port != s7_nil(s7)) gc_loc = s7_gc_protect(s7, old_port); /* evaluate the input string */ result = s7_eval_c_string(s7, buffer); /* print out the value wrapped in "{}" so we can tell it from other IO paths */ fprintf(stdout, "{%s}", s7_object_to_c_string(s7, result)); /* look for error messages */ errmsg = s7_get_output_string(s7, s7_current_error_port(s7)); /* if we got something, wrap it in "[]" */ if ((errmsg) && (*errmsg)) fprintf(stdout, "[%s]", errmsg); s7_close_output_port(s7, s7_current_error_port(s7)); s7_set_current_error_port(s7, old_port); if (gc_loc != -1) s7_gc_unprotect_at(s7, gc_loc); }} } /* * gcc -c s7.c -I. -g3 * gcc -o ex3 ex3.c s7.o -lm -I. -ldl * * if with_error_hook is false, * * > (+ 1 2) * {3} * > (+ 1 #\c) * {wrong-type-arg}[ * ;+ argument 2, #\c, is character but should be a number, line 1 * ] * * so s7 by default prepends ";" to the error message, and appends "\n", * sending that to current-error-port, and the error type ('wrong-type-arg here) * is returned. * * if with_error_hook is true, * * > (+ 1 2) * {3} * > (+ 1 #\c) * error: + argument 2, #\c, is character but should be a number * {our-error} * * so now the *error-hook* code handles both the error reporting and * the value returned ('our-error in this case). */
#include <stdlib.h> #include <stdio.h> #include <string.h> #include "s7.h" static s7_pointer my_hook_function(s7_scheme *sc, s7_pointer args) { fprintf(stderr, "a is %s\n", s7_object_to_c_string(sc, s7_symbol_local_value(sc, s7_make_symbol(sc, "a"), s7_car(args)))); return(s7_car(args)); } int main(int argc, char **argv) { s7_scheme *s7 = s7_init(); /* define test_hook in C, test-hook in Scheme, arguments are named a and b */ s7_pointer test_hook = s7_eval_c_string(s7, "(make-hook 'a 'b)"); s7_define_constant(s7, "test-hook", test_hook); /* add my_hook_function to the test_hook function list */ s7_hook_set_functions(s7, test_hook, s7_cons(s7, s7_make_function(s7, "my-hook-function", my_hook_function, 1, 0, false, "my hook-function"), s7_hook_functions(s7, test_hook))); while (1) { char buffer[512]; fprintf(stdout, "\n> "); fgets(buffer, 512, stdin); if ((buffer[0] != '\n') || (strlen(buffer) > 1)) { char response[1024]; snprintf(response, 1024, "(write %s)", buffer); s7_eval_c_string(s7, response); }} } /* * > test-hook * #<lambda (hook)> * > (hook-functions test-hook) * (my-hook-function) * > (test-hook 1 2) * a is 1 * #<unspecified> */
We can use dlopen to load a shared library, and dlsym to initialize that library in our main program. The tricky part is to conjure up the right compiler and loader flags. First we define a module that defines a new s7 function, add-1 that we'll tie into s7 explicitly, and another function that we'll try to call by waving a wand.
#include <stdlib.h> #include <stdio.h> #include <string.h> #include "s7.h" double a_function(double an_arg); double a_function(double an_arg) { return(an_arg + 1.0); } static s7_pointer add_1(s7_scheme *sc, s7_pointer args) { return(s7_make_integer(sc, s7_integer(s7_car(args)) + 1)); } void init_ex(s7_scheme *sc); void init_ex(s7_scheme *sc) /* this needs to be globally accessible (not "static") */ { /* tell s7 about add-1, but leave a_function hidden */ s7_define_function(sc, "add-1", add_1, 1, 0, false, "(add-1 x) adds 1 to x"); }
And here is our main program:
#include <stdlib.h> #include <stdio.h> #include <string.h> #include "s7.h" #include <dlfcn.h> static void *library = NULL; static s7_pointer try(s7_scheme *sc, s7_pointer args) { /* try tries to call an arbitrary function in the shared library */ void *func = dlsym(library, s7_string(s7_car(args))); if (func) { /* we'll assume double f(double) */ typedef double (*dl_func)(double arg); return(s7_make_real(sc, ((dl_func)func)(s7_real(s7_cadr(args))))); } return(s7_error(sc, s7_make_symbol(sc, "can't find function"), s7_list(sc, 2, s7_make_string(sc, "loader error: ~S"), s7_make_string(sc, dlerror())))); } static s7_pointer cload(s7_scheme *sc, s7_pointer args) { /* cload loads a shared library */ #define CLOAD_HELP "(cload so-file-name) loads the module" library = dlopen(s7_string(s7_car(args)), RTLD_LAZY); if (library) { /* call our init func to define add-1 in s7 */ void *init_func = dlsym(library, s7_string(s7_cadr(args))); if (init_func) { typedef void *(*dl_func)(s7_scheme *sc); ((dl_func)init_func)(sc); /* call the initialization function (init_ex above) */ return(s7_t(sc)); }} return(s7_error(sc, s7_make_symbol(sc, "load-error"), s7_list(sc, 2, s7_make_string(sc, "loader error: ~S"), s7_make_string(sc, dlerror())))); } int main(int argc, char **argv) { s7_scheme *s7 = s7_init(); s7_define_function(s7, "cload", cload, 2, 0, false, CLOAD_HELP); s7_define_function(s7, "try", try, 2, 0, false, "(try name num) tries to call name in the shared library with the argument num."); while (1) { char buffer[512]; fprintf(stdout, "\n> "); fgets(buffer, 512, stdin); if ((buffer[0] != '\n') || (strlen(buffer) > 1)) { char response[1024]; snprintf(response, 1024, "(write %s)", buffer); s7_eval_c_string(s7, response); }} } /* Put the module in the file ex3a.c and the main program in ex3.c, then * * in Linux: * gcc -c -fPIC ex3a.c * gcc ex3a.o -shared -o ex3a.so * gcc -c s7.c -I. -fPIC -shared * gcc -o ex3 ex3.c s7.o -lm -ldl -I. -Wl,-export-dynamic * # omit -ldl in freeBSD * * in Mac OSX: * gcc -c ex3a.c * gcc ex3a.o -o ex3a.so -dynamic -bundle -undefined suppress -flat_namespace * gcc -c s7.c -I. -dynamic -bundle -undefined suppress -flat_namespace * gcc -o ex3 ex3.c s7.o -lm -ldl -I. * * and run it: * ex3 * > (cload "/home/bil/snd-18/ex3a.so" "init_ex") * #t * > (add-1 2) * 3 * > (try "a_function" 2.5) * 3.5 */
All of this is just boring boilerplate, so with a little support from s7, we can write a script to do the entire linkage. The s7 side is an extension to "load" that loads a shared object file if its extension is "so", and runs an initialization function whose name is defined in the load environment (the optional second argument to load). An example of the scheme side is cload.scm, included in the s7 tarball. It defines a function that can be called:
(c-define '(double j0 (double)) "m" "math.h")
This links the s7 function m:j0 to the math library function j0. See cload.scm for more details.
Here's a shorter example:
add1.c: #include <stdlib.h> #include "s7.h" static s7_pointer add1(s7_scheme *sc, s7_pointer args) { if (s7_is_integer(s7_car(args))) return(s7_make_integer(sc, 1 + s7_integer(s7_car(args)))); return(s7_wrong_type_arg_error(sc, "add1", 1, s7_car(args), "an integer")); } void add1_init(s7_scheme *sc); void add1_init(s7_scheme *sc) { s7_define_function(sc, "add1", add1, 1, 0, false, "(add1 int) adds 1 to int"); } /* gcc -fpic -c add1.c * gcc -shared -Wl,-soname,libadd1.so -o libadd1.so add1.o -lm -lc * gcc s7.c -o repl -fpic -DWITH_MAIN -I. -ldl -lm -Wl,-export-dynamic -DUSE_SND=0 * repl * (load "libadd1.so" (inlet 'init_func 'add1_init)) * (add1 2) */
Bignum support depends on gmp, mpfr, and mpc. In this example, we define "add-1" which adds 1 to any kind of number. The s7_big_* functions return the underlying gmp/mpfr/mpc pointer.
#include <stdlib.h> #include <stdio.h> #include <string.h> #include <gmp.h> #include <mpfr.h> #include <mpc.h> #include "s7.h" static s7_pointer big_add_1(s7_scheme *sc, s7_pointer args) { /* add 1 to either a normal number or a bignum */ s7_pointer n; s7_pointer x = s7_car(args); if (s7_is_big_integer(x)) { mpz_t big_n; mpz_init_set(big_n, *s7_big_integer(x)); mpz_add_ui(big_n, big_n, 1); n = s7_make_big_integer(sc, &big_n); mpz_clear(big_n); return(n); } if (s7_is_big_ratio(x)) { mpq_t big_q; mpq_init(big_q); mpq_set_si(big_q, 1, 1); mpq_add(big_q, *s7_big_ratio(x), big_q); mpq_canonicalize(big_q); n = s7_make_big_ratio(sc, &big_q); mpq_clear(big_q); return(n); } if (s7_is_big_real(x)) { mpfr_t big_x; mpfr_init_set(big_x, *s7_big_real(x), MPFR_RNDN); mpfr_add_ui(big_x, big_x, 1, MPFR_RNDN); n = s7_make_big_real(sc, &big_x); mpfr_clear(big_x); return(n); } if (s7_is_big_complex(x)) { mpc_t big_z; mpc_init2(big_z, mpc_get_prec(*s7_big_complex(x))); mpc_add_ui(big_z, *s7_big_complex(x), 1, MPC_RNDNN); n = s7_make_big_complex(sc, &big_z); mpc_clear(big_z); return(n); } if (s7_is_integer(x)) return(s7_make_integer(sc, 1 + s7_integer(x))); if (s7_is_rational(x)) return(s7_make_ratio(sc, s7_numerator(x) + s7_denominator(x), s7_denominator(x))); if (s7_is_real(x)) return(s7_make_real(sc, 1.0 + s7_real(x))); if (s7_is_complex(x)) return(s7_make_complex(sc, 1.0 + s7_real_part(x), s7_imag_part(x))); return(s7_wrong_type_arg_error(sc, "add-1", 0, x, "a number")); } int main(int argc, char **argv) { s7_scheme *s7 = s7_init(); s7_define_function(s7, "add-1", big_add_1, 1, 0, false, "(add-1 num) adds 1 to num"); while (1) { char buffer[512]; fprintf(stdout, "\n> "); fgets(buffer, 512, stdin); if ((buffer[0] != '\n') || (strlen(buffer) > 1)) { char response[1024]; snprintf(response, 1024, "(write %s)", buffer); s7_eval_c_string(s7, response); }} } /* * gcc -DWITH_GMP=1 -c s7.c -I. -O2 -g3 * gcc -DWITH_GMP=1 -o gmpex gmpex.c s7.o -I. -O2 -lm -ldl -lgmp -lmpfr -lmpc * * gmpex * > (add-1 1) * 2 * > (add-1 2/3) * 5/3 * > (add-1 1.4) * 2.4 * > (add-1 1.5+i) * 2.5+1i * > (add-1 (bignum 3)) * 4 * > (add-1 (bignum 3/4)) * 7/4 * > (add-1 (bignum 2.5)) * 3.500E0 * > (add-1 (bignum 1.5+i)) * 2.500E0+1.000E0i */
To tie mpfr's bessel-j0 into s7 at run-time:
/* libgmp_s7.c */ #include <gmp.h> #include <mpfr.h> #include <mpc.h> #define WITH_GMP 1 #include "s7.h" static s7_pointer gmp_bessel_j0(s7_scheme *sc, s7_pointer args) { s7_pointer x, result; mpfr_t mp; mpfr_init2(mp, s7_integer(s7_starlet_ref(sc, s7_make_symbol(sc, "bignum-precision")))); /* initialize the mpfr variable mp to the current s7 bignum-precision */ x = s7_car(args); if (s7_is_big_real(x)) mpfr_j0(mp, *s7_big_real(x), MPFR_RNDN); else { if (s7_is_real(x)) { mpfr_set_d(mp, s7_real(x), MPFR_RNDN); mpfr_j0(mp, mp, MPFR_RNDN); } else return(s7_wrong_type_arg_error(sc, "gmp_bessel_j0", 1, x, "real")); } result = s7_make_big_real(sc, &mp); mpfr_clear(mp); return(result); } void libgmp_s7_init(s7_scheme *sc); void libgmp_s7_init(s7_scheme *sc) { s7_define_function(sc, "bessel-j0", gmp_bessel_j0, 1, 0, false, "(bessel-j0 x) returns j0(x)"); }
libarb_s7.c provides some extensions of the multiprecision math: Bessel functions and the like. It is based on the Flint and Arb libraries, flintlib.org and arblib.org. In Linux:
gcc -fPIC -c libarb_s7.c gcc libarb_s7.o -shared -o libarb_s7.so -lflint -larb repl > (load "libarb_s7.so" (inlet 'init_func 'libarb_s7_init)) #f > (acb_bessel_j 0 1.0) 7.651976865579665514497175261026632209096E-1
gdbinit has some debugging commands, intended for your ~/.gdbinit file.
s7print interprets its argument as an s7 value and displays it s7eval evals its argument (a string) s7stack displays the current s7 stack (nested lets) s7value prints the value of the variable passed by its print name: s7v "*features*" s7let shows all non-global variables that are currently accessible s7history shows the history entries (if enabled)
gdbinit also has two backtrace decoders: s7bt and s7btfull. The bt replacements print the gdb backtrace info, replacing bare pointer numbers with their s7 value, wherever possible:
(gdb) s7bt #0 0x000055555567f7ca in check_cell (p=#<lambda (lst ind)>, func=0x5555559106e0 <__FUNCTION__.10273> "mark_slot", line=3976) at s7.c:28494 #1 0x000055555567f84d in check_nref (p=#<lambda (lst ind)>, func=0x5555559106e0 <__FUNCTION__.10273> "mark_slot", line=3976) at s7.c:28507 #2 0x0000555555563201 in mark_slot (p='list-ref #<lambda (lst ind)>) at s7.c:3976 #3 0x0000555555564ce0 in mark_let (env=#<mock-number-class>) at s7.c:4506 #4 0x0000555555563239 in mark_slot (p='mock-number-class #<mock-number-class>) at s7.c:3976 #5 0x0000555555564ce0 in mark_let (env=(inlet 'mock-number-class #<mock-number-class> 'mock-number mock-number)) at s7.c:4506 #6 0x0000555555563239 in mark_slot (p='*mock-number* (inlet 'mock-number-class #<mock-number-class> 'mock-number...)) at s7.c:3976 #7 0x0000555555564ce0 in mark_let (env=(inlet '*features* (mockery.scm stuff.scm linux autoload dlopen...))) at s7.c:4506 #8 0x0000555555565697 in mark_closure (p=reactive-vector) at s7.c:4590 #9 0x0000555555566872 in mark_rootlet (sc=0x555555b41eb0) at s7.c:4813 #10 0x0000555555566a2f in gc (sc=0x555555b41eb0) at s7.c:4897 #11 0x000055555558e903 in copy_stack (sc=0x555555b41eb0, old_v=[sc->stack] #<stack>) at s7.c:9024
Most of the s7.h functions do little, if any, error checking. s7_car, for example, does not check that its argument is a pair. Partly this is a matter of speed; partly of simplicity. If we had elaborate error checks, we'd need some convention for passing error information back to the caller, and of course separate versions of each function for cases where all those checks are redundant. You can easily make your own C version of s7_car that includes error checks:
static s7_pointer my_car(s7_scheme *sc, s7_pointer lst) { if (s7_is_pair(lst)) return(s7_car(lst)); return(s7_wrong_type_arg_error(sc, "my_car", 0, "a pair")); }
The s7.h error functions are:
s7_pointer s7_error(s7_scheme *sc, s7_pointer type, s7_pointer info); s7_pointer s7_wrong_type_arg_error(s7_scheme *sc, const char *caller, s7_int arg_n, s7_pointer arg, const char *descr); s7_pointer s7_wrong_type_error(s7_scheme *sc, s7_pointer caller, s7_int arg_n, s7_pointer arg, s7_pointer descr); s7_pointer s7_out_of_range_error(s7_scheme *sc, const char *caller, s7_int arg_n, s7_pointer arg, const char *descr); s7_pointer s7_wrong_number_of_args_error(s7_scheme *sc, const char *caller, s7_pointer args); s7_pointer s7_current_error_port(s7_scheme *sc); s7_pointer s7_set_current_error_port(s7_scheme *sc, s7_pointer port);
s7_error is equivalent to the scheme error function, and like the latter, it takes two arguments:
a symbol giving the error type, and a list giving the error data. In s7, all of the data lists
are organized so that you can (apply format #f data)
to get an error string.
If you're using catch to handle errors, the error type is what catch looks for. So, the
s7_wrong_type_arg_error call above could be:
s7_error(sc, s7_make_symbol(sc, "wrong-type-arg"), s7_list(sc, 3, s7_make_string(sc, "~S is a ~S, but should be a pair"), s7_car(lst), s7_type_of(sc, s7_car(lst))));
s7_wrong_type_arg_error takes the name of the caller, the argument number, the argument itself, and a description of the type expected. If the argument number is 0, that info is left out of the error message (that is, the caller takes only one argument). s7_out_of_range_error is similar. s7_wrong_number_of_args_error takes the caller's name and the offending arg list. The corresponding error types are 'wrong-type-arg, 'wrong-number-of-args, and 'out-of-range. A faster version is s7_wrong_type_error; here the caller is an s7 symbol or string, and the description is an s7 string.
Normally, s7_error sends its error message to the current error-port which defaults to stderr. In GUI-based apps, you may need to redirect the output to your interface. One method, used in Snd's snd-motif.c, captures the error output in an output string:
old_port = s7_set_current_error_port(s7, s7_open_output_string(s7)); ... result = s7_eval_c_string(s7, text); errmsg = s7_get_output_string(s7, s7_current_error_port(s7)); s7_close_output_port(s7, s7_current_error_port(s7)); s7_set_current_error_port(s7, old_port); ...
and if errmsg is not NULL, it posts it somewhere. (You'll also want to GC-protect the old port while it is idle).
s7_error does not return; its s7_pointer return type is just a convenience. It unwinds the scheme stack, closing files, handling dynamic-winds, looking for a catch that matches its type argument and so on, then longjmps to unwind the C stack. If a catch is found, its error handler becomes the new point of execution.
If you save an s7_pointer value in C, you may need to protect it from the garbage collector. In the example above, the first "..." is:
gc_loc = s7_gc_protect(s7, old_port);
where gc_loc is (or should be) an s7_int. Since we're subsequently calling s7_eval_c_string, we need to GC protect old_port beforehand. After the evaluation,
s7_close_output_port(s7, s7_current_error_port(s7)); s7_set_current_error_port(s7, old_port); s7_gc_unprotect_at(s7, gc_loc);
The full set of GC protection functions is:
s7_int s7_gc_protect(s7_scheme *sc, s7_pointer x); void s7_gc_unprotect_at(s7_scheme *sc, s7_int loc); s7_pointer s7_gc_protected_at(s7_scheme *sc, s7_int loc); s7_pointer s7_gc_protect_via_stack(s7_scheme *sc, s7_pointer x); s7_pointer s7_gc_unprotect_via_stack(s7_scheme *sc, s7_pointer x); s7_pointer s7_gc_protect_via_location(s7_scheme *sc, s7_pointer x, s7_int loc); s7_pointer s7_gc_unprotect_via_location(s7_scheme *sc, s7_int loc); s7_pointer s7_gc_on(s7_scheme *sc, bool on);
If you create an s7 object in C, that object needs to be GC protected if there is any chance the GC might run without an existing Scheme-level reference to it. s7_gc_protect places the object in a vector that the GC always checks, returning the object's location in that table. s7_gc_unprotect_at unprotects the object (removes it from the vector) using the location passed to it. s7_gc_protected_at returns the object at the given location. There is a built-in lag between the creation of a new object and its first possible GC (the lag time is set indirectly by GC_TEMPS_SIZE in s7.c), so you don't need to worry about very short term temps such as the arguments to s7_cons in:
s7_cons(s7, s7_make_real(s7, 3.14), s7_cons(s7, s7_make_integer(s7, 123), s7_nil(s7)));
The protect_via_stack functions place the object on the s7 stack where it is protected until the stack unwinds past that point. Besides speed, this provides a way to be sure an object is unprotected even in some complicated situation where error handling may bypass an explicit s7_gc_unprotect_at call. The protect_via_location are intended for cases where you have a location already (from s7_gc_protect), and want to reuse it for a different object. s7_gc_on turns the GC on or off. Objects can be created at a blistering pace, so don't leave the GC off for a long time!
s7_pointer s7_load(s7_scheme *sc, const char *file); s7_pointer s7_load_with_environment(s7_scheme *sc, const char *filename, s7_pointer e); s7_pointer s7_load_c_string(s7_scheme *sc, const char *content, s7_int bytes); s7_pointer s7_load_c_string_with_environment(s7_scheme *sc, const char *content, s7_int bytes, s7_pointer e); s7_pointer s7_load_path(s7_scheme *sc); s7_pointer s7_add_to_load_path(s7_scheme *sc, const char *dir); s7_pointer s7_autoload(s7_scheme *sc, s7_pointer symbol, s7_pointer file_or_function); void s7_autoload_set_names(s7_scheme *sc, const char **names, s7_int size); snd-xref.c
s7_load is similar to the scheme-side load function. Its argument is a file name, and optionally (via s7_load_with_environment) an environment in which to place top-level objects. Normally the file contains scheme code, but if WITH_C_LOADER is set when s7 is built, you can also load shared-object files. If you load a shared-object file (a dynamically loadable library), the environment argument provides a way to pass in the initialization function (named 'init_func). For example, the repl in s7.c needs access to libc's tcsetattr, so it looks for libc_s7.so (created by libc.scm). If found,
s7_load_with_environment(sc, "libc_s7.so", s7_inlet(sc, s7_list(sc, 2, s7_make_symbol(sc, "init_func"), s7_make_symbol(sc, "libc_s7_init")));
You can also include an 'init_args field to pass arguments to init_func. Here's an example that includes init_args:
/* tlib.c */ #include <stdio.h> #include <stdlib.h> #include "s7.h" static s7_pointer a_function(s7_scheme *sc, s7_pointer args) { return(s7_car(args)); } s7_pointer tlib_init(s7_scheme *sc, s7_pointer args); /* void tlib_init(s7_scheme *sc) if no init_args */ s7_pointer tlib_init(s7_scheme *sc, s7_pointer args) { fprintf(stderr, "tlib_init: %s\n", s7_object_to_c_string(sc, args)); s7_define_function(sc, "a-function", a_function, 1, 0, true, ""); return(s7_car(args)); } /* in Linux: gcc -fPIC -c tlib.c gcc tlib.o -shared -o tlib.so -ldl -lm -Wl,-export-dynamic /home/bil/cl/ repl <1> (load "tlib.so" (inlet 'init_func 'tlib_init 'init_args (list 1 2 3))) tlib_init: (1 2 3) 1 <2> (a-function 1 2 3) 1 */
s7_load returns the last value produced during the load; so given "test.scm" with the contents:
define (f x) (+ x 1)) 32
when we call s7_load:
s7_pointer val; val = s7_load_with_environment(sc, "test.scm", s7_curlet(sc));
val is set to 32 (as a scheme object), and f is placed in the current environment. If "test.scm" is not in the current directory, s7 looks at the entries in its *load-path* variable, trying each in turn until it finds the file. If it fails, it returns NULL. s7_load_path returns this list, and s7_add_to_load_path adds a directory name to the list.
s7_load_c_string takes an array of bytes representing some scheme code (xxd -i file.scm can generate these arrays), and treats it as if it were the contents of a file of scheme code. So, unlike s7_eval_c_string, it can handle multiple statements, and things like double-quote don't need to be quoted. nrepl.c for example embeds the contents of nrepl.scm at compile time, then calls s7_load_c_string at program startup. It also includes notcurses_s7.c. The end result is a stand-alone program that doesn't need to load either nrepl.scm or notcurses_s7.so. The "content" argument should be a null-terminated C string. The "bytes" argument is the contents length, not including the trailing null, as in strlen. There are simple examples in ffitest.c.
xxd is not ideal in this context because diffs become enormous. I use this code to turn nrepl.scm into nrepl-bits.h, following the original code's layout to minimize diffs:
(call-with-output-file "nrepl-bits.h" (lambda (op) (call-with-input-file "nrepl.scm" (lambda (ip) (format op "unsigned char nrepl_scm[] = {~% ") (do ((c (read-char ip) (read-char ip)) (i 0 (+ i 1))) ((eof-object? c) (format op "0};~%unsigned int nrepl_scm_len = ~D;~%" (+ i 1))) (format op "0x~X, " (char->integer c)) (if (char=? c #\newline) (format op "~% ")))))))Then in nrepl.c:
#include "nrepl-bits.h" s7_load_c_string(sc, (const char *)nrepl_scm, nrepl_scm_len);which replaces
s7_load(sc, "nrepl.scm")
.
s7_autoload adds a symbol to the autoload table. As a convenience, s7_autoload_set_names adds an array of names+files. The array should be sorted alphabetically by string<? acting on the symbol names (not the file names), and the size argument is the number of symbol names (half the actual array size). snd-xref.c in Snd has more than 5000 such names:
static const char *snd_names[11848] = { "*clm-array-print-length*", "ws.scm", /* each pair of entries is entity name + file name */ "*clm-channels*", "ws.scm", /* so clm-channels is defined in ws.scm */ ... "zone-tailed-hawk", "animals.scm", "zoom-spectrum", "examp.scm", }; s7_autoload_set_names(sc, snd_names, 5924);
s7_pointer s7_eval(s7_scheme *sc, s7_pointer code, s7_pointer e); s7_pointer s7_eval_with_location(s7_scheme *sc, s7_pointer code, s7_pointer e, const char *caller, const char *file, s7_int line); s7_pointer s7_eval_c_string(s7_scheme *sc, const char *str); s7_pointer s7_eval_c_string_with_environment(s7_scheme *sc, const char *str, s7_pointer e); s7_pointer s7_apply_function(s7_scheme *sc, s7_pointer fnc, s7_pointer args); s7_pointer s7_apply_function_star(s7_scheme *sc, s7_pointer fnc, s7_pointer args); s7_pointer s7_call(s7_scheme *sc, s7_pointer func, s7_pointer args); s7_pointer s7_call_with_location(s7_scheme *sc, s7_pointer func, s7_pointer args, const char *caller, const char *file, s7_int line); s7_pointer s7_call_with_catch(s7_scheme *sc, s7_pointer tag, s7_pointer body, s7_pointer error_handler); s7_pointer s7_apply_1(s7_scheme *sc, s7_pointer args, s7_pointer (*f1)(s7_pointer a1)); s7_pointer s7_apply_n_1(s7_scheme *sc, s7_pointer args, s7_pointer (*f1)(s7_pointer a1)); /* and many more passing 2 to 9 arguments */
These functions evaluate Scheme expressions, and call Scheme functions (which might be defined in C originally). s7_eval evaluates a list that represents Scheme code. That is,
s7_eval(sc, s7_cons(sc, s7_make_symbol(sc, "+"), s7_cons(sc, s7_make_integer(sc, 1), s7_cons(sc, s7_make_integer(sc, 2), s7_nil(sc)))), s7_rootlet(sc)); /* s7_nil here is the same as s7_rootlet */
returns 3 (as a Scheme integer). This may look ridiculous, but see snd-sig.c for an actual use. s7_eval_c_string evaluates a Scheme expression presented to it as a C string; it combines read and eval, whereas s7_eval is just the eval portion.
s7_eval_c_string(sc, "(+ 1 2)");
also returns 3. The expression is evaluated in rootlet (the global environment). To specify the environment, use s7_eval_c_string_with_environment.
s7_apply_function and s7_apply_function_star take an s7_function and apply it to a list of arguments. These two functions are the low-level versions of the s7_call functions. The latter set up various catches so that error handling is safe, whereas s7_apply_function assumes you have a catch already somewhere.
s7_call_with_location passes some information to the error handler, and s7_call_with_catch wraps an explicit catch around a function call: s7_call_with_catch(sc, tag, body, err) is equivalent to (catch tag body err). There are many examples of these functions in clm2xen.c, ffitest.c, etc.
The s7_apply_1 functions and its many friends are left over from long ago. I hope to deprecate them someday, but currently Snd uses them to excess.  Use s7_set_shadow_rootlet to import the current let into rootlet.
s7_define(s7, s7_curlet(s7), s7_make_symbol(s7, "var"), s7_make_integer(s7, 123));
adds the variable named var to the current environment with the value 123.
Scheme code can then refer to var just as if we had said (define var 123)
in Scheme.
s7_define_variable is a wrapper for s7_define; the code above could be:
s7_define_variable(s7, "var", s7_make_integer(s7, 123)); /* (define var 123) */
except that s7_define_variable assumes you want var in rootlet.
s7_define_constant is another wrapper for s7_define; it makes the variable immutable:
s7_define_constant(sc, "var", s7_f(sc)); /* (define-constant var 123) */
Most of the s7_define* functions return the name as a symbol; this reflects the way define worked in s7 until 2014. Backwards compatibility...
The rest of the functions in this section deal with tieing C functions into Scheme.
s7_make_function creates (and returns) a Scheme function object from the s7_function 'fnc'.
An s7_function is a C function of the form s7_pointer func(s7_scheme *sc, s7_pointer args)
.
The new function's name is 'name', it requires 'required_args' arguments,
it can accept 'optional_args' other arguments, and if 'rest_arg' is true, it accepts
a "rest" argument (a list of all the trailing arguments).
The function's documentation is 'doc'.
Leaving aside the value returned, s7_define_function is the same as s7_make_function, but it also adds 'name' (as a symbol) to the global environment, with the function as its value. For example, the Scheme function 'car' is essentially:
s7_pointer g_car(s7_scheme *sc, s7_pointer args) {return(s7_car(s7_car(args)));} /* args is a list of args */
It is bound to the name "car":
s7_define_function(sc, "car", g_car, 1, 0, false, "(car obj)");
which says that car has one required argument, no optional arguments, and no "rest" argument.
s7_define_macro defines a Scheme macro; its arguments are not evaluated (unlike a function), but its returned value (assumed to be some sort of Scheme expression) is evaluated. It returns a symbol.
The "safe" and "unsafe" versions of these functions refer to the s7 optimizer. If it knows a function is safe, it can more thoroughly optimize the expression it is in. "Safe" here means the function does not call the evaluator itself (via s7_apply_function for example) and does not mess with s7's stack.
The "typed" versions refer to the function's signature. Since "car" is safe, and has a signature, it is defined in s7.c:
s7_define_typed_function(sc, "car", g_car, 1, 0, false, H_car, Q_car);
Here unless you use s7_define_unsafe_typed_function, the function is assumed to be safe.
We've given it the Scheme name "car", which invokes the C function g_car. It takes one
required argument, and no optional or rest arguments. Its documentation is H_car, and
its signature is Q_car. The latter is s7_make_signature(sc, 2, sc->T, sc->is_pair_symbol)
which says that car takes a pair argument, and returns any type object.
The function_star functions are similar, but in this case we pass the argument list as a string, as it would appear in Scheme. s7 makes sure the arguments are ordered correctly and have the specified defaults before calling the C function.
s7_define_function_star(sc, "a-func", a_func, "arg1 (arg2 32)", "an example of C define*");
Now in Scheme, (a-func :arg1 2) calls the C function a_func with the arguments 2 and 32.
Finally, the dilambda function define Scheme dilambda, just as the Scheme dilambda function does. The dax example above gives read/write access to its x field via:
s7_define_variable(s7, "dax-x", s7_dilambda(s7, "dax-x", dax_x, 1, 0, set_dax_x, 2, 0, "dax x field"));
const char *s7_documentation(s7_scheme *sc, s7_pointer p); const char *s7_set_documentation(s7_scheme *sc, s7_pointer symbol, const char *new_doc); const char *s7_help(s7_scheme *sc, s7_pointer obj); s7_pointer s7_arity(s7_scheme *sc, s7_pointer obj); bool s7_is_aritable(s7_scheme *sc, s7_pointer obj, s7_int args); s7_pointer s7_setter(s7_scheme *sc, s7_pointer obj); s7_pointer s7_set_setter(s7_scheme *sc, s7_pointer obj, s7_pointer setter); s7_pointer s7_signature(s7_scheme *sc, s7_pointer func); s7_pointer s7_make_signature(s7_scheme *sc, s7_int len, ...); s7_pointer s7_make_circular_signature(s7_scheme *sc, s7_int cycle_point, s7_int len, ...); s7_pointer s7_closure_body(s7_scheme *sc, s7_pointer p); s7_pointer s7_closure_let(s7_scheme *sc, s7_pointer p); s7_pointer s7_closure_args(s7_scheme *sc, s7_pointer p); s7_pointer s7_funclet(s7_scheme *sc, s7_pointer p);
These functions pertain mostly to functions, both those defined in Scheme and those in C. s7_help and s7_documentation return the documentation string associated with their argument. I find "documentation" tedious to type, and Snd uses "help", but other than the name, there isn't much difference between them. s7_set_documentation sets the documentation string, if it can.
s7_arity returns an object's arity, a cons of the number of required arguments, and the total acceptable arguments. s7_is_aritable returns true if the object can accept that number of args.
s7_setter is the object's setter, and s7_set_setter sets it, if possible.
s7_signature is the object's signature, a list of types (symbols like 'integer?) giving return and argument types. For a function defined in C, s7_make_signature and s7_make_circular_signature create the signature that is then associated with the function via s7_define_typed_function and its friends. In s7.c g_is_zero (the function that implements zero?) uses:
s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_number_symbol); /* return a boolean, argument is a number */
Similarly, g_add is:
s7_make_circular_signature(sc, 0, 1, sc->is_number_symbol); /* returns a number, takes any number of numbers */
The two numeric arguments set the cycle start point (0-based) and the number of type symbols passed as arguments to it. So, char=? is:
s7_make_circular_signature(sc, 1, 2, sc->is_boolean_symbol, sc->is_char_symbol);
which says there are two type entries (the "2"), and the cycle starts at the second (the "1" -- it's 0-based).
The s7_closure functions only apply to functions defined in Scheme. They return the closure body (s7_closure_body, a list),
its definition environment (s7_closure_let), and its argument list (s7_closure_args). If the function is of the form
(define (f . args) ...)
, s7_closure_args returns the symbol ('args in this case).
s7_funclet returns the top let within the function (the let containing the argument names).
bool s7_is_c_object(s7_pointer p); s7_pointer s7_make_c_object(s7_scheme *sc, s7_int type, void *value); s7_pointer s7_make_c_object_without_gc(s7_scheme *sc, s7_int type, void *value); s7_pointer s7_make_c_object_with_let(s7_scheme *sc, s7_int type, void *value, s7_pointer let); s7_int s7_c_object_type(s7_pointer obj); void *s7_c_object_value(s7_pointer obj); void *s7_c_object_value_checked(s7_pointer obj, s7_int type); s7_pointer s7_c_object_let(s7_pointer obj); s7_pointer s7_c_object_set_let(s7_scheme *sc, s7_pointer obj, s7_pointer e); s7_int s7_make_c_type(s7_scheme *sc, const char *name); void s7_c_type_set_gc_free (s7_scheme *sc, s7_int type, s7_pointer (*gc_free) (s7_scheme *sc, s7_pointer obj)); void s7_c_type_set_gc_mark (s7_scheme *sc, s7_int type, s7_pointer (*mark) (s7_scheme *sc, s7_pointer obj)); void s7_c_type_set_is_equal (s7_scheme *sc, s7_int type, s7_pointer (*is_equal) (s7_scheme *sc, s7_pointer args)); void s7_c_type_set_is_equivalent(s7_scheme *sc, s7_int type, s7_pointer (*is_equivalent)(s7_scheme *sc, s7_pointer args)); void s7_c_type_set_ref (s7_scheme *sc, s7_int type, s7_pointer (*ref) (s7_scheme *sc, s7_pointer args)); void s7_c_type_set_set (s7_scheme *sc, s7_int type, s7_pointer (*set) (s7_scheme *sc, s7_pointer args)); void s7_c_type_set_length (s7_scheme *sc, s7_int type, s7_pointer (*length) (s7_scheme *sc, s7_pointer args)); void s7_c_type_set_copy (s7_scheme *sc, s7_int type, s7_pointer (*copy) (s7_scheme *sc, s7_pointer args)); void s7_c_type_set_fill (s7_scheme *sc, s7_int type, s7_pointer (*fill) (s7_scheme *sc, s7_pointer args)); void s7_c_type_set_reverse (s7_scheme *sc, s7_int type, s7_pointer (*reverse) (s7_scheme *sc, s7_pointer args)); void s7_c_type_set_to_list (s7_scheme *sc, s7_int type, s7_pointer (*to_list) (s7_scheme *sc, s7_pointer args)); void s7_c_type_set_to_string (s7_scheme *sc, s7_int type, s7_pointer (*to_string) (s7_scheme *sc, s7_pointer args)); void s7_c_type_set_getter (s7_scheme *sc, s7_int type, s7_pointer getter); void s7_c_type_set_setter (s7_scheme *sc, s7_int type, s7_pointer setter); void s7_mark(s7_pointer p);
These functions create a new Scheme object type. See dax above for a simple example, and s7test.scm for several progressively more complicated examples. C-objects in Scheme usually correspond to an instance of a struct in C which you want to access from Scheme. The normal sequence is: define a new c-type via s7_make_c_type, call s7_c_type_set* to specialize its behavior, then to wrap a C object, call s7_make_c_object. s7_make_c_type takes an arbitrary name, used in object->string to identify the object, and returns an s7_int, the "type" mentioned in many of the other functions.
s7_c_type_set_free sets the function that is called by the GC when a Scheme c-object is garbage-collected. You normally use this to free the associated C value (the instance of the struct). To get that value, call s7_c_object_value. It returns the void* pointer that you originally passed to s7_make_c_object. See free_dax in the dax example.
s7_c_type_set_mark sets the function that is called by the GC during its marking phase. Any s7_pointer value local to your C struct should be marked explicitly at this time, or the GC will free it. Use s7_mark for this (see mark_dax). Don't allocate any s7 objects in the mark function (otherwise you'll get a recursive call of the GC).
s7_c_type_set_equal and s7_c_type_set_equivalent set the function called when s7 sees a c-object of the current type as an argument to equal? or equivalent?. When called, these functions can assume that the first argument is a c-object of the current type, but the second argument can be anything (see dax_is_equal).
s7_c_type_set_ref and s7_c_type_set_set are called when the c-object is treated as an applicable object
in Scheme. That is, (object ...)
in Scheme calls the function set as the "ref" function, and
(set! (object ...) new-value)
calls the "set" function. The arguments in the set! form are
passed as a flattened list.
The rest of the s7_c_type_set* functions set the functions called when the c-object is an argument to length (s7_c_type_set_length), copy (s7_c_type_set_copy), fill! (s7_c_type_set_fill), reverse (s7_c_type_set_reverse), object->string (s7_c_type_set_to_string), and internally by map and a few other cases, s7_c_type_set_to_list. For the copy function, either the first or second argument can be a c-object of the given type. The getter and setter functions are optimizer helpers.
s7_c_object_value_checked is like s7_c_object, but it first checks that the object type matches the given type.
s7_c_object_let and s7_c_object_set_let manage the c-object's local environment. These two functions need to check that they are passed the correct number of arguments. See the block object in s7test.scm. The c_object_let provides methods normally. In Snd, marks can be passed into Scheme; the setup code is:
static s7_pointer g_mark_methods; ... g_mark_methods = s7_openlet(s7, s7_inlet(s7, s7_list(s7, 2, s7_make_symbol(s7, "object->let"), mark_to_let_func))); s7_gc_protect(s7, g_mark_methods); xen_mark_tag = s7_make_c_type(s7, "<mark>"); s7_c_type_set_gc_free(s7, xen_mark_tag, s7_xen_mark_free); s7_c_type_set_is_equal(s7, xen_mark_tag, s7_xen_mark_is_equal); s7_c_type_set_copy(s7, xen_mark_tag, s7_xen_mark_copy); s7_c_type_set_to_string(s7, xen_mark_tag, g_xen_mark_to_string);
The mark object's let (g_mark_methods) has a method for object->let. It is tied into each mark object:
s7_pointer m; m = s7_make_c_object(s7, xen_mark_tag, mx); /* mx is the C-side value */ s7_c_object_set_let(s7, m, g_mark_methods);
and now if you type (object->let mark) in Snd's listener (where "mark" is an appropriate mark of course), object->let calls the object's object->let method. Don't forget to GC-protect the let!
s7_make_c_object_without_gc makes a c-object of the given type, but the gc_free function won't be called when the s7_cell that holds the C data is freed for reuse.
bool s7_is_input_port(s7_scheme *sc, s7_pointer p); bool s7_is_output_port(s7_scheme *sc, s7_pointer p); void s7_close_input_port(s7_scheme *sc, s7_pointer p); void s7_close_output_port(s7_scheme *sc, s7_pointer p); bool s7_flush_output_port(s7_scheme *sc, s7_pointer p); /* false=flush lost data */ const char *s7_port_filename(s7_scheme *sc, s7_pointer x); s7_int s7_port_line_number(s7_scheme *sc, s7_pointer p); s7_pointer s7_open_input_file(s7_scheme *sc, const char *name, const char *mode); s7_pointer s7_open_output_file(s7_scheme *sc, const char *name, const char *mode); s7_pointer s7_open_input_string(s7_scheme *sc, const char *input_string); s7_pointer s7_open_output_string(s7_scheme *sc); const char *s7_get_output_string(s7_scheme *sc, s7_pointer out_port); s7_pointer s7_output_string(s7_scheme *sc, s7_pointer out_port); typedef enum {S7_READ, S7_READ_CHAR, S7_READ_LINE, S7_PEEK_CHAR, S7_IS_CHAR_READY, S7_NUM_READ_CHOICES} s7_read_t; s7_pointer s7_open_output_function(s7_scheme *sc, void (*function)(s7_scheme *sc, uint8_t c, s7_pointer port)); s7_pointer s7_open_input_function(s7_scheme *sc, s7_pointer (*function)(s7_scheme *sc, s7_read_t read_choice, s7_pointer port)); s7_pointer s7_read_char(s7_scheme *sc, s7_pointer port); s7_pointer s7_peek_char(s7_scheme *sc, s7_pointer port); s7_pointer s7_write_char(s7_scheme *sc, s7_pointer c, s7_pointer port); s7_pointer s7_write(s7_scheme *sc, s7_pointer obj, s7_pointer port); s7_pointer s7_display(s7_scheme *sc, s7_pointer obj, s7_pointer port); void s7_newline(s7_scheme *sc, s7_pointer port); const char *s7_format(s7_scheme *sc, s7_pointer args); s7_pointer s7_object_to_string(s7_scheme *sc, s7_pointer arg, bool use_write); char *s7_object_to_c_string(s7_scheme *sc, s7_pointer obj); s7_pointer s7_current_input_port(s7_scheme *sc); s7_pointer s7_set_current_input_port(s7_scheme *sc, s7_pointer p); s7_pointer s7_current_output_port(s7_scheme *sc); s7_pointer s7_set_current_output_port(s7_scheme *sc, s7_pointer p); s7_pointer s7_current_error_port(s7_scheme *sc); s7_pointer s7_set_current_error_port(s7_scheme *sc, s7_pointer port); s7_pointer s7_read(s7_scheme *sc, s7_pointer port);
Most of these correspond closely to the similarly named scheme function. s7_port_filename returns the file associated with a file port. s7_port_line_number returns position of the reader in an input file port. The "use_write" parameter to s7_object_to_string refers to the write/display choice in scheme. The string returned by s7_object_to_c_string should be freed by the caller. s7_output_string is the same as s7_get_output_string except that it returns an s7 string, not a C string.
s7_open_input_function and s7_open_output_function call their "function" argument when input or output is requested. The "read_choice" argument specifies to that function which of the input scheme functions called it. The intent of these two input functions is to give you complete control over IO. In the case of an input_function:
static s7_pointer my_read(s7_scheme *sc, s7_read_t peek, s7_pointer port) { /* this function should handle input according to the peek choice */ return(s7_make_character(sc, '0')); } s7_pointer port; s7_int gc_loc; uint8_t c; port = s7_open_input_function(sc, my_read); gc_loc = s7_gc_protect(sc, port); c = s7_character(s7_read_char(sc, p1)); /* my_read "peek" == S7_READ_CHAR */ if (last_c != '0') fprintf(stderr, "c: %c\n", c); s7_gc_unprotect_at(sc, gc_loc);
s7_pointer s7_rootlet(s7_scheme *sc); s7_pointer s7_shadow_rootlet(s7_scheme *sc); s7_pointer s7_set_shadow_rootlet(s7_scheme *sc, s7_pointer let); s7_pointer s7_curlet(s7_scheme *sc); s7_pointer s7_set_curlet(s7_scheme *sc, s7_pointer e); s7_pointer s7_outlet(s7_scheme *sc, s7_pointer e); s7_pointer s7_sublet(s7_scheme *sc, s7_pointer let, s7_pointer bindings); s7_pointer s7_inlet(s7_scheme *sc, s7_pointer bindings); s7_pointer s7_varlet(s7_scheme *sc, s7_pointer let, s7_pointer symbol, s7_pointer value); s7_pointer s7_let_to_list(s7_scheme *sc, s7_pointer let); bool s7_is_let(s7_pointer e); s7_pointer s7_let_ref(s7_scheme *sc, s7_pointer let, s7_pointer symbol); s7_pointer s7_let_set(s7_scheme *sc, s7_pointer let, s7_pointer symbol, s7_pointer val); s7_pointer s7_starlet_ref(s7_scheme *sc, s7_pointer sym); s7_pointer s7_starlet_set(s7_scheme *sc, s7_pointer sym, s7_pointer new_value); /* the old confusing names for the same functions: */ s7_pointer s7_let_field_ref(s7_scheme *sc, s7_pointer symbol); s7_pointer s7_let_field_set(s7_scheme *sc, s7_pointer symbol, s7_pointer new_value); s7_pointer s7_openlet(s7_scheme *sc, s7_pointer e); bool s7_is_openlet(s7_pointer e); s7_pointer s7_method(s7_scheme *sc, s7_pointer object, s7_pointer method); /* these might go away someday */ s7_pointer s7_slot(s7_scheme *sc, s7_pointer symbol); s7_pointer s7_slot_value(s7_pointer slot); s7_pointer s7_slot_set_value(s7_scheme *sc, s7_pointer slot, s7_pointer value); s7_pointer s7_make_slot(s7_scheme *sc, s7_pointer env, s7_pointer symbol, s7_pointer value); void s7_slot_set_real_value(s7_scheme *sc, s7_pointer slot, s7_double value);
Many of these are the same as the corresponding scheme function: s7_rootlet, s7_curlet, s7_outlet, s7_sublet, s7_inlet, s7_varlet, s7_let_to_list, s7_is_let, s7_let_ref, s7_let_set, s7_openlet, and s7_is_openlet.
s7_starlet_ref and s7_starlet_set refer to *s7*, the let that holds various s7 settings. To get the current default print-length,
s7_integer(s7_starlet_ref(s7, s7_make_symbol(s7, "print-length")))
s7_method looks for a field in "object" with the name "method", a symbol. For example, in clm2xen.c, if mus-copy is called on an object that Snd does not immediately recognize (i.e. a generator), it looks for a mus-copy method, and if found, Snd calls it:
s7_pointer func; func = s7_method(s7, gen, s7_make_symbol(s7, "mus-copy")); if (func != s7_undefined(s7)) return(s7_apply_function(s7, func, s7_list(s7, 1, gen)));
The object searched can be anything that has an associated let: a c-object, a function or macro, a c-pointer, or of course a let.
s7_set_curlet and the slot functions might go away someday. They are currently used in Snd. For the adventurous however, here's a sketchy description. A slot in s7 is a location in a let (a variable binding in an environment to use more standard terminology). s7_make_slot creates a slot in "env" with the given symbol and value. s7_slot_value returns the value; s7_slot_set_value sets the value; s7_slot_set_real_value sets the mutable real value's numerical value. s7_slot takes a symbol and tries to find its currently active slot. s7_set_curlet sets curlet, returning the previous curlet.
s7_shadow_rootlet and s7_set_shadow_rootlet make it easier to import a let into rootlet. This is also aimed at code that is defining lots of functions and variables, using the default functions like s7_define_variable that place things in the rootlet, but the code actually wants all those objects stored in a let other than rootlet.
s7_pointer cur_env, old_shadow; cur_env = s7_curlet(sc); old_shadow = s7_set_shadow_rootlet(sc, cur_env); /* define everything here */ s7_set_shadow_rootlet(sc, old_shadow);
s7_set_shadow_rootlet returns the previous shadow rootlet, so this turns the current environment into a shadow rootlet while defining functions, then restores the old rootlet. Similarly notcurses_s7.c places everything in the *notcurses* let, but uses s7_set_shadow_rootlet to make these available in scheme as if they were in the rootlet:
s7_pointer notcurses_let, old_shadow; s7_define_constant(sc, "*notcurses*", notcurses_let = s7_inlet(sc, s7_nil(sc))); old_shadow = s7_set_shadow_rootlet(sc, notcurses_let); /* ... here we have all the s7_defines ... */ s7_set_shadow_rootlet(sc, old_shadow);
bool s7_is_symbol(s7_pointer p); const char *s7_symbol_name(s7_pointer p); s7_pointer s7_make_symbol(s7_scheme *sc, const char *name); s7_pointer s7_gensym(s7_scheme *sc, const char *prefix); bool s7_is_keyword(s7_pointer obj); s7_pointer s7_make_keyword(s7_scheme *sc, const char *key); s7_pointer s7_keyword_to_symbol(s7_scheme *sc, s7_pointer key); s7_pointer s7_name_to_value(s7_scheme *sc, const char *name); s7_pointer s7_symbol_value(s7_scheme *sc, s7_pointer sym); s7_pointer s7_symbol_set_value(s7_scheme *sc, s7_pointer sym, s7_pointer val); s7_pointer s7_symbol_local_value(s7_scheme *sc, s7_pointer sym, s7_pointer local_env); s7_pointer s7_symbol_table_find_name(s7_scheme *sc, const char *name); bool s7_for_each_symbol_name(s7_scheme *sc, bool (*symbol_func)(const char *symbol_name, void *data), void *data); bool s7_for_each_symbol(s7_scheme *sc, bool (*symbol_func)(const char *symbol_name, void *data), void *data);
s7_is_symbol corresponds to scheme's symbol?, s7_symbol_name to symbol->string, s7_make_symbol is string->symbol, s7_gensym to gensym. The gensym prefix is the optional argument to gensym in scheme. By default the prefix is "gensym", so the gensym-created symbols are of the form {gensym}-nnn where nnn is some number. s7_is_keyword is keyword?, s7_make_keyword is string->keyword, and s7_keyword_to_symbol is keyword->symbol.
Normal symbols, and keywords do not need to be garbage-protected, but gensyms do.
s7_symbol_to_value finds the current binding of the symbol (using its string name), and returns its value, similar to symbol->value. To specify the environment in which to lookup the symbol, use s7_symbol_local_value. s7_symbol_set_value sets the value of the symbol in its current binding.
s7_symbol_table_find_name finds the symbol given its name. s7_make_symbol is the same if the symbol already exists, but s7_symbol_find_by_name returns NULL if there isn't any symbol by that name. s7_for_each_symbol_name and s7_for_each_symbol traverse the symbol table, calling "symbol_func" on each symbol. symbol_func is a boolean function that takes as arguments the symbol name and the void* data pointer. The latter can carry along whatever state your function needs. s7_for_each_symbol_name also includes some s7 constants like #f.