|
s7 is a Scheme implementation intended as an extension language for other applications, primarily Snd and Common Music. It exists as just two files, s7.c and s7.h, that want only to disappear into someone else's source tree. There are no libraries, no run-time init files, and no configuration scripts. It can be built as a stand-alone interpreter (see below). s7test.scm is a regression test for s7. If you're running s7 in a context that has getenv, file-exists?, and system (Snd for example), you can use s7-slib-init.scm to gain easy access to slib (this init file is named "s7.init" in the slib distribution). A tarball is available: ftp://ccrma-ftp.stanford.edu/pub/Lisp/s7.tar.gz.
s7 is the default extension language of Snd and sndlib (http://ccrma.stanford.edu/software/snd/), and Rick Taube's Common Music (commonmusic at sourceforge). There are X, Motif, Gtk, and openGL bindings in libxm (in the Snd tarball, or at ftp://ccrma-ftp.stanford.edu/pub/Lisp/libxm.tar.gz).
Although it is a descendent of tinyScheme, s7 is closest as a Scheme dialect to Guile 1.8 (r5rs). It has full continuations, dynamic-wind, sort!, error handling, ratios and complex numbers, define-macro, keywords, hash-tables, block comments, threads, multiprecision arithmetic for all numeric types, generalized set!, format, define*, and so on. It does not have syntax-rules or any of its friends, and it does not think there is any such thing as an "inexact integer".
This file assumes you know about Scheme and all its problems, and want a quick tour of where s7 is different.
|
All numeric types (integers, ratios, reals, complex numbers) are supported. The basic integer and real types are defined in s7.h, defaulting to long long int and double. pi is predefined, as are most-positive-fixnum and most-negative-fixnum. s7 can be built with multiprecision support for all types, using the gmp, mpfr, and mpc libraries (set WITH_GMP to 1 in s7.c). If multiprecision arithmetic is enabled, the following functions are included: bignum, bignum?, and bignum-precision. bignum-precision, which defaults to 128, sets the number of bits each float takes. pi automatically reflects the current bignum-precision:
> pi 3.141592653589793238462643383279502884195E0 > (bignum-precision) 128 > (set! (bignum-precision) 256) 256 > pi 3.141592653589793238462643383279502884197169399375105820974944592307816406286198E0
bignum? returns #t if its argument is a big number of some type (that is, I use "bignum" for any big number, not just integers). To create a big number, either include enough digits to overflow the default types, or use the bignum function. Its argument is a string representing the desired number:
> (bignum "123456789123456789") 123456789123456789 > (bignum "1.123123123123123123123123123") 1.12312312312312312312312312300000000009E0
In the non-gmp case, if s7 is built using doubles (s7_Double in s7.h), the float "epsilon" is around (expt 2 -53), or about 1e-16. In the gmp case, it is around (expt 2 (- (bignum-precision))). So in the default case (precision = 128), using gmp:
> (= 1.0 (+ 1.0 (expt 2.0 -128))) #t > (= 1.0 (+ 1.0 (expt 2.0 -127))) #fand in the non-gmp case:
> (= 1.0 (+ 1.0 (expt 2 -53))) #t > (= 1.0 (+ 1.0 (expt 2 -52))) #f
|
s7 includes:
The random function can take any numeric argument, including 0. The following constants are predefined: pi, most-positive-fixnum, most-negative-fixnum. Other math-related differences between s7 and r5rs:
> (exact? 1.0) #f > (floor 1.4) 1 > (rational? 1.5) #f > (modulo 1.4 1.0) 0.4 > (lcm 3/4 1/6) 3/2 > (log 8 2) 3 > (number->string 0.5 2) "0.1" > (string->number "0.1" 2) 0.5 > (rationalize 1.5) 3/2
The exponent itself is always in base 10 (this follows gmp usage). Since Scheme uses "@" for its useless polar notation, s7 doesn't use it for the exponent marker, but that means (string->number "1e1" 16) is ambiguous — is the "e" a digit or an exponent marker? s7 could perhaps substitute "s" in this case, but instead it just prohibits exponents if the radix is greater than 10.
> (string->number "1e9" 2) ; (expt 2 9) 512.0 > (string->number "1e1" 12) ; "e" is not a digit in base 12 #f > (string->number "1e1" 16) ; (+ (* 1 16 16) (* 14 16) 1) 481 > (string->number "1.2e1" 3); (* 3 (+ 1 2/3)) 5.0Perhaps s7 should use "@"!
"rational" in s7 does not mean "could possibly be expressed equally well as a ratio (floats are approximations!)", but "is actually expressed as a ratio (or an integer of course)"; otherwise "rational?" is the same as "real?":
(not-s7-scheme)> (rational? (sqrt 2)) #tDid "inexact" originally mean "floating point"? So 0.0 becomes an "inexact" integer (although it can be represented exactly in floating point). +inf.0 is an integer — its fractional part is explicitly zero! But +nan.0... And then there's:
(not-s7-scheme)> (integer? 9007199254740993.1) #tWhen does this matter? I often need to index into a vector, but the index is inexact. In standard scheme:
(not-s7-scheme)> (vector-ref #(0) (floor 0.1)) ERROR: Wrong type (expecting exact integer): 0.0Not to worry, I'll use inexact->exact!
(not-s7-scheme)> (inexact->exact 0.1) 3602879701896397/36028797018963968So I end up using the verbose
(inexact->exact (floor ...))
everywhere, and even then I have no guarantee that I'll get a legal vector index. When I started work on s7, I thought perhaps "exact" could mean "is represented exactly in the computer". We'd have integers and ratios exact; reals and complex exact if they are exactly represented in the current floating point implementation. 0.0 and 0.5 might be exact if the printout isn't misleading, and 0.1 is inexact. "integer?" and friends would refer instead to the programmer's point of view. That is, if the programmer uses 1 or if the thing prints as 1, it is the integer 1, whereas 1.0 means floating point (not integer!). But then what would inexact->exact do? And to keep exactness in view, we'd have to monitor which operations introduce inexactness — a kind of interval arithmetic. I may remove the exact/inexact distinction from s7. The only useful part is exact->inexact, but perhaps it would be better named "->float"? Then if you have to run code that uses those guys:(define exact? rational?) (define (inexact? x) (not (rational? x))) (define inexact->exact rationalize) ; or floor (define (exact->inexact x) (* x 1.0))I'd also remove #i and #e — they're already useless because you can have any number after, for example, #b:
> #b1.1 1.5 > #b1e2 4.0 > #o17.5+i 15.625+1i
Should s7 predefine the numbers +inf.0, -inf.0, and nan.0? It doesn't currently, but you can get them via log:
(define -inf.0 (real-part (log 0.0))) (define +inf.0 (- (real-part (log 0.0)))) (define nan.0 (/ +inf.0 +inf.0))There are some situations involving NaNs and infinities that I believe the IEEE doesn't specify. I've made what I hope are reasonable choices:
> (expt 1.0 +inf.0) 1.0 > (sin nan.0) nan.0 ;; etc
|
These are extensions of define and lambda that make it easier to to deal with optional, keyword, and rest arguments. The syntax is very simple: every argument to define* has a default value and is automatically available as a keyword argument. The default value is either #f (if unspecified), or given in a list whose first member is the argument name. The last argument can be preceded by :rest or a dot to indicate that all other trailing arguments should be packaged as a list under that argument's name. A trailing or rest argument's default value is '(). You can use :optional and :key, but they are ignored.
(define* (hi a (b 32) (c "hi")) (list a b c))
Here the argument "a" defaults to #f, "b" to 32, etc. When the function is called, the argument names are bound to their default values, then the function's current argument list is scanned. Any name that occurs as a keyword (":a") sets that argument's new value. Otherwise, as values occur, they are plugged into the actual argument list based on their position (counting a keyword/value pair as one argument). This is called an optional-key list in CLM. So, taking the function above as an example:
(hi 1) -> '(1 32 "hi") (hi :b 2 :a 3) -> '(3 2 "hi") (hi 3 2 1) -> '(3 2 1)
See s7test.scm for many examples.
(define* (make-parameter initial-value converter) (let* ((unspecified (if #f #f)) ; #<unspecified> (value (if (procedure? converter) (converter initial-value) initial-value))) (lambda* ((val unspecified)) (if (not (eq? val unspecified)) (set! value (if (procedure? converter) (converter val) val))) value))) > (define hiho (make-parameter 12)) hiho > (hiho) 12 > (hiho 32) 32 > (hiho) 32
If you want a version of define* that insists that any arguments before the keyword :optional are required:
(define-macro (define** declarations . forms) (let ((name (car declarations)) (args (cdr declarations))) (define (position thing lst count) (if (or (null? lst) (not (pair? (cdr lst)))) ; for dotted arg = "rest" arg #f (if (eq? thing (car lst)) count (position thing (cdr lst) (+ count 1))))) (let ((required-args (position :optional args 0))) (if required-args `(define* (,name . func-args) (if (< (length func-args) ,required-args) (error "~A requires ~D argument~A: ~A" ',name ,required-args (if (> ,required-args 1) "s" "") func-args) (apply (lambda* ,args ,@forms) func-args))) `(define* ,declarations ,@forms))))) > (define** (hi a :optional (b 23)) (list a b)) hi > (hi 1) (1 23) > (hi) ;hi requires 1 argument: ()
If a define* argument's default value is an expression, it is evaluated in the definition environment at the time of the procedure call:
(let ((c 1)) (define* (a (b (+ c 1))) b) (set! c 2) (let ((c 123)) (a))) ; (+ c 1) here is (+ 2 1) so this returns 3Since the expression is not evaluated until the procedure is called, it is ok to use variables that are undefined at the definition point:
> (define* (a (b c)) b) a > c ;c: unbound variable > (define c 123) c > (a) 123
To try to catch what I believe are usually mistakes, I added two error checks. One is triggered if you set the same parameter twice in the same call, and the other if an unknown keyword is encountered in the key position. These problems arise in a case such as
(define* (f (a 1) (b 2)) (list a b))You could do any of the following by accident:
(f 1 :a 2) ; what is a? (f :b 1 2) ; what is b? (f :c 3) ; did you really want a to be :c and b to be 3?In the last case, to pass a keyword deliberately, either include the argument keyword:
(f :a :c)
, or make the default value a keyword:(define* (f (a :c) ...))
.
s7's lambda* arglist handling is not the same as CL's lambda-list. First, you can have more than one :rest parameter:
> ((lambda* ((a 1) :rest b :rest c) (list a b c)) 1 2 3 4 5) (1 (2 3 4 5) (3 4 5))and second, the rest parameter, if any, takes up an argument slot just like any other argument:
> ((lambda* ((b 3) :rest x (c 1)) (list b c x)) 32) (32 1 ()) > ((lambda* ((b 3) :rest x (c 1)) (list b c x)) 1 2 3 4 5) (1 3 (2 3 4 5))CL would agree with the first case (if we used &key for 'c'), but would give an error in the second. Of course, the major difference is that s7 keyword arguments don't insist that the key be present. The :rest argument is needed in cases like these because we can't use expression such as:
> ((lambda* ((a 3) . b c) (list a b c)) 1 2 3 4 5) stray dot?Yet another nit: the :rest argument is not considered a keyword argument, so
> (define* (f :rest a) a) f > (f :a 1) (:a 1)
|
define-macro, define-macro*, defmacro, defmacro*, macroexpand, gensym, and macro? implement the standard (CL-style) macro definers.
(define-macro (add-1 arg) `(+ 1 ,arg)) (defmacro add-1 (arg) `(+ 1 ,arg))
macroexpand can help debug a macro:
> (define-macro (add-1 arg) `(+ 1 ,arg)) add-1 > (macroexpand (add-1 32)) (+ 1 32)
gensym returns a symbol that is guaranteed to be currently unused. It takes an optional string argument giving the new symbol name's prefix.
(defmacro pop! (sym) (let ((v (gensym))) `(let ((,v (car ,sym))) (set! ,sym (cdr ,sym)) ,v)))
As in define*, the starred forms give optional and keyword arguments:
> (define-macro* (add-2 a (b 2)) `(+ ,a ,b)) add-2 > (add-2 1 3) 4 > (add-2 1) 3 > (add-2 :b 3 :a 1) 4
See s7test.scm for many examples including such perennial favorites as when, loop, dotimes, do*, enum, pushnew, and defstruct.
macro? returns #t if its argument is a macro or a symbol whose value is a macro. We can use it, and other macro-related stuff to make a version of macroexpand-all:
(define-macro (fully-expand form) (define (expand form) (if (pair? form) (if (macro? (car form)) (expand ((eval (procedure-source (car form))) form)) (cons (expand (car form)) (expand (cdr form)))) form)) (expand form)) > (define-macro (hi a) `(+ 1 ,a)) hi > (define-macro (ha c) `(hi (+ ,c 1))) ha > (fully-expand (define (ho b) (+ 1 (ha b)))) ho > (procedure-source ho) (lambda (b) (+ 1 (+ 1 (+ b 1))))
fully-expand expands each macro it encounters by using the procedure-source of that macro, that is, the function that the macro definition expanded into:
(define-macro (hi a) `(+ ,a 1)) > (procedure-source hi) (lambda (defmac-13) (apply (lambda (a) (cons (quote +) (cons a (cons 1 (quote ()))))) (cdr defmac-13)))
I hesitate to mention this, but macros are "first-class" entities in s7. You can pass one as a function argument, apply it to a list, return it from a function, and assign it to a variable:
> (define-macro (hi a) `(+ ,a 1)) hi > (apply hi '((dummy-name 4))) (+ 4 1) > (define (fmac mac) (apply mac '((xxx 4)))) fmac > (fmac hi) (+ 4 1) > (define (fmac mac) (mac 4)) fmac > (fmac hi) 5 > (define (make-mac) (define-macro (hi a) `(+ ,a 1)) hi) make-mac > (let ((x (make-mac))) (x 2)) 3The presence of the dummy name in the applied macro's arguments is an historical accident; it could be removed.
s7 macros are not "hygenic". For example,
(define-macro (mac b) `(let ((a 12)) (+ a ,b))) (let ((a 1) (+ *)) (mac a))returns 144 because "+" has turned into "*", and "a" is the internal "a", not the argument "a". We get (* 12 12) where we probably expected (+ 12 1). It is possible to use gensym to clean this up, but that makes the macro unreadable in all but the simplest cases, and besides, gensymification is something a macro can do for us:
(define-macro (define-clean-macro name-and-args . body) (let ((syms ())) (define (walk func lst) (if (and (func lst) (pair? lst)) (begin (walk func (car lst)) (walk func (cdr lst))))) (define (car-member sym lst) (if (null? lst) #f (if (eq? sym (caar lst)) (cdar lst) (car-member sym (cdr lst))))) (define (walker val) (if (pair? val) (if (eq? (car val) 'quote) (or (car-member (cadr val) syms) (and (pair? (cadr val)) (or (and (eq? (caadr val) 'quote) ; 'sym -> (quote (quote sym)) val) (append (list 'list) (walker (cadr val))))) (cadr val)) (cons (walker (car val)) (walker (cdr val)))) (or (car-member val syms) val))) (walk (lambda (val) (if (and (pair? val) (eq? (car val) 'quote) (symbol? (cadr val)) (not (car-member (cadr val) syms))) (set! syms (cons (cons (cadr val) (gensym (symbol->string (cadr val)))) syms))) (or (not (pair? val)) (not (eq? (car val) 'quote)) (not (pair? (cadr val))) (not (eq? (caadr val) 'quote)))) body) (let* ((new-body (walker body)) (new-syms (map (lambda (slot) (list (cdr slot) `(gensym))) syms)) (new-globals (let ((result '())) (for-each (lambda (slot) (if (defined? (car slot)) (set! result (cons (list 'set! (cdr slot) (car slot)) result)))) syms) result))) `(define-macro ,name-and-args (let ,new-syms ,@new-globals `(begin ,,@new-body))))))Now we can automatically generate hygenic macros:
(define-clean-macro (mac b) `(let ((a 12)) (+ a ,b))) (let ((a 1) (+ *)) (mac a))which returns 13 as expected. If you just want to make sure your macro arguments don't get captured (how often does anyone actually redefine "+"?), use lambda:
(define-macro (mac a) `((lambda (b) (let ((a 12)) (+ a b))) ,a))
|
define-constant defines a constant and constant? returns #t if its argument is a constant. A constant in s7 is really constant: it can't be set or rebound.
> (define-constant var 32) var > (set! var 1) ;set!: can't alter immutable object: var > (let ((var 1)) var) ;can't bind or set an immutable object: var, line 1
This has the possibly surprising side effect that previous uses of the constant name become constants:
(define (func a) (let ((cvar (+ a 1))) cvar)) (define-constant cvar 23) (func 1) ;can't bind or set an immutable object: cvar
So, obviously, choose unique names for your constants, or don't use define-constant. A function can also be a constant (define-constant is an extension of define).
Constants are very similar to things such as keywords (no set, always return itself as its value), variable trace (informative function upon set or keeping a history of past values), typed variables (restricting a variable's values or doing automatic conversions upon set), and notification upon set (either in Scheme or in C; I wanted this many years ago in Snd). The notification function is especially useful if you have a Scheme variable and want to reflect any change in its value immediately in C (see example below). All of these cases modify the path between a symbol and its value. s7 gives you a handle on that path via the procedure-with-setter symbol-access. (symbol-access symbol) returns that symbol's accessors (if any), and (set! (symbol-access symbol) accessor-list) changes it. The accessor-list is a list of three functions, the get, set, and bind functions. The set and bind functions take two arguments, the symbol in question and the value that it is about to be set or bound to. The variable is set or bound to the value they return. We could replace define-constant, and add local constants with:
(define constant-access (list #f (lambda (symbol new-value) (error "can't change constant ~A's value to ~A" symbol new-value)) (lambda (symbol new-value) (error "can't bind constant ~A to a new value, ~A" symbol new-value)))) (define-macro (define-constant symbol value) `(begin (define ,symbol ,value) (set! (symbol-access ',symbol) constant-access) ',symbol)) (define-macro (let-constant vars . body) (let ((varlist (map car vars))) `(let ,vars ,@(map (lambda (var) `(set! (symbol-access ',var) constant-access)) varlist) ,@body)))
In the next example, we restrict the values a variable can take to integers:
(define-macro (define-integer var value) `(begin (define ,var ,value) (set! (symbol-access ',var) (list #f (lambda (symbol new-value) (if (real? new-value) (floor new-value) ; or min/max to restrict it to some range etc (error "~A can only take an integer value, not ~S" symbol new-value))) #f)) ',var)) > (define-integer int 123) int > (set! int 321.67) 321 > (set! int (list 1 2)) ;int can only take an integer value, not (1 2)
Here are trace and untrace. We save the previous accessors in trace, restore them upon untrace, and in between, call the previous set accessor, if any, after reporting the set:
(define (trace var) (let* ((cur-access (symbol-access var)) (cur-set (and cur-access (cadr cur-access)))) (set! (symbol-access var) (list (and cur-access (car cur-access)) (lambda (symbol new-value) (format #t "~A set to ~A~%" symbol new-value) (if cur-set (cur-set symbol new-value) new-value)) (and cur-access (caddr cur-access)) cur-access)))) ; save the old version (define (untrace var) (if (and (symbol-access var) (cdddr (symbol-access var))) (set! (symbol-access var) (cadddr (symbol-access var)))))
The "get" function is currently not implemented. I believe symbol-access is similar to Ruby's hooked variables, or perhaps Perl's tied variables. You could implement all kinds of fancy things with this mechanism. (One amusing case: property lists. Just tack the properties onto the end of the accessor list, as in trace above).
We can use symbol-access to fix fluid-let. The usual form of that macro claims that it implements dynamic scope, but it doesn't:
(let ((x 32) (y 0)) (define (gx) x) (let ((x 100)) (fluid-let ((x 12)) (set! y (gx)))) (list x y))which returns '(32 32) whereas the correct value is '(32 12). To fix it, we block let-binding and add let-global:
(define-macro (define-global variable value) `(begin (define ,variable ,value) (set! (symbol-access ',variable) (list #f #f (lambda (symbol new-value) (error "use let-global to bind a global variable")))))) (define-macro (let-global xexe . body) ;; all xexe vars are assumed to be global variables ;; this is fluid-let, taken with changes from Teach Yourself Scheme (let ((xx (map car xexe)) (ee (map cadr xexe)) (old-xx (map (lambda (ig) (gensym)) xexe))) `(let ,(map (lambda (old-x x) `(,old-x ,x)) old-xx xx) (dynamic-wind (lambda () #f) (lambda () ,@(map (lambda (x e) `(set! ,x ,e)) xx ee) (let () ,@body)) (lambda () ,@(map (lambda (x old-x) `(set! ,x ,old-x)) xx old-xx)))))) (let () (define-global x 32) (let ((y 0)) (define (gx) x) (let-global ((x 100)) (let-global ((x 12)) (set! y (gx)))) (list x y)))which returns '(32 12).
|
make-type (borrowed from Alaric Snell-Pym) returns a type-object: a list of three functions '?, 'make, and 'ref. The ? func returns #t if its argument is of the new type, the make function returns a new object of the new type with the value of the argument to the make function, and the ref function returns that value when passed that object.
(define special-value ((cadr (make-type)) 'special)) ;; now special-value's value can't be eq? to any other scheme object ;; expand, for example, (define-record rec (a 1) (b 2)) (begin (define rec? #f) (define make-rec #f) (define rec-a #f) (define rec-b #f) (let* ((rec-type (make-type)) (? (car rec-type)) (make (cadr rec-type)) (ref (caddr rec-type))) (set! make-rec (lambda* ((a 1) (b 2)) (make (vector a b)))) (set! rec? ?) (set! rec-a (make-procedure-with-setter (lambda (obj) (and (rec? obj) (vector-ref (ref obj) 0))) (lambda (obj val) (if (rec? obj) (vector-set! (ref obj) 0 val))))) (set! rec-b (make-procedure-with-setter (lambda (obj) (and (rec? obj) (vector-ref (ref obj) 1))) (lambda (obj val) (if (rec? obj) (vector-set! (ref obj) 1 val))))))) #| (let ((hi (make-rec 32 '(1 2)))) (set! (rec-b hi) 123) (format #t "rec: ~A ~A" (rec-a hi) (rec-b hi))) "rec: 32 123" |#
Currently make-type takes some optional arguments to specify other actions. I might change this to be an alist of (operation function) pairs, but for now, the optional (optkey) arguments are: print equal getter setter length name copy fill. Except for the 'name' argument, these are functions. When these functions are called, the argument representing the object is the value of the object, not the object itself (see the examples below). If no print function is specified, the 'name' argument is used when the object is displayed. The 'equal' function checks two objects of the new type for equality. The 'getter' function applies the object to whatever arguments are passed, and the 'setter' function does the same in the context of set!. The 'length' function returns the length of the object's value. The 'copy function returns a new object of the same type with the copy function applied to the old object's value. The 'fill' function takes two arguments, the object and what to fill its value with. So, remembering that (cadr type) is the make function:
> ((cadr (make-type)) 3.14) #<anonymous-type 3.14> > ((cadr (make-type :name "hiho")) 123) #<hiho 123> > ((cadr (make-type :print (lambda (a) (format #f "#<typo: |~A|>" a)))) 1) #<typo: |1|> > (((cadr (make-type :getter (lambda (a b) (vector-ref a b)))) (vector 1 2 3)) 1) 2
The last is easier to read if we separate out the steps:
> (let* ((type (make-type :getter (lambda (a b) (vector-ref a b)))) ; make a new type with its own getter function (object ((cadr type) (vector 1 2 3)))) ; create an object of the new type, its value is a vector (object 1)) ; "apply" the object to 1 => (vector-ref object 1) via the getter 2
The objects created in this way, or via s7_new_type in C, can be passed to for-each if you supply the length and getter functions to make-type.
Here is define-record using make-type. It has a few Common Lisp extensions:
(define-macro (define-record struct-name . fields) (let* ((name (if (list? struct-name) (car struct-name) struct-name)) (sname (if (string? name) name (symbol->string name))) (fsname (if (list? struct-name) (let ((cname (assoc :conc-name (cdr struct-name)))) (if cname (symbol->string (cadr cname)) sname)) sname)) (make-name (if (list? struct-name) (let ((cname (assoc :constructor (cdr struct-name)))) (if cname (cadr cname) (string->symbol (string-append "make-" sname)))) (string->symbol (string-append "make-" sname)))) (is-name (string->symbol (string-append sname "?"))) (copy-name (if (list? struct-name) (let ((cname (assoc :copier (cdr struct-name)))) (if cname (cadr cname) (string->symbol (string-append "copy-" sname)))) (string->symbol (string-append "copy-" sname)))) (field-names (map (lambda (n) (symbol->string (if (list? n) (car n) n))) fields)) (field-types (map (lambda (field) (if (list? field) (apply (lambda* (val type read-only) type) (cdr field)) #f)) fields)) (field-read-onlys (map (lambda (field) (if (list? field) (apply (lambda* (val type read-only) read-only) (cdr field)) #f)) fields))) `(begin ;; declare our globally-accessible names (define ,is-name #f) (define ,make-name #f) (define ,copy-name #f) ,@(map (lambda (n) `(define ,(string->symbol (string-append fsname "-" n)) #f)) field-names) (let* ((rec-type (make-type)) (? (car rec-type)) (make (cadr rec-type)) (ref (caddr rec-type))) (set! ,is-name ?) (set! ,make-name (lambda* ,(map (lambda (n) (if (and (list? n) (>= (length n) 2)) (list (car n) (cadr n)) (list n #f))) fields) (make (vector ',(string->symbol sname) ,@(map string->symbol field-names))))) (set! ,copy-name (lambda (obj) (make (copy (ref obj))))) ,@(map (let ((ctr 1)) (lambda (n type read-only) (let ((val (if read-only `(set! ,(string->symbol (string-append fsname "-" n)) (lambda (arg) ((ref arg) ,ctr))) `(set! ,(string->symbol (string-append fsname "-" n)) (make-procedure-with-setter (lambda (arg) ((ref arg) ,ctr)) (lambda (arg val) (set! ((ref arg) ,ctr) val))))))) (set! ctr (+ 1 ctr)) val))) field-names field-types field-read-onlys) ',struct-name)))) > (define-record point (x 0.0) (y 0.0)) point > (let ((pt (make-point 1.0))) (set! (point-y pt) 3.0) (list (point? pt) (point-x pt) (point-y pt))) (#t 1.0 3.0)
In the next example, we define a float-vector type:
(begin (define make-float-vector #f) (define float-vector? #f) (define float-vector #f) (let* ((fv-type (make-type :getter vector-ref :length length :copy copy :fill fill! :setter (lambda (obj index value) (if (not (real? value)) (error 'wrong-type-arg-error "float-vector element must be real: ~S" value)) (vector-set! obj index (exact->inexact value))) :name "float-vector")) (fv? (car fv-type)) (make-fv (cadr fv-type)) (fv-ref (caddr fv-type))) (set! make-float-vector (lambda* (len (initial-element 0.0)) (if (not (real? initial-element)) (error 'wrong-type-arg-error "make-float-vector initial element must be real: ~S" initial-element)) (make-fv (make-vector len (exact->inexact initial-element))))) (set! float-vector? fv?) (set! float-vector (lambda args (let* ((len (length args)) (fv (make-float-vector len)) (v (fv-ref fv))) (do ((lst args (cdr lst))) (i 0 (+ i 1))) ((null? lst) fv) (let ((arg (car lst))) (if (not (real? arg)) (error 'wrong-type-arg-error "float-vector element must be real: ~S in ~S" arg args)) (set! (v i) (exact->inexact arg)))))))) > (let ((v (make-float-vector 3))) (set! (v 1) 32) v) #<float-vector #(0.0 32.0 0.0)> > (let ((v (make-float-vector 3))) (set! (v 1) "hi") v) ;float-vector element must be real: "hi" > (map + (list 1 2 3) (float-vector 1 2 3)) ; we have a getter and length, so map and for-each will work (2.0 4.0 6.0)
I seem to be using the same construct over and over; a begin to hold the names defined in the outer environment, a let to hold internal stuff, and set!s to give the names values. It's a clumsy, but simple way for multiple functions to share a closure. Maybe it rates a macro:
(define-macro (blet* names bindings . body) `(begin ,@(map (lambda (name) `(define ,name #f)) names) (let* ,bindings ,@body))) (blet* (make-adjustable-vector adjustable-vector? adjust-vector) ((av-type (make-type :name "adjustable-vector" :getter (lambda (obj index) ((car obj) index)) :setter (lambda (obj index value) (set! ((car obj) index) value)) :length (lambda (obj) (vector-length (car obj))) :print (lambda (obj) (object->string (car obj))))) (av? (car av-type)) (make-av (cadr av-type)) (av-ref (caddr av-type))) (set! make-adjustable-vector (lambda args (make-av (list (apply make-vector args))))) (set! adjustable-vector? av?) (set! adjust-vector (lambda* (obj new-length initial-element) (let* ((new-vector (make-vector new-length initial-element)) (copy-len (min new-length (length obj)))) (do ((i 0 (+ i 1))) ((= i copy-len)) (set! (new-vector i) (obj i))) (set! (car (av-ref obj)) new-vector))))) > (define v (make-adjustable-vector 3 #f)) v > v #(#f #f #f) > (set! (v 1) 32.0) 32.0 > v #(#f 32.0 #f) > (adjust-vector v 10 #f) #(#f 32.0 #f #f #f #f #f #f #f #f)
|
A procedure-with-setter consists of two functions, the "getter" and the "setter". The getter is called when the object is encountered as a function, and the setter when it is set:
(define xx (let ((x 32)) (make-procedure-with-setter (lambda () x) (lambda (val) (set! x val) x)))) (xx) -> 32 (set! (xx) 1) (xx) -> 1
The setter's last argument is the value passed to set!. That is,
(define v123 (let ((vect (vector 1 2 3))) (make-procedure-with-setter (lambda (index) (vect index)) (lambda (index value) (set! (vect index) value))))) > (v123 2) 3 > (set! (v123 2) 32) 32 > (v123 2) 32
Here is a pretty example of make-procedure-with-setter:
(define-macro (c?r path) ;; "path" is a list and "X" marks the spot in it that we are trying to access ;; (a (b ((c X)))) -- anything after the X is ignored, other symbols are just placeholders ;; c?r returns a procedure-with-setter that gets/sets X (define (X-marks-the-spot accessor tree) (if (pair? tree) (or (X-marks-the-spot (cons 'car accessor) (car tree)) (X-marks-the-spot (cons 'cdr accessor) (cdr tree))) (if (eq? tree 'X) accessor #f))) (let ((body 'lst)) (for-each (lambda (f) (set! body (list f body))) (reverse (X-marks-the-spot '() path))) `(make-procedure-with-setter (lambda (lst) ,body) (lambda (lst val) (set! ,body val))))) > ((c?r (a b (X))) '(1 2 (3 4) 5)) 3 > (let ((lst (list 1 2 (list 3 4) 5))) (set! ((c?r (a b (X))) lst) 32) lst) (1 2 (32 4) 5) > (procedure-source (c?r (a b (X)))) (lambda (lst) (car (car (cdr (cdr lst))))) > ((c?r (a b . X)) '(1 2 (3 4) 5)) ((3 4) 5) > (let ((lst (list 1 2 (list 3 4) 5))) (set! ((c?r (a b . X)) lst) '(32)) lst) (1 2 32) > (procedure-source (c?r (a b . X))) (lambda (lst) (cdr (cdr lst))) > ((c?r (((((a (b (c (d (e X)))))))))) '(((((1 (2 (3 (4 (5 6)))))))))) 6 > (let ((lst '(((((1 (2 (3 (4 (5 6))))))))))) (set! ((c?r (((((a (b (c (d (e X)))))))))) lst) 32) lst) (((((1 (2 (3 (4 (5 32))))))))) > (procedure-source (c?r (((((a (b (c (d (e X))))))))))) (lambda (lst) (car (cdr (car (cdr (car (cdr (car (cdr (car (cdr (car (car (car (car lst)))))))))))))))
|
procedure-with-setters can be viewed as one generalization of set!. Another treats objects as having predefined get and set functions. In s7 lists, strings, vectors, hash-tables, and any cooperating C or Scheme-defined objects are both applicable and settable. I think the syntax is pretty (the less noise, the better!):
;; an example taken from R Cox's website (define dense (make-vector 128)) (define sparse (make-vector 128)) (define n 0) (define (add-member i) (set! (dense n) i) (set! (sparse i) n) (set! n (+ n 1))) (define (is-member i) (and (number? (sparse i)) (< (sparse i) n) (= (dense (sparse i)) i))) (define (clear-all) (set! n 0)) (define (remove-member i) (if (is-member i) (begin (let ((j (dense (- n 1)))) (set! (dense (sparse i)) j) (set! (sparse j) (sparse i)) (set! n (- n 1)))))) (add-member 32) 1 (add-member 12) 2 (is-member 14) #f (is-member 12) #t
Lists and hash-tables behave similarly:
(let ((lst (list 1 2 3))) (set! (lst 1) 32) (list (lst 0) (lst 1))) -> '(1 32) (let ((hash (make-hash-table))) (set! (hash 'hi) 32) (hash 'hi)) -> 32
You can use list-ref and friends, of course, but just try to read any serious vector arithmetic code when it is buried in vector-refs and vector-set!s! set! can also apply to string-ref, list-ref, vector-ref, hash-table-ref, car, and cdr. That is,
> (let ((str "123")) (set! (string-ref str 1) #\x) str) "1x3" > (let ((str "123")) (set! (str 1) #\x) str) "1x3"
Well, maybe applicable strings look weird:
("hi" 1)
is #\i, but worse, so is(cond (1 => "hi"))
!
The applicable object syntax makes it easy to write generic functions. For example, s7test.scm has implementations of Common Lisp's sequence functions. length, copy, reverse, fill!, map and for-each are generic in this sense (map always returns a list).
> (map (lambda (a b) (- a b)) (list 1 2) (vector 3 4)) (5 -3 9) > (length "hi") 2We can write an FFT procedure that accepts lists or vectors:
(define* (cfft! data n (dir 1)) ; (complex data) (if (not n) (set! n (length data))) (do ((i 0 (+ i 1)) (j 0)) ((= i n)) (if (> j i) (let ((temp (data j))) (set! (data j) (data i)) (set! (data i) temp))) (let ((m (/ n 2))) (do () ((or (< m 2) (< j m))) (set! j (- j m)) (set! m (/ m 2))) (set! j (+ j m)))) (let ((ipow (floor (log n 2))) (prev 1)) (do ((lg 0 (+ lg 1)) (mmax 2 (* mmax 2)) (pow (/ n 2) (/ pow 2)) (theta (make-rectangular 0.0 (* pi dir)) (* theta 0.5))) ((= lg ipow)) (let ((wpc (exp theta)) (wc 1.0)) (do ((ii 0 (+ ii 1))) ((= ii prev)) (do ((jj 0 (+ jj 1)) (i ii (+ i mmax)) (j (+ ii prev) (+ j mmax))) ((>= jj pow)) (let ((tc (* wc (data j)))) (set! (data j) (- (data i) tc)) (set! (data i) (+ (data i) tc)))) (set! wc (* wc wpc))) (set! prev mmax)))) data) > (cfft! (list 0.0 1+i 0.0 0.0)) (1+1i -1+1i -1-1i 1-1i) > (cfft! (vector 0.0 1+i 0.0 0.0)) #(1+1i -1+1i -1-1i 1-1i)
|
s7 supports vectors with any number of dimensions. It is here, in particular, that the generalized set! stuff shines. make-vector's 2nd argument can be a list of dimensions, rather than an integer (the one dimensional case):
(make-vector (list 2 3 4)) (make-vector '(2 3) 1.0) (vector-dimensions (make-vector (list 2 3 4))) -> (2 3 4)
The second example includes the optional initial element.
(vect i ...)
or (vector-ref vect i ...)
return the given
element, and (set! (vect i ...) value)
and (vector-set! vect i ... value)
set it. vector-length (or just length) returns the total number of elements.
vector-dimensions returns a list of the dimensions.
> (define v (make-vector '(2 3) 1.0)) #2D((1.0 1.0 1.0) (1.0 1.0 1.0)) > (set! (v 0 1) 2.0) #2D((1.0 2.0 1.0) (1.0 1.0 1.0)) > (v 0 1) 2.0 > (vector-length v) 6
matrix multiplication:
(define (matrix-multiply A B) ;; assume square matrices and so on here for simplicity (let* ((size (car (vector-dimensions A))) (C (make-vector (list size size) 0))) (do ((i 0 (+ i 1))) ((= i size) C) (do ((j 0 (+ j 1))) ((= j size)) (let ((sum 0)) (do ((k 0 (+ k 1))) ((= k size)) (set! sum (+ sum (* (A i k) (B k j))))) (set! (C i j) sum))))))
Multidimensional vector constant syntax is modelled after CL: #nd(...) or #nD(...) signals that the lists specify the elements of an 'n' dimensional vector:
#2D((1 2 3) (4 5 6))
> (vector-ref #2D((1 2 3) (4 5 6)) 1 2) 6 > (matrix-multiply #2d((-1 0) (0 -1)) #2d((2 0) (-2 2))) #2D((-2 0) (2 -2))If any dimension has 0 length, you get an n-dimensional empty vector. It is not equal to a 1-dimensional empty vector.
> (make-vector '(10 0 3)) #3D() > (equal? #() #3D()) #f
|
The hashed object can be a symbol, string, integer, or (problematically of course) a real.
(let ((ht (make-hash-table))) (set! (ht "hi") 123) (ht "hi")) -> 123
hash-table parallels vector, list, and string. Its arguments are cons's containing the key/value pair.
The result is a new hash-table with those values preinstalled: (hash-table '("hi" . 32) '("ho" 1))
.
Since hash-tables accept the same applicable-object syntax that vectors use, we can treat a hash-table as, for example, a sparse array:
> (define make-sparse-array make-hash-table) make-sparse-array > (let ((arr (make-sparse-array))) (set! (arr 1032) "1032") (set! (arr -23) "-23") (list (arr 1032) (arr -23))) ("1032" "-23")
for-each and map accept hash-table arguments. Currently, the map or for-each function is passed the internal lists, rather than the key/value pairs (this is a bug; someday I'll fix it!).
(define (hash-table->alist table) (let ((alist '())) (for-each (lambda (lst) ; this outer for-each should not be necessary (for-each (lambda (key.value) (set! alist (cons key.value alist))) lst)) table) alist))
|
If s7 is built with HAVE_PTHREADS set, you get multithreading functions.
Threads in s7 share the heap and symbol table, but have their own local environment, stack, and evaluator locals. I use the term "lock" in place of "mutex", and "thread-variable" in place of "pthread_key". The thread-variable is applicable and settable, so instead of pthread_getspecific, just call it: (var).
(let ((a-lock (make-lock)) (threads '()) (a-thread-variable (make-thread-variable))) (let loop ((i 0)) (set! threads (cons (make-thread (lambda () (set! (a-thread-variable) i) (grab-lock a-lock) (format #t "thread ~A " (a-thread-variable)) (release-lock a-lock))) threads)) (if (< i 8) (loop (+ i 1)))) (for-each (lambda (thread) (join-thread thread)) threads))
|
The r5rs section about values makes no sense to me; why have multiple values at all if you're just going to throw away all but the first value? In s7 (+ (values 1 2 3) 4) is 10. Similarly,
(string-ref ((lambda () (values "abcd" 2)))) -> #\c ((lambda (a b) (+ a b)) ((lambda () (values 1 2)))) -> 3 ;; call-with-values: (define-macro (call-with-values producer consumer) `(,consumer (,producer))) ;; multiple-value-bind ("receive" in srfi-8): (define-macro (multiple-value-bind vars expr . body) `((lambda ,vars ,@body) ,expr)) ;; multiple-value-set!: (define-macro (multiple-value-set! vars expr . body) (let ((local-vars (map (lambda (n) (gensym)) vars))) `((lambda ,local-vars ,@(map (lambda (n ln) `(set! ,n ,ln)) vars local-vars) ,@body) ,expr))) ;; call/cc returns multiple values: (+ (call/cc (lambda (ret) (ret 1 2 3))) 4) -> 10 ;; let*-values is defined as a macro at the end of s7.c (commented out)
Is there any real need for multiple-values (even in its CL form)? Daniel Weinreb says the original intention was to avoid consing, which it does in s7, but that's a gnat's eyelash of an optimization. And what is:
(+ (values (values 1 2) (values 4 5)))In Guile, the + operator returns multiple-values (1 and 4) in this case, whereas s7 returns 12. But
(+ (values (values 1 2) (values 4 5)) 0)in Guile just returns 1! In Clisp, both cases return 1. This causes total confusion:
(apply + (map (lambda (n) (values n (+ n 1))) (list 1 2)))
|
call-with-exit is call/cc without the ability to return (an escape or goto, "call/exit"?).
(define (find-first-even-number arg) (call-with-exit (lambda (return) (for-each (lambda (a) (if (even? a) (return a))) arg)))) (find-first-even-number (list 1 3 9 13 8 2 4)) -> 8 (define-macro (block . body) `(call-with-exit (lambda (return) ,@body))) (block (display "hi") (return 32) (display "oops")) -> 32
continuation? returns #t if its argument is a continuation, as opposed to a normal procedure. I don't know why Scheme hasn't had this function from the very beginning, but it's needed if you want to write a continuable error handler. Here is a sketch of the situation:
(let () (catch #t (lambda () (let ((res (call/cc (lambda (ok) (error 'cerror "an error" ok))))) (display res) (newline))) (lambda args (if (and (eq? (car args) 'cerror) (continuation? (cadadr args))) (begin (display "continuing...") ((cadadr args) 2))) (display "oops")))) -> continuing...2
In a more general case, the error handler is separate from the catch body, and needs a way to distinguish a real continuation from a simple procedure. Otherwise, it blithely announces that it is continuing from the point of the error, but then fails to do so.
|
s7's built-in format function is very close to that in srfi-48.
(format #f "~A ~D ~F" 'hi 123 3.14) -> "hi 123 3.140000"
The format directives (tilde chars) are:
~% insert newline ~& insert newline if preceding char was not newline ~~ insert tilde ~\n (tilde followed by newline): trim white space ~{ begin iteration (take arguments from a list) ~} end iteration ~^ jump out of iteration ~* ignore the current argument ~A object->string as in display ~S object->string as in write ~C print as character ~P insert 's' if current argument is not 1 or 1.0 (use ~@P for "ies" or "y") ~B number->string in base 2 ~O number->string in base 8 ~D number->string in base 10 ~X number->string in base 16 ~E float to string, (format #f "~E" 100.1) -> "1.001000e+02", (%e in C) ~F float to string, (format #f "~F" 100.1) -> "100.100000", (%f in C) ~G float to string, (format #f "~G" 100.1) -> "100.1", (%g in C) ~T insert spaces (padding)
The last eight take the usual numeric arguments to specify field width and precision.
Floats can occur in any base, so:
> #xf.c 15.75This also affects format. In most schemes,
(format #f "~X" 1.25)
is an error (in CL, it is equivalent to using ~A which is perverse). But> (number->string 1.25 16) "1.4"and there's no obvious way to get the same effect from format unless we accept floats in the "~X" case. So in s7,
> (format #f "~X" 21) "15" > (format #f "~X" 1.25) "1.4" > (format #f "~X" 1.25+i) "1.4+1.0i" > (format #f "~X" 21/4) "15/4"That is, the output choice matches the argument.
|
object->string returns the string representation of its argument, like format with ~S:
> (object->string "hiho") "\"hiho\"" > (format #f "~S" "hiho") "\"hiho\""
I added object->string before deciding to include format; it's no longer very useful. Similarly, string->list can be replaced by map, and list->string by string (using apply).
|
s7's error handling mimics that of (pre-r6rs) Guile. An error is signalled via the error function, and can be trapped and dealt with via catch.
(catch 'wrong-number-of-args (lambda () ; code protected by the catch (abs 1 2)) (lambda args ; the error handler (apply format (append (list #t) (cadr args))))) -> "abs: too many arguments: (1 2)" (catch 'division-by-zero (lambda () (/ 1.0 0.0)) (lambda args (string->number "inf.0"))) -> inf.0
catch has 3 arguments: a tag indicating what error to catch (#t = anything), the code (a thunk) that the catch is protecting, and the function to call if a matching error occurs during the evaluation of the thunk. The error handler takes a rest argument which will hold whatever the error function chooses to pass it. The error function itself takes at least 2 arguments, the error type (a symbol), and the error message. There may also be other arguments describing the error. The default action (in the absence of any catch) is to treat the message as a format control string, apply format to it and the other arguments, and send that info to the current-error-port.
When an error is encountered, the variable *error-info* (a vector) contains additional info about that error:
To find a variable's value at the point of the error:
(symbol->value var (vector-ref *error-info* 5))
To print the stack at the point of the error:
(stacktrace *error-info*)
The variable *error-hook* provides a way to specialize error reporting. It is a function of 2 arguments, the values passed by the error function (the error type and whatever other info accompanies it).
(set! *error-hook* (lambda (tag args) (apply format (cons #t args))))
stacktrace can be called anytime to see the chain of function calls. Its optional argument can be *error-info* (as above) to show the stack at the point of the last error, a thread object to show that thread's stack, or a continuation to show the continuation stack.
(let () (define (a1 a) (+ a #\c)) (define (a2 b) (+ b (a1 b))) (define (a3 c) (+ c (a2 c))) (catch #t (lambda () (a3 1)) (lambda args (stacktrace *error-info*)))) -> (a1 (a . 1)) (a2 (b . 1)) (a3 (c . 1))
See also trace below. There is a break macro defined in Snd (see snd-xen.c) which allows you to stop at some point, then evaluate arbitrary expressions in that context. There's yet another hook, *unbound-variable-hook*, which is called when an unbound variable is encountered (before the error is signalled). Its value is a function of one argument, the unbound symbol. In Snd, this is used to implement autoloading:
(set! *unbound-variable-hook* (lambda (sym) ;; add your own symbol checks here (let ((file (autoload-file (symbol->string sym)))) ;; autoload-file is a Snd function that knows where a lot of Snd's scheme functions are (if file (load file)) (symbol->value sym)))) ; this will return #<undefined> if we didn't find its source file
The s7-built-in catch tags (error symbols) are 'wrong-type-arg, 'syntax-error, 'read-error, 'thread-error, 'out-of-memory, 'wrong-number-of-args, 'format-error, 'out-of-range, 'division-by-zero, 'io-error, and 'bignum-error.
|
These functions provide tracing:
(define (hiho arg) (if (> arg 0) (+ 1 (hiho (- arg 1))) 0)) (trace hiho) (hiho 3) [hiho 3] [hiho 2] [hiho 1] [hiho 0] 0 1 2 3
trace adds a function to the list of functions being traced, and untrace removes it. trace with no arguments causes everything to be traced, and untrace with no arguments turns this off.
There is also a hook, *trace-hook*, a function of 2 arguments (the currently traced function and the list of current arguments). It is evaluated in the environment of the function call (that is, global to the function, not the function's local environment).
(define (hiho a b c) (* a b c)) (set! *trace-hook* (lambda (f args) (format #t "sum of args: ~A~%" (apply + args)))) (trace hiho) (hiho 2 3 4) [hiho 2 3 4] sum of args: 9 24
|
Besides files, ports can also represent strings and functions. The string port functions are:
(let ((result #f) (p (open-output-string))) (format p "this ~A ~C test ~D" "is" #\a 3) (set! result (get-output-string p)) (close-output-port p) result) -> "this is a test 3"
Other functions:
The variable *vector-print-length* sets the upper limit on how many vector elements are printed by object->string and format.
When running s7 behind a GUI, you often want input to come from and output to go to arbitrary widgets. The "function ports" provide a way to redirect IO. See below for an example.
s7 also includes current-error-port and set-current-error-port.
binary-io.scm in the Snd package has functions that read and write integers and floats in both endian choices in a variety of sizes. Besides read-byte and write-byte, it uses integer-decode-float, and the various bitwise operators.
|
procedure-source, procedure-arity, procedure-documentation, and help provide a look into a scheme function. procedure-documentation returns the documentation string associated with a procedure (the initial string in the function's body). procedure-arity returns a list describing the argument list of a function: '(required-args optional-args rest-arg?). procedure-source returns the source (as a list) of a procedure. procedure-environment returns a procedure's environment.
> (define* (add-2 a (b 32)) "add-2 adds its 2 args" (+ a b)) add-2 > (procedure-documentation add-2) "add-2 adds its 2 args" > (procedure-arity add-2) (0 2 #f) > (procedure-source add-2) (lambda* (a (b 32)) "add-2 adds its 2 args" (+ a b))
We can use procedure-environment and __func__ (mentioned below) to write a function that tells us where the source is for a function:
(define (where-is func) (let ((addr (cdr (assoc '__func__ (car (procedure-environment func)))))) (if (not (pair? addr)) "not found" (format #f "~A is at line ~D of ~A" (car addr) (caddr addr) (cadr addr))))) > (where-is profile) "profile is at line 1048 of extensions.scm"
procedure-source returns the actual function source — more fun than a barrel of monkeys. Here is a circular function:
(define (cfunc) (begin (display "func! ") #f)) (let ((clst (procedure-source cfunc))) (set! (cdr (cdr (car (cdr (cdr clst))))) (cdr (car (cdr (cdr clst)))))) (cfunc) ; displays "func! " until you kill itCould you implement goto this way? Now we can write code that is not only unreadable, but unprintable!
Since define* accepts multiple rest arguments, perhaps procedure-arity should return that number, rather than a boolean. I haven't run into a case where it matters. If procedure-arity is passed a procedure-with-setter, it returns 6 values, rather than 3. The first 3 describe the "getter" and the following 3 describe the "setter". I wonder if it would be more consistent to use the name "procedure/setter" in place of "make-procedure-with-setter". (Its syntax is closer to vector than make-vector, for example).
|
(symbol-table) returns the symbol table, a vector of lists of symbols. (symbol->value sym :optional env) returns the binding of 'sym' in the given environment which defaults to the current environment. (defined? obj :optional env) returns #t if 'obj' has a binding (a value) in the environment 'env'. If profiling is enabled (set WITH_PROFILING in s7.c), (symbol-calls sym) returns the number of times that symbol's binding has been applied. Here we scan the symbol table for any function that doesn't have documentation:
(let ((st (symbol-table))) (do ((i 0 (+ i 1))) ((= i (vector-length st))) (let ((lst (vector-ref st i))) (for-each (lambda (sym) (if (defined? sym) (let ((val (symbol->value sym))) (if (and (procedure? val) (string=? "" (procedure-documentation val))) (format #t "~A " sym))))) lst))))
|
environments are "first class objects" in s7. An environment is a list of alists ending with a hash-table (the global environment). (current-environment :optional thread) returns the current environment (symbol bindings). (global-environment) returns the top-level environment. (procedure-environment proc) returns the procedure proc's environment. Here is an example of "apropos" that accesses both environments:
(define (apropos name) ;; (apropos "name") prints out a list of all symbols whose name includes "name" as a substring (define (substring? subs s) ; from Larceny (let* ((start 0) (ls (string-length s)) (lu (string-length subs)) (limit (- ls lu))) (let loop ((i start)) (cond ((> i limit) #f) ((do ((j i (+ j 1)) (k 0 (+ k 1))) ((or (= k lu) (not (char=? (string-ref subs k) (string-ref s j)))) (= k lu))) i) (else (loop (+ i 1))))))) (define (apropos-1 alist) (for-each (lambda (binding) (if (substring? name (symbol->string (car binding))) (format (current-output-port) "~A: ~A~%" (car binding) (if (procedure? (cdr binding)) (procedure-documentation (cdr binding)) (cdr binding))))) alist)) (for-each (lambda (frame) (if (vector? frame) ; the global environment (let ((len (vector-length frame))) (do ((i 0 (+ i 1))) ((= i len)) (apropos-1 (vector-ref frame i)))) (apropos-1 frame))) (current-environment)))
(with-environment env . body) evaluates its body in the environment env. Although the environment is just a list of alists of (symbol . value) pairs, you can't simply add new pairs to it (or use set-cdr! to change the value in an existing binding) because symbol lookup is optimized to reduce the time spent pawing through the environment. So, to add a new value to an environment, use augment-environment:
(let ((a 1)) (eval '(+ a b) (augment-environment (current-environment) (cons 'b 32)))) ; add 'b with the value 32 to this environment -> 33
augment-environment does not change the environment passed to it. It
just prepends the new bindings (shadowing any old ones),
as if you had called "let".
I think these two functions can implement the notions of libraries,
separate namespaces, or modules. The library file exports a list
of bindings: (cons name value)
, keeping all its own
code in a let, or group of lets:
(let ((var1 32)) (define (func1 a) (+ a 1)) (define (func2 a) (+ a 2)) (list (cons 'func1 func1) (cons 'func2 func2) (cons 'var1 var1)))
Loading this file returns the list (load returns the last thing it evaluates). For explicitness, we could put the list of names at the top of the file (an "export" statement), and fill in the values as we define them (as in the make-type record example above). The file that wants to use this library uses with-environment and augment-environment to "import" the exported values:
(define (import file) (apply augment-environment (current-environment) (load file))) (with-environment (import "lib1.scm") (display (* (func1 var1) (func2 var1)))) ; displays 1122, i.e. (* 33 34)
If we want to import these things under different names, or use only some subset, the list passed to augment-environment is at our disposal. Loading a library file does not add anything to our environment unless we explicitly ask for it, and subsets and renaming are trivial. To import many libraries, just nest the import statements, or make a version that loads up all the libraries, saving the exported lists, and pass them concatenated to augment-environment. And when we leave the with-environment body, all those new bindings go away too, so the global state is unaffected. If we actually want to affect the top-level, we can forego the with-environment wrapper:
(define lib1-exports (load "lib1.scm")) (define global-func (let ((func1 (cdr (assoc 'func1 lib1-exports)))) (lambda (a) (func1 a))))
To use namespaces from C, see the FFI example below.
We have atoms, lists, namespaces (alists), environments (lists of alists), procedures (source code and its environment), and threads (a procedure with a private stack). So it seems reasonable to define an object (in the "object-oriented" sense) as a cons of two alists, the object's private fields and its methods (in the class-inheritance case, we'd have an environment of methods). Then a generic function is:
(define-macro (define-generic f) `(define (,f obj . args) (apply (cdr (or (assoc ',f (cdr obj)) (error "can't find the ~A method for ~A" ',f obj))) obj args)))and all the rest of the object machinery is equally straightforward, at least conceptually. We can even conjure up objects without any explicit class:
(define hi (cons (list (cons 'a 1) (cons 'b 2)) ; its local data (list (cons 'splice (lambda (obj) "splicing"))))) ; its "splice" method (define-generic splice) (splice hi) "splicing"
|
eval evaluates its argument (a list representing a piece of code). It takes an optional second argument, the environment in which the evaluation should take place. eval-string is similar, but its argument is a string.
> (eval '(+ 1 2)) 3 > (eval-string "(+ 1 2)") 3
The environment argument is mainly useful in debugging. A breakpoint can be set, for example, then any input is evaluated in the environment of the break. Say we have the following code in ex.scm:
(define-macro (break) `(let ((break-env (current-environment)) (prompt (format #f "~%~A > " (if (defined? '__func__) __func__ "break")))) (call-with-exit (lambda (return) (do () () ; our debugger's own REPL (display prompt) ; show where we stopped (let ((str (read-line '()))) ; read a line of input, :go -> exit the debugger ;; the nil argument to read-line makes sure that we read C's stdin. In any normal ;; program, we'd get the string from a text widget. (if (> (length str) 0) (catch #t ; try to handle typing mistakes etc (lambda () (let ((val (eval-string str break-env))) (if (eq? val :go) (return)) (write val))) (lambda args (format #t "error: ~A" args)))))))))) ;; now some random code that has a breakpoint (define (a-function b) (let ((x 32)) (do ((i 0 (+ i 1))) ((= i 10)) (if (= i 3) (break))) x)) (a-function 123) (display "done!") (newline)Start up a REPL, and:
> (load "ex.scm") (a-function "ex.scm" 26) > x ; here we're in the debugger 32 (a-function "ex.scm" 26) > (+ b i) 126 (a-function "ex.scm" 26) > :go done!
|
*load-path* is a list of directories to search when loading a file. *load-hook* is a function called just before a file is loaded. Its argument is the filename. While loading, port-filename and port-line-number (of the current-input-port) can tell you where you are in the file.
(set! *load-hook* (lambda (name) (format #t "loading ~S...~%" name)))
Here's a *load-hook* function that adds the loaded file's directory to the *load-path* variable so that subsequent loads don't need to specify the directory:
(set! *load-hook* (lambda (filename) (let ((pos -1) (len (length filename))) (do ((i 0 (+ i 1))) ((= i len)) (if (char=? (filename i) #\/) (set! pos i))) (if (positive? pos) (let ((directory-name (substring filename 0 pos))) (if (not (member directory-name *load-path*)) (set! *load-path* (cons directory-name *load-path*))))))))
|
As in Common Lisp, *features* is a list describing what is currently loaded into s7. You can check it with the provided? function, or add something to it with provide. In my version of Snd, at startup *features* is:
> *features* (snd10 snd snd-s7 snd-motif gsl alsa xm snd-ladspa run clm4 clm sndlib gmp s7) > (provided? 'gmp) #t
|
Multi-line comments can be enclosed in either #| and |#, or #! and !# (the latter
is for compatibility with Guile). These are also useful for in-line comments:
(+ #| add |# 1 2)
.
Leaving aside these two cases, and the booleans, #f and #t, you can specify your own handlers for tokens that start with "#". *#readers* is a list of pairs: (char . func). "char" refers to the first character after the sharp sign (#). "func" is a function of one argument, the string that follows the #-sign up to the next delimiter. "func" is called when #<char> is encountered. If it returns something other than #f, the #-expression is replaced with that value. Scheme has several predefined #-readers for cases such as #b1, #\a, #i123, and so on, but you can override these if you like. If the string passed in is not the complete #-expression, the function can use read-char to get the rest. Say we'd like #t<number> to interpret the number in base 12:
(set! *#readers* (cons (cons #\t (lambda (str) (string->number (substring str 1) 12))) *#readers*)) > #tb 11 > #t11.3 13.25
I use *#readers* primarily to implement a way to get the current line number and file name, along the lines of C's __LINE__ and __FILE__. port-line-number works if we're reading a file (during load for example), and *error-info* has the same information if an error happens. But during Snd's auto-test sequence, there are many cases that aren't errors, and the file is no longer being loaded, but I need to know where something unexpected happened. So:
(set! *#readers* (cons (cons #\_ (lambda (str) (if (string=? str "__line__") (port-line-number) (if (string=? str "__file__") (port-filename) #f)))) *#readers*))
|
(make-list length (initial-element #f)) returns a list of 'length' elements defaulting to 'initial-element'.
reverse! is an in-place version of the built-in function reverse. That is, it modifies the list passed to it in the process of reversing its contents. list-set! sets a member of a list. sort! sorts a list or a vector using the function passed as its second argument to choose the new ordering.
> (sort! (list 3 4 8 2 0 1 5 9 7 6) <) (0 1 2 3 4 5 6 7 8 9) (define (mix-notelists . notelists) ;; assume the 2nd parameter is the begin time in seconds (the 1st is the instrument name) (sort! (apply append notelists) (lambda (note1 note2) (< (cadr note1) (cadr note2))))) (mix-notelists '((fm-violin 0 1 440 .1) (fm-violin 1 1 550 .1)) '((bird 0 .1 ) (bird .2 .1) (bird 1.2 .3) (bird .5 .5))) -> ((bird 0 0.1) (fm-violin 0 1 440 0.1) (bird 0.2 0.1) (bird 0.5 0.5) (fm-violin 1 1 550 0.1) (bird 1.2 0.3))
Despite the "!" in its name, sort! actually copies any list argument passed to it, but vectors are sorted in place.
|
Keywords exist mainly for define*'s benefit. The keyword functions are:
keyword?, make-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.
s7's keyword support is somewhat lackadaisical; I can't decide if it's worth complaining
about stuff like (let ((:hi 1)) :hi)
.
|
help tries to find information about its argument.
> (help 'caadar) "(caadar lst) returns (car (car (cdr (car lst)))): (caadar '((1 (2 3)))) -> 2"
If the initial expression in a function body is a string constant, it is assumed to be a documentation string (accessible via help or procedure-documentation):
(define (add1 a) "(add1 a) adds 1 to its argument" (+ a 1)) > (help add1) "(add1 a) adds 1 to its argument"
|
quit exits s7.
gc calls the garbage collector. (gc #f) turns off the GC, and (gc #t) turns it on. In the multithread case, don't call gc yourself except from the top-level.
|
Some other differences from r5rs:
(define progn begin) (progn (display "progn!") (+ 3 4))
or (define function lambda)
, etc
Schemes vary in their treatment of (). s7 considers it a constant that evaluates to itself, so you rarely (never?) need to quote it.
(eq? () '())
is #t.
Schemes also vary in handling trailing arguments:
(* 0 "hi")
in Guile returns 0, but s7 gives an error.(cond (1) (=>))
is 1 in both, and(or 1 2 . 3)
is an error in Guile, and 1 in s7! (Because it flushes trailing arguments, Guile returns 0 from(* 0 +inf.0)
, but it should return NaN).
And a harder one... How should s7 treat this:
(string-set! "hiho" 1 #\z)
, or(vector-set! #(1 2 3) 1 32)
, or(list-set! '(1 2 3) 1 32)
? Originally, in s7, the first two were errors, and the third was allowed, which doesn't make much sense. Guile (and Common Lisp) accept all three, but that leads to weird cases where we can reach into a function's body:> (let ((x (lambda () '(1 2 3)))) (list-set! (x) 1 32) (x)) (1 32 3) ; s7, Guile > (flet ((x () '(1 2 3))) (setf (nth 1 (x)) 32) (x)) (1 32 3) ; Clisp > (let ((x (lambda () (list 1 2 3)))) (list-set! (x) 1 32) (x)) (1 2 3)But it's possible to reach into a function's closure, even when the closed-over thing is a constant:
> (flet ((x () '(1 2 3))) (setf (nth 1 (x)) 32) (x)) (1 32 3) > (let ((xx (let ((x '(1 2 3))) (lambda () x)))) (list-set! (xx) 1 32) (xx)) (1 32 3) > (let ((xx (let ((x (list 1 2 3))) (lambda () x)))) (list-set! (xx) 1 32) (xx)) (1 32 3)And it's possible to reach into a constant list via list-set! (or set-car! of course):
> (let* ((x '(1 2)) (y (list x)) (z (car y))) (list-set! z 1 32) (list x y z)) ((1 32) ((1 32)) (1 32))It would be a programmer's nightmare to have to keep track of which piece of a list is constant, and an implementor's nightmare to copy every list. set! in all its forms is used for its side-effects, so why should we try to put a fence around them? If we flush "immutable constant" because it is a ham-fisted, whack-it-with-a-shovel approach, the only real problem I can see is symbol->string. In CL, this is explicitly an error:
> (setf (elt (symbol-name 'xyz) 1) #\X) *** - Attempt to modify a read-only string: "XYZ"And in Guile:
> (string-set! (symbol->string 'symbol->string) 1 #\X) ERROR: string is read-only: "symbol->string"So both have a notion of immutable strings. I wonder what other Scheme programmers (not implementors!) want in this situation. Currently, there are no immutable list, string, or vector constants, and symbol->string returns a copy of the string. One simple way to ensure immutability is to use copy:
> (let ((x (lambda () (copy "hiho")))) (string-set! (x) 1 #\x) (x)) "hiho"
Another minor difference: 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#)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*.
Length returns +inf.0 if passed a circular list, and returns a negative number if passed a dotted list (its absolute value is the list length not counting the final cdr).
(define (circular? lst) (infinite? (length lst)))
.
|
s7 is primarily aimed at computer music, CLM-based sound synthesis in particular. A CLM "instrument" is usually a do-loop running things like oscillators and envelopes for zillions of sound samples. These calculations do not involve recursion, or complex numbers, or fancy list processing, so it is not too hard to write an optimizer for them. In sndlib, that optimizer is called "run". It is a macro (in modern jargon, a JIT byte compiler) that can be wrapped around any piece of Scheme code that you want to speed up. If it can't optimize the code, it passes it to the s7 interpreter. If run is successful, you will normally get a speed up by a factor of 10 to 30. For CLM instruments, the result runs close to the speed of the equivalent compiled and optimized C code. Here are my timings for two instruments, "bird" and "fm-violin", each running for 100 seconds. I've included sbcl times for comparison.
s7 interpreted s7+run C (-O2) sbcl bird 9.6 .7 .65 .65 violin 21.6 1.44 1.28 1.28
The sbcl and C compiler cases are the same because CLM in sbcl uses a version of the run macro that translates the CL code to C, calls the C compiler on that, then loads it as a foreign function, so it is essentially the same as the straight C case. In s7, however, we're running interpreted; there is no separate compilation step. Another comparison: the fft benchmark from the Gabriel tests. In s7 interpreted, it runs 1000 1024 point FFTs in 53 seconds; with "run", the same takes 2 seconds. In Guile 1.9.5 after compilation, it takes 10 seconds. So, in general, s7 is not so slow as to be an annoyance.
|
I can't resist giving another example. Here's some vector arithmetic:
(let* ((size (* 128 1024)) (v1 (make-vector size 0.0)) (v2 (make-vector size 0.0)) (sum 0.0)) (run (do ((i 0 (+ i 1))) ((= i size)) (vector-set! v1 i (- (random 2.0) 1.0)) (vector-set! v2 i (- (random 2.0) 1.0))) (do ((i 0 (+ i 1))) ((= i size) sum) (set! sum (+ sum (* (vector-ref v1 i) (vector-ref v2 i)))))))With run, this takes .092 seconds on my old machine; without run, it takes 1.94 seconds.
|
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:
HAVE_STDBOOL_H 1 if you have stdbool.h HAVE_PTHREADS 1 if you want multithreading support (requires pthreads, default is 0) HAVE_NESTED_FUNCTIONS 1 if your compiler supports nested functions WITH_GMP 1 if you want multiprecision arithmetic (requires gmp, mpfr, and mpc, default is 0) WITH_COMPLEX 1 if your compiler supports complex numbers HAVE_COMPLEX_TRIG 1 if your math library has complex versions of the trig functions WITH_PROFILING 1 if you want profiling support (default is 0) WITH_FORCE 1 if you want force and delay (default is 0) WITH_MULTIPLE_VALUES 1 if you want multiple-values and its friends (default is 1) S7_DISABLE_DEPRECATED 1 if you want to make sure you're not using any deprecated s7 stuff (default is 0)
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" static s7_pointer our_exit(s7_scheme *sc, s7_pointer args) { /* all added functions have this form, args is a list, * s7_car(args) is the 1st arg, etc */ exit(1); return(s7_nil(sc)); /* never executed, but makes the compiler happier */ } int main(int argc, char **argv) { s7_scheme *s7; char buffer[512]; char response[1024]; s7 = s7_init(); /* initialize the interpreter */ s7_define_function(s7, "exit", our_exit, 0, 0, false, "(exit) exits the program"); /* add the function "exit" to the interpreter. * 0, 0, false -> no required args, * no optional args, * no "rest" arg */ while (1) /* fire up a REPL */ { fprintf(stdout, "\n> "); /* prompt for input */ fgets(buffer, 512, stdin); if ((buffer[0] != '\n') || (strlen(buffer) > 1)) { sprintf(response, "(write %s)", buffer); s7_eval_c_string(s7, response); /* evaluate input and write the result */ } } } /* make mus-config.h (it can be empty), then * * gcc -c s7.c -I. * gcc -o doc7 doc7.c s7.o -lm -I. * * run it: * * doc7 * > (+ 1 2) * 3 * > (define (add1 x) (+ 1 x)) * add1 * > (add1 2) * 3 * > (exit) */ |
Define a function with arguments and a returned value, and a variable:
#include <stdlib.h> #include <stdio.h> #include <string.h> #include "s7.h" static s7_pointer our_exit(s7_scheme *sc, s7_pointer args) { exit(1); return(s7_nil(sc)); } 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")); } int main(int argc, char **argv) { s7_scheme *s7; char buffer[512]; char response[1024]; s7 = s7_init(); /* initialize the interpreter */ s7_define_function(s7, "exit", our_exit, 0, 0, false, "(exit) exits the program"); s7_define_function(s7, "add1", add1, 1, 0, false, "(add1 int) adds 1 to int"); s7_define_variable(s7, "my-pi", s7_make_real(s7, 3.14159265)); while (1) /* fire up a "repl" */ { fprintf(stdout, "\n> "); /* prompt for input */ fgets(buffer, 512, stdin); if ((buffer[0] != '\n') || (strlen(buffer) > 1)) { sprintf(response, "(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) */ |
Call a scheme-defined function from C, and get/set scheme variable values in C:
#include <stdlib.h> #include <stdio.h> #include <string.h> #include "s7.h" int main(int argc, char **argv) { s7_scheme *s7; 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: %d\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: %d\n", s7_integer(s7_name_to_value(s7, "an-integer"))); fprintf(stderr, "(add1 2): %d\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 */ |
C++ and Juce, from Rick Taube:
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; } s7_pointer val; std::string str; while (true) { 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; } |
Load sndlib using the XEN functions and macros into an s7 repl:
#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 */ #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 */ s7_make_symbol(s7, "mus-error"), s7_cons(s7, s7_make_string(s7, msg), s7_nil(s7))); } static s7_pointer our_exit(s7_scheme *sc, s7_pointer args) { exit(1); return(s7_nil(sc)); } /* the next functions are needed for either with-sound or many standard instruments, like fm-violin */ /* (these are in the xen-style FFI) */ static XEN g_file_exists_p(XEN name) { #define H_file_exists_p "(file-exists? filename): #t if the file exists" XEN_ASSERT_TYPE(XEN_STRING_P(name), name, XEN_ONLY_ARG, "file-exists?", "a string"); return(C_TO_XEN_BOOLEAN(mus_file_probe(XEN_TO_C_STRING(name)))); } XEN_NARGIFY_1(g_file_exists_p_w, g_file_exists_p) static XEN g_delete_file(XEN name) { #define H_delete_file "(delete-file filename): deletes the file" XEN_ASSERT_TYPE(XEN_STRING_P(name), name, XEN_ONLY_ARG, "delete-file", "a string"); return(C_TO_XEN_BOOLEAN(unlink(XEN_TO_C_STRING(name)))); } XEN_NARGIFY_1(g_delete_file_w, g_delete_file) int main(int argc, char **argv) { char buffer[512]; char response[1024]; s7 = s7_init(); /* initialize the interpreter */ xen_initialize(); /* 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 */ XEN_DEFINE_PROCEDURE("file-exists?", g_file_exists_p_w, 1, 0, 0, H_file_exists_p); XEN_DEFINE_PROCEDURE("delete-file", g_delete_file_w, 1, 0, 0, H_delete_file); s7_define_function(s7, "exit", our_exit, 0, 0, false, "(exit) exits the program"); while (1) /* fire up a "repl" */ { fprintf(stdout, "\n> "); /* prompt for input */ fgets(buffer, 512, stdin); if ((buffer[0] != '\n') || (strlen(buffer) > 1)) { sprintf(response, "(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 * * (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 */ |
Add a new scheme type and procedure-with-setters:
#include <stdlib.h> #include <stdio.h> #include <string.h> #include "s7.h" static s7_pointer our_exit(s7_scheme *sc, s7_pointer args) { exit(1); return(s7_nil(sc)); } /* 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 char *print_dax(s7_scheme *sc, void *val) { char *data_str, *str; int data_str_len; dax *o = (dax *)val; data_str = s7_object_to_c_string(sc, o->data); data_str_len = strlen(data_str); 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); return(str); } static void free_dax(void *val) { if (val) free(val); } static bool equal_dax(void *val1, void *val2) { return(val1 == val2); } static void mark_dax(void *val) { dax *o = (dax *)val; if (o) s7_mark_object(o->data); } static int dax_type_tag = 0; static s7_pointer make_dax(s7_scheme *sc, s7_pointer args) { dax *o; o = (dax *)malloc(sizeof(dax)); o->x = s7_real(s7_car(args)); if (s7_cdr(args) != s7_nil(sc)) o->data = s7_car(s7_cdr(args)); else o->data = s7_nil(sc); return(s7_make_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_object(s7_car(args)) && s7_object_type(s7_car(args)) == dax_type_tag)); } static s7_pointer dax_x(s7_scheme *sc, s7_pointer args) { dax *o; o = (dax *)s7_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; o = (dax *)s7_object_value(s7_car(args)); o->x = s7_real(s7_car(s7_cdr(args))); return(s7_car(s7_cdr(args))); } static s7_pointer dax_data(s7_scheme *sc, s7_pointer args) { dax *o; o = (dax *)s7_object_value(s7_car(args)); return(o->data); } static s7_pointer set_dax_data(s7_scheme *sc, s7_pointer args) { dax *o; o = (dax *)s7_object_value(s7_car(args)); o->data = s7_car(s7_cdr(args)); return(o->data); } int main(int argc, char **argv) { s7_scheme *s7; char buffer[512]; char response[1024]; s7 = s7_init(); s7_define_function(s7, "exit", our_exit, 0, 0, false, "(exit) exits the program"); s7_define_variable(s7, "*listener-prompt*", s7_make_string(s7, ">")); dax_type_tag = s7_new_type("dax", print_dax, free_dax, equal_dax, mark_dax, NULL, NULL); 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_make_procedure_with_setter(s7, "dax-x", dax_x, 1, 0, set_dax_x, 2, 0, "dax x field")); s7_define_variable(s7, "dax-data", s7_make_procedure_with_setter(s7, "dax-data", dax_data, 1, 0, set_dax_data, 2, 0, "dax data field")); while (1) { fprintf(stdout, "\n%s ", listener_prompt(s7)); fgets(buffer, 512, stdin); if ((buffer[0] != '\n') || (strlen(buffer) > 1)) { sprintf(response, "(write %s)", buffer); s7_eval_c_string(s7, response); /* evaluate input and write the result */ } } } /* * > *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) */ |
Redirect output (and input) to a C procedure:
#include <stdlib.h> #include <stdio.h> #include <string.h> #include "s7.h" static void my_print(s7_scheme *sc, char 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(s7, fgetc(stdin))); } int main(int argc, char **argv) { s7_scheme *s7; char buffer[512]; char response[1024]; 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) { fprintf(stdout, "\n> "); fgets(buffer, 512, stdin); if ((buffer[0] != '\n') || (strlen(buffer) > 1)) { sprintf(response, "(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] */ |
Extend a built-in operator ("+" in this case):
#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; char buffer[512]; char response[1024]; 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) { fprintf(stdout, "\n> "); fgets(buffer, 512, stdin); if ((buffer[0] != '\n') || (strlen(buffer) > 1)) { sprintf(response, "(write %s)", buffer); s7_eval_c_string(s7, response); } } } /* * > (+ 1 2) * 3 * > (+ "hi" "ho") * "hiho" */ |
C-side define* (s7_define_function_star):
#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_car(s7_cdr(args))))); } int main(int argc, char **argv) { s7_scheme *s7; char buffer[512]; char response[1024]; s7 = s7_init(); s7_define_function_star(s7, "plus", plus, "(red 32) blue", "an example of define* from C"); while (1) { fprintf(stdout, "\n> "); fgets(buffer, 512, stdin); if ((buffer[0] != '\n') || (strlen(buffer) > 1)) { sprintf(response, "(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 */ |
C-side define-macro (s7_define_macro):
#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, b; a = s7_car(args); b = s7_car(s7_cdr(args)); return(s7_cons(sc, s7_make_symbol(sc, "+"), /* we are forming the list `(+ ,a ,b) */ s7_cons(sc, a, s7_cons(sc, b, s7_nil(sc))))); } int main(int argc, char **argv) { s7_scheme *s7; char buffer[512]; char response[1024]; s7 = s7_init(); s7_define_macro(s7, "plus", plus, 2, 0, false, "plus adds its two arguments"); while (1) { fprintf(stdout, "\n> "); fgets(buffer, 512, stdin); if ((buffer[0] != '\n') || (strlen(buffer) > 1)) { sprintf(response, "(write %s)", buffer); s7_eval_c_string(s7, response); } } } /* * > (plus 2 3) * 5 */ |
Signal handling (C-C to break out of an infinite loop), and s7_make_continuation to pick up where we were interrupted:
#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_exit(s7_scheme *sc, s7_pointer args) { /* this function is really needed if we are trapping C-C! */ exit(1); return(s7_f(sc)); } static s7_pointer our_sleep(s7_scheme *sc, s7_pointer args) { /* slow down out infinite loop for demo purposes */ sleep(1); return(s7_f(sc)); } int main(int argc, char **argv) { char buffer[512]; char response[1024]; s7 = s7_init(); s7_define_function(s7, "exit", our_exit, 0, 0, false, "(exit) exits"); 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) { fprintf(stderr, "\n> "); fgets(buffer, 512, stdin); if ((buffer[0] != '\n') || (strlen(buffer) > 1)) { sprintf(response, "(write %s)", buffer); s7_eval_c_string(s7, response); } } } /* * > (do ((i 0 (+ i 1))) ((= i -1)) (format #t "~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 */ |
Multidimensional vector element access:
#include <stdlib.h> #include <stdio.h> #include <string.h> #include <stdarg.h> #include "s7.h" static s7_pointer multivector_ref(s7_scheme *sc, s7_pointer vector, int indices, ...) { /* multivector_ref returns an element of a multidimensional vector */ int ndims; ndims = s7_vector_rank(vector); if (ndims == indices) { va_list ap; s7_Int index = 0; va_start(ap, indices); if (ndims == 1) { index = va_arg(ap, s7_Int); va_end(ap); return(s7_vector_ref(sc, vector, index)); } else { int i; s7_pointer *elements; s7_Int *offsets, *dimensions; elements = s7_vector_elements(vector); dimensions = s7_vector_dimensions(vector); offsets = s7_vector_offsets(vector); for (i = 0; i < indices; i++) { int ind; ind = va_arg(ap, int); if ((ind < 0) || (ind >= dimensions[i])) { va_end(ap); return(s7_out_of_range_error(sc, "multivector_ref", i, s7_make_integer(sc, ind), "index should be between 0 and the dimension size")); } index += (ind * offsets[i]); } va_end(ap); return(elements[index]); } } return(s7_wrong_number_of_args_error(sc, "multivector_ref: wrong number of indices: ~A", s7_make_integer(sc, indices))); } int main(int argc, char **argv) { char buffer[512]; char response[1024]; s7_scheme *s7; s7 = s7_init(); s7_eval_c_string(s7, "(define vect (make-vector '(2 3 4) 0))"); s7_eval_c_string(s7, "(set! (vect 1 1 1) 32)"); fprintf(stdout, "vect[0,0,0]: %s, vect[1,1,1]: %s\n", s7_object_to_c_string(s7, multivector_ref(s7, s7_name_to_value(s7, "vect"), 3, 0, 0, 0)), s7_object_to_c_string(s7, multivector_ref(s7, s7_name_to_value(s7, "vect"), 3, 1, 1, 1))); } /* vect[0,0,0]: 0, vect[1,1,1]: 32 */ |
Notification from Scheme that a given scheme variable has been set.
#include <stdlib.h> #include <stdio.h> #include <string.h> #include "s7.h" static s7_pointer my_exit(s7_scheme *sc, s7_pointer args) {exit(0);} 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_car(s7_cdr(args)))); return(s7_car(s7_cdr(args))); } int main(int argc, char **argv) { s7_scheme *s7; s7 = s7_init(); s7_define_function(s7, "exit", my_exit, 0, 0, false, "(exit) exits the program"); 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_symbol_set_access(s7, /* set symbol-access of notified-var to (list #f notify-C #f) */ s7_make_symbol(s7, "notified-var"), s7_cons(s7, s7_f(s7), s7_cons(s7, s7_name_to_value(s7, "notify-C"), s7_cons(s7, s7_f(s7), s7_nil(s7))))); if (argc == 2) { fprintf(stderr, "load %s\n", argv[1]); s7_load(s7, argv[1]); } else { char buffer[512]; char response[1024]; while (1) { fprintf(stdout, "\n> "); fgets(buffer, 512, stdin); if ((buffer[0] != '\n') || (strlen(buffer) > 1)) { sprintf(response, "(write %s)", buffer); s7_eval_c_string(s7, response); } } } } /* > notified-var * 0 * > (set! notified-var 32) * notified-var set to 32 * 32 */ |
Load C defined stuff into a separate namespace.
#include <stdlib.h> #include <stdio.h> #include <string.h> #include "s7.h" static s7_pointer my_exit(s7_scheme *sc, s7_pointer args) {exit(0);} 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_pointer new_env; s7 = s7_init(); s7_define_function(s7, "exit", my_exit, 0, 0, false, "(exit) exits the program"); /* "func1" and "var1" will be placed in an anonymous environment, * accessible from Scheme via the global variable "lib-exports" */ new_env = s7_augment_environment(s7, s7_cons(s7, s7_current_environment(s7), s7_nil(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_car(new_env)); if (argc == 2) { fprintf(stderr, "load %s\n", argv[1]); s7_load(s7, argv[1]); } else { char buffer[512]; char response[1024]; while (1) { fprintf(stdout, "\n> "); fgets(buffer, 512, stdin); if ((buffer[0] != '\n') || (strlen(buffer) > 1)) { sprintf(response, "(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 augment-environment (current-environment) lib-exports)) * lib-env * > (with-environment lib-env (func1 var1)) * 33 * * ;; or rename them to prepend "lib:" * > (define lib-env (apply augment-environment (current-environment) (map (lambda (binding) (cons (string->symbol (string-append "lib:" (symbol->string (car binding)))) (cdr binding))) lib-exports))) * lib-env * > (with-environment 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 */ |
Handle scheme errors in C.
#include <stdlib.h> #include <stdio.h> #include <string.h> #include "s7.h" static s7_pointer my_exit(s7_scheme *sc, s7_pointer args) {exit(0);} static s7_pointer error_handler(s7_scheme *sc, s7_pointer args) { /* put <<>> around the string so it's obvious who is producing what */ fprintf(stdout, "<<%s>>", s7_string(s7_car(args))); return(s7_make_symbol(sc, "our-error")); } int main(int argc, char **argv) { s7_scheme *s7; char buffer[512]; char response[1024]; bool with_error_hook = false; s7 = s7_init(); s7_define_function(s7, "exit", my_exit, 0, 0, false, "(exit) exits the program"); s7_define_function(s7, "error-handler", error_handler, 1, 0, false, "our error handler"); if (with_error_hook) s7_eval_c_string(s7, "(set! *error-hook* \n\ (lambda (tag args) \n\ (error-handler \n\ (apply format #f (car args) (cdr args)))))"); while (1) { fprintf(stdout, "\n> "); fgets(buffer, 512, stdin); if ((buffer[0] != '\n') || (strlen(buffer) > 1)) { s7_pointer old_port, result; int gc_loc = -1; const char *errmsg = NULL; /* trap error messages */ 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. * * 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) * <<+ 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). */ |