Commit d38474bc authored by IOhannes zmölnig's avatar IOhannes zmölnig

New upstream version 19.3

parent f9fab338
Snd change log
15-Apr: Snd 19.3.
11-Mar: Snd 19.2.
7-Feb: Snd 19.1.
2-Jan-19: Snd 19.0.
......
Snd 19.2:
Snd 19.3:
in s7, added (*s7* 'undefined-constant-warnings) to flag typos like #ff or #_input_port?
added coverlets and openlets (an experiment)
clm: Anders added support for 64-bit lispworks.
checked: sbcl 1.5.0
s7: port-position and port-file (for libc.scm).
deleted Display and sequence->string (stuff.scm)
Thanks!: Kjetil
checked: sbcl 1.5.1
Thanks!: Daniel Hensel, Anders Vinjar.
\ No newline at end of file
......@@ -11541,6 +11541,8 @@ static mus_float_t mus_src_two(mus_any *p, mus_float_t x) {return(mus_src(p, x,
static mus_float_t mus_convolve_simple(mus_any *p) {return(mus_convolve(p, NULL));}
/* static mus_float_t mus_phase_vocoder_simple(mus_any *p) {return(mus_phase_vocoder(p, NULL));} */
/* almost no error checking here; for example all the s7_c_object_value calls should check that their argument is a c-object */
#define GEN_1(Type, Func) \
static bool is_ ## Type ## _b(s7_pointer p) \
{ \
......
......@@ -103,11 +103,13 @@
;;; (* 1024 mem)))))
;;; --------------------------------------------------------------------------------
(define *cload-cflags* "")
(define *cload-cflags* (if (provided? 'clang) "-fPIC" ""))
(define *cload-ldflags* "")
(if (not (defined? '*cload-directory*))
(define *cload-directory* ""))
(define *cload-c-compiler* (if (provided? 'gcc) "gcc" (if (provided? 'clang) "clang" "cc")))
(define-macro (defvar name value)
`(if (not (defined? ',name))
......@@ -580,10 +582,10 @@
(cond ((provided? 'osx)
;; I assume the caller is also compiled with these flags?
(system (format #f "gcc -c ~A -o ~A ~A ~A"
c-file-name o-file-name *cload-cflags* cflags))
(system (format #f "gcc ~A -o ~A -dynamic -bundle -undefined suppress -flat_namespace ~A ~A"
o-file-name so-file-name *cload-ldflags* ldflags)))
(system (format #f "~A -c ~A -o ~A ~A ~A"
*cload-c-compiler* c-file-name o-file-name *cload-cflags* cflags))
(system (format #f "~A ~A -o ~A -dynamic -bundle -undefined suppress -flat_namespace ~A ~A"
*cload-c-compiler* o-file-name so-file-name *cload-ldflags* ldflags)))
((provided? 'freebsd)
(system (format #f "cc -fPIC -c ~A -o ~A ~A ~A"
......@@ -592,10 +594,10 @@
o-file-name so-file-name *cload-ldflags* ldflags)))
((provided? 'openbsd)
(system (format #f "gcc -fPIC -ftrampolines -c ~A -o ~A ~A ~A"
c-file-name o-file-name *cload-cflags* cflags))
(system (format #f "gcc ~A -shared -o ~A ~A ~A"
o-file-name so-file-name *cload-ldflags* ldflags)))
(system (format #f "~A -fPIC -ftrampolines -c ~A -o ~A ~A ~A"
*cload-c-compiler* c-file-name o-file-name *cload-cflags* cflags))
(system (format #f "~A ~A -shared -o ~A ~A ~A"
*cload-c-compiler* o-file-name so-file-name *cload-ldflags* ldflags)))
((provided? 'sunpro_c) ; just guessing here...
(system (format #f "cc -c ~A -o ~A ~A ~A"
......@@ -603,13 +605,11 @@
(system (format #f "cc ~A -G -o ~A ~A ~A"
o-file-name so-file-name *cload-ldflags* ldflags)))
;; what about clang? Maybe use cc below, not gcc (and in osx case above)
(else
(system (format #f "gcc -fPIC -c ~A -o ~A ~A ~A"
c-file-name o-file-name *cload-cflags* cflags))
(system (format #f "gcc ~A -shared -o ~A ~A ~A"
o-file-name so-file-name *cload-ldflags* ldflags)))))
(system (format #f "~A -fPIC -c ~A -o ~A ~A ~A"
*cload-c-compiler* c-file-name o-file-name *cload-cflags* cflags))
(system (format #f "~A ~A -shared -o ~A ~A ~A"
*cload-c-compiler* o-file-name so-file-name *cload-ldflags* ldflags)))))
(define handle-declaration
(let ()
......
#! /bin/sh
# Guess values for system-dependent variables and create Makefiles.
# Generated by GNU Autoconf 2.69 for snd 19.2.
# Generated by GNU Autoconf 2.69 for snd 19.3.
#
# Report bugs to <bil@ccrma.stanford.edu>.
#
......@@ -580,8 +580,8 @@ MAKEFLAGS=
# Identity of this package.
PACKAGE_NAME='snd'
PACKAGE_TARNAME='ftp://ccrma-ftp.stanford.edu/pub/Lisp/snd-19.tar.gz'
PACKAGE_VERSION='19.2'
PACKAGE_STRING='snd 19.2'
PACKAGE_VERSION='19.3'
PACKAGE_STRING='snd 19.3'
PACKAGE_BUGREPORT='bil@ccrma.stanford.edu'
PACKAGE_URL=''
......@@ -1324,7 +1324,7 @@ if test "$ac_init_help" = "long"; then
# Omit some internal or obsolete options to make the list less imposing.
# This message is too long to be a string in the A/UX 3.1 sh.
cat <<_ACEOF
\`configure' configures snd 19.2 to adapt to many kinds of systems.
\`configure' configures snd 19.3 to adapt to many kinds of systems.
Usage: $0 [OPTION]... [VAR=VALUE]...
......@@ -1395,7 +1395,7 @@ fi
if test -n "$ac_init_help"; then
case $ac_init_help in
short | recursive ) echo "Configuration of snd 19.2:";;
short | recursive ) echo "Configuration of snd 19.3:";;
esac
cat <<\_ACEOF
......@@ -1514,7 +1514,7 @@ fi
test -n "$ac_init_help" && exit $ac_status
if $ac_init_version; then
cat <<\_ACEOF
snd configure 19.2
snd configure 19.3
generated by GNU Autoconf 2.69
Copyright (C) 2012 Free Software Foundation, Inc.
......@@ -1975,7 +1975,7 @@ cat >config.log <<_ACEOF
This file contains any messages produced by compilers while
running configure, to aid debugging if configure makes a mistake.
It was created by snd $as_me 19.2, which was
It was created by snd $as_me 19.3, which was
generated by GNU Autoconf 2.69. Invocation command line was
$ $0 $@
......@@ -3322,7 +3322,7 @@ LOCAL_LANGUAGE="None"
GRAPHICS_TOOLKIT="None"
PACKAGE=Snd
VERSION=19.2
VERSION=19.3
#--------------------------------------------------------------------------------
# configuration options
......@@ -6906,7 +6906,7 @@ cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1
# report actual input values of CONFIG_FILES etc. instead of their
# values after options handling.
ac_log="
This file was extended by snd $as_me 19.2, which was
This file was extended by snd $as_me 19.3, which was
generated by GNU Autoconf 2.69. Invocation command line was
CONFIG_FILES = $CONFIG_FILES
......@@ -6968,7 +6968,7 @@ _ACEOF
cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1
ac_cs_config="`$as_echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`"
ac_cs_version="\\
snd config.status 19.2
snd config.status 19.3
configured by $0, generated by GNU Autoconf 2.69,
with options \\"\$ac_cs_config\\"
......
......@@ -5,7 +5,7 @@
# gmp, mpfr, and mpc deliberately have none!
AC_INIT(snd, 19.2, bil@ccrma.stanford.edu, ftp://ccrma-ftp.stanford.edu/pub/Lisp/snd-19.tar.gz)
AC_INIT(snd, 19.3, bil@ccrma.stanford.edu, ftp://ccrma-ftp.stanford.edu/pub/Lisp/snd-19.tar.gz)
AC_CONFIG_SRCDIR(snd.c)
AC_CANONICAL_HOST # needed by case $host below
......@@ -24,7 +24,7 @@ LOCAL_LANGUAGE="None"
GRAPHICS_TOOLKIT="None"
PACKAGE=Snd
VERSION=19.2
VERSION=19.3
#--------------------------------------------------------------------------------
# configuration options
......
......@@ -663,7 +663,7 @@ the 15 main components, with their sum in black:
(let* ((angle 0.0)
(incr (hz->radians 1.0))
(n (ceiling (+ index 5)))
(cur-phases (make-vct (* (+ n 1) 3 2))))
(cur-phases (make-float-vector (* (+ n 1) 3 2))))
(do ((i 0 (+ i 1))
(j 0 (+ j 3)))
......@@ -1319,7 +1319,7 @@ examples which come from a collection of "imaginary machines":
:duration dur :scaler (hz-&gt;radians (abs gliss)))))
(do ((i start (+ i 1)))
((= i stop))
(set! (fmssb-index gen) (env indf))
(set! (gen 'index) (env indf))
(outa i (* (env ampf) (fmssb gen (env frqf)))))))
(with-sound (:play #t)
......@@ -1546,7 +1546,7 @@ In general:
(cr (make-oscil freq carrier-phase))
(n (length mc-ratios))
(modulators (make-vector n))
(fm-indices (make-vct n)))
(fm-indices (make-float-vector n)))
(do ((i 0 (+ i 1)))
((= i n))
(set! (modulators i) (make-oscil (* freq (mc-ratios i)) (mod-phases i)))
......@@ -2496,10 +2496,10 @@ used in "Colony" and other pieces:
(car-os (make-oscil 0))
(evens (make-vector 3))
(odds (make-vector 3))
(amps (apply vct formant-amps))
(amps (apply float-vector formant-amps))
(ampf (make-env '(0 0 25 1 75 1 100 0) :scaler amp :duration dur))
(frmfs (make-vector 3))
(indices (apply vct indexes))
(indices (apply float-vector indexes))
(per-vib (make-triangle-wave 6 :amplitude (* freq .03)))
(ran-vib (make-rand-interp 20 :amplitude (* freq .5 .02))))
(do ((i 0 (+ i 1)))
......
This source diff could not be displayed because it is too large. You can view the blob instead.
......@@ -18,6 +18,7 @@
(define *report-any-!-as-setter* #t) ; unknown funcs/macros ending in ! are treated as setters
(define *report-doc-strings* #f) ; old-style (CL) doc strings (definstrument ignores this switch -- see ws.scm)
(define *report-func-as-arg-arity-mismatch* #f) ; as it says...
(define *report-combinable-lets* #t) ; report lets that can be combined
(define *report-ridiculous-variable-names* 50) ; max length of var name
(define *report-bad-variable-names* '(l ll .. O ~ else)) ; bad names -- a list to check such as:
......@@ -417,13 +418,13 @@
(denote (lint-format str caller . args)
(let ((outstr (apply format #f
(string-append (if line-number
(string-append (if (and line-number (> line-number 0))
"~NC~A (line ~D): "
"~NC~A: ")
str "~%")
lint-left-margin #\space
(truncated-list->string caller)
(if line-number
(if (and line-number (> line-number 0))
(values line-number args)
args))))
(set! made-suggestion (+ made-suggestion 1))
......@@ -434,6 +435,7 @@
(denote (local-line-number tree)
(let ((tree-line (and (pair? tree) (pair-line-number tree))))
(if (and (integer? tree-line)
(> tree-line 0)
(not (= tree-line line-number)))
(format #f " (line ~D)" tree-line)
"")))
......@@ -2478,7 +2480,7 @@
(format outport "~NCin ~A~A,~%~NCperhaps change ~S to ~S~A~%"
lint-left-margin #\space
(truncated-list->string form)
(if ln (format #f " (line ~D)" ln) "")
(if (and ln (> ln 0)) (format #f " (line ~D)" ln) "")
(+ lint-left-margin 4) #\space
old-arg new-arg comment))))))))
......@@ -2665,7 +2667,7 @@
(format outport "~NCin ~A~A,~%~NCperhaps change ~S to ~S~A~%"
lint-left-margin #\space
(truncated-list->string form)
(if ln (format #f " (line ~D)" ln) "")
(if (and ln (> ln 0)) (format #f " (line ~D)" ln) "")
(+ lint-left-margin 4) #\space
old-arg new-arg comment)))))))
......@@ -2704,7 +2706,7 @@
(format outport "~NCin ~A~A,~%~NCperhaps change ~A to ~A~%"
lint-left-margin #\space
(truncated-list->string form)
(if ln (format #f " (line ~D)" ln) "")
(if (and ln (> ln 0)) (format #f " (line ~D)" ln) "")
(+ lint-left-margin 4) #\space
(truncated-list->string a2)
(list new-e '...)))))))))
......@@ -3666,7 +3668,7 @@
(format outport "~NCin ~A~A,~%~NCperhaps change ~S to ~S~%"
lint-left-margin #\space
(truncated-list->string form)
(if ln (format #f " (line ~D)" ln) "")
(if (and ln (> ln 0)) (format #f " (line ~D)" ln) "")
(+ lint-left-margin 4) #\space
(list 'and '... val '... p)
nval)
......@@ -4327,7 +4329,7 @@
(format outport "~NCin ~A~A, ~A is ~A, but ~A wants ~A"
lint-left-margin #\space
(truncated-list->string form)
(if ln (format #f " (line ~D)" ln) "")
(if (and ln (> ln 0)) (format #f " (line ~D)" ln) "")
(cadr arg1)
(prettify-checker-unq (car arg1))
(car arg2)
......@@ -5844,7 +5846,7 @@
(hash-table-set! h 'min nummax))
h)) ; define numerics-table
(lambda (form env)
(lambda (form env) ; simplify-numerics??
(define (simplify-arg x)
(if (or (null? x) ; constants and the like look dumb if simplified
(not (proper-list? x))
......@@ -10135,7 +10137,7 @@
(hash-table-set! h f #t))
'(print-length safety cpu-time heap-size max-heap-size free-heap-size gc-freed max-string-length max-list-length
max-vector-length max-vector-dimensions default-hash-table-length initial-string-port-length memory-usage
gc-protected-objects file-names rootlet-size c-types stack-top stack-size stacktrace-defaults
gc-protected-objects file-names rootlet-size c-types stack-top stack-size stacktrace-defaults history-enabled
max-stack-size stack catches float-format-precision bignum-precision default-rationalize-error
default-random-state equivalent-float-epsilon hash-table-float-epsilon undefined-identifier-warnings
undefined-constant-warnings gc-stats history-size history profile-info autoloading? max-format-length))
......@@ -12147,7 +12149,7 @@
((null? (cdr clause))) ; ignore the initial value which depends on a different env
(let ((call (car clause)))
(if (pair? call)
(set! line-number (or (pair-line-number call) line-number)))
(set! line-number (or (pair-line-number call) (if (> line-number 0) line-number 0))))
(when (pair? call)
(let ((func (car call))
......@@ -14137,7 +14139,7 @@
(pair-line-number (var-initial-value v)))))
(lint-format "~A in ~A is already a constant, defined ~A~A" caller sym
(truncated-list->string form)
(if line (format #f "(line ~D): " line) "")
(if (and line (> line 0)) (format #f "(line ~D): " line) "")
(truncated-list->string (var-initial-value v)))))))
((memq sym '(else =>)) ; also in r7rs ... and _, but that is for syntax-rules
......@@ -14924,7 +14926,7 @@
(pair-line-number (var-initial-value v)))))
(lint-format "can't set! ~A in ~A (it is a constant: ~A~A)" caller settee
(truncated-list->string form)
(if line (format #f "(line ~D): " line) "")
(if (and line (> line 0)) (format #f "(line ~D): " line) "")
(truncated-list->string (var-initial-value v))))))
((and (not lint-in-with-let)
......@@ -18870,10 +18872,10 @@
(lint-format "perhaps ~A" caller
(lists->string form (list 'do new-cadr '...)))))))
;; let->do -- sometimes a bad idea, set *max-cdr-len* to #f to disable this.
;; let->do -- sometimes a bad idea, set *report-combinable-lets* to #f to disable this.
;; (the main objection is that the s7/clm optimizer can't handle it, and
;; instruments using it look kinda dumb -- the power of habit or something)
(when (and (integer? *max-cdr-len*)
(when (and *report-combinable-lets*
(not (len>1? (cdr body)))
;; moving more than one expr here is usually ugly -- the only exception I've
;; seen is where the do body is enormous and the end stuff very short, and
......@@ -19929,7 +19931,8 @@
(set! env (cdr es)))
(when (pair? vars)
(unless named-let
(unless (or named-let
(not *report-combinable-lets*))
(evert-function-locals form vars env))
(when (and (pair? (cadr form))
(pair? (caadr form)))
......@@ -19962,7 +19965,7 @@
(let ((body (cddr form))
(varlist (cadr form)))
;; let*->do (could go further down)
(when (and (integer? *max-cdr-len*)
(when (and *report-combinable-lets*
(pair? body)
(pair? (car body))
(eq? (caar body) 'do)
......@@ -21269,7 +21272,8 @@
((not (var-member vname env))
(lint-format "~A is the same as ~A" caller
func-name
(if (pair-line-number (var-initial-value v))
(if (and (pair-line-number (var-initial-value v))
(> (pair-line-number (var-initial-value v)) 0))
(format #f "~A (line ~D)" vname (pair-line-number (var-initial-value v)))
(if (eq? func-name vname)
(format #f "previous ~A" vname)
......@@ -22209,7 +22213,7 @@
;; -------- lint-walk-pair --------
(lambda (caller form env)
(let ((head (car form)))
(set! line-number (or (pair-line-number form) line-number))
(set! line-number (or (pair-line-number form) (if (> line-number 0) line-number 0)))
(if *report-repeated-code-fragments*
(lint-fragment form env))
......@@ -22460,7 +22464,8 @@
(hash-table-ref built-in-functions f))
(format outport "~NCtop-level ~Aredefinition of built-in function ~A: ~A~%"
lint-left-margin #\space
(if (pair-line-number form)
(if (and (pair-line-number form)
(> (pair-line-number form) 0))
(format #f "(line ~D) " (pair-line-number form))
"")
f (truncated-list->string form)))))
......
This diff is collapsed.
This diff is collapsed.
(provide 'profile.scm)
(define* (show-profile (n 100))
(let ((info (*s7* 'profile-info)))
(if (null? info)
......
......@@ -47,9 +47,8 @@
(define bytevector byte-vector)
(define bytevector? byte-vector?)
(define make-bytevector make-byte-vector)
(define bytevector-ref string-ref)
(define bytevector-set! string-set!)
(define bytevector-ref byte-vector-ref)
(define bytevector-set! byte-vector-set!)
(define bytevector-copy! vector-copy!)
(define string-copy! vector-copy!)
(define (bytevector->list bv) (map values bv))
......@@ -102,9 +101,9 @@
(define (bytevector-u8-set! b k c) (set! (b k) c))
(define bytevector-u8 (dilambda (lambda (b k) (b k)) (lambda (b k c) (set! (b k) c))))
(define bytevector-length length)
(define (bytevector-copy . args) (string->byte-vector (apply r7rs-string-copy args)))
(define (bytevector-append . args) (string->byte-vector (apply string-append args)))
(define write-bytevector write-string)
(define bytevector-copy vector-copy!)
(define bytevector-append append)
(define write-bytevector write)
(define* (read-bytevector! bv port (start 0) end)
(let ((lim (or end (length bv)))
(pt (or port (current-input-port))))
......@@ -115,7 +114,7 @@
bv)
(set! (bv i) c))))
(define* (read-bytevector k port)
(read-bytevector! (string->byte-vector (make-string k)) port))
(read-bytevector! (make-byte-vector k) port))
(define (get-output-bytevector port) (string->byte-vector (get-output-string port)))
(define open-input-bytevector open-input-string)
(define open-output-bytevector open-output-string)
......
......@@ -51,7 +51,6 @@
(define slot-expr-env c-pointer-weak2)
(define (slot symbol expr env expr-env) (c-pointer 0 symbol expr env expr-env))
(define (symbol->let symbol env)
;; return let in which symbol lives (not necessarily curlet)
(if (not (let? env))
......@@ -60,17 +59,13 @@
env
(symbol->let symbol (outlet env)))))
(define (setter-update cp) ; cp: (slot var expr env expr-env)
;; when var set, all other vars dependent on it need to be set also, watching out for GC'd followers
(let ((var (slot-symbol cp))
(env (slot-env cp))
(expr (slot-expr cp)))
(when (and (let? (slot-env cp)) ; when slot-env is GC'd, the c-pointer field is set to #f (by the GC)
(let? (slot-expr-env cp)))
(let ((new-val (eval expr (slot-expr-env cp))))
(when (let? (slot-env cp))
(let-set! env var new-val))))))
(when (and (let? (slot-env cp)) ; when slot-env is GC'd, the c-pointer field is set to #f (by the GC)
(let? (slot-expr-env cp)))
(let-set! (slot-env cp)
(slot-symbol cp)
(eval (slot-expr cp) (slot-expr-env cp)))))
(define (slot-equal? cp1 cp2)
......@@ -79,12 +74,11 @@
(define (setter-remove cp lst)
;; if reactive-set! called again on a variable, its old setters need to remove the now obsolete set of that variable
(if (null? lst)
()
(if (slot-equal? cp (car lst))
(cdr lst)
(cons (car lst)
(setter-remove cp (cdr lst))))))
(map (lambda (c)
(if (slot-equal? cp c)
(values)
c))
lst))
(define* (make-setter var env (followers ()) (setters ()) (expr ()) expr-env)
......@@ -258,9 +252,8 @@
(cons cp setter-followers)))))
setters))))))
vars inits)))
`(let ,vars/inits
,@reacts
,@body)))))
(cons 'let (cons vars/inits (append reacts body)))))))
;;; --------------------------------------------------------------------------------
#|
......
......@@ -1055,8 +1055,8 @@
;; -------- emacs --------
(define (emacs-repl)
;; TODO: use the emacs language server protocol? (not our own rpc stuff or epc), for json, see json.scm
;; probably will need an argument/function? for repl to open the channel or whatever
;; someday maybe use the language server protocol? (not our own rpc stuff or epc), for json, see json.scm
;; probably will need an argument/function for repl to open the channel or whatever
;; also this does not resend the entire expression after editing
;; and does not notice in-place edits
;; can <cr> get entire expr?
......
This diff is collapsed.
#ifndef S7_H
#define S7_H
#define S7_VERSION "8.1"
#define S7_DATE "4-Jan-19"
#define S7_VERSION "8.2"
#define S7_DATE "22-Mar-19"
#include <stdint.h> /* for int64_t */
......@@ -291,11 +291,6 @@ s7_pointer s7_make_and_fill_vector(s7_scheme *sc, s7_int len, s7_pointer fill);
void s7_vector_fill(s7_scheme *sc, s7_pointer vec, s7_pointer obj); /* (vector-fill! vec obj) */
s7_pointer s7_vector_copy(s7_scheme *sc, s7_pointer old_vect);
s7_pointer s7_vector_to_list(s7_scheme *sc, s7_pointer vect); /* (vector->list vec) */
s7_int s7_print_length(s7_scheme *sc); /* value of (*s7* 'print-length) */
s7_int s7_set_print_length(s7_scheme *sc, s7_int new_len); /* sets (*s7* 'print-length), returns old value */
/*
* (vect i) is the same as (vector-ref vect i)
* (set! (vect i) x) is the same as (vector-set! vect i x)
......@@ -303,8 +298,7 @@ s7_int s7_set_print_length(s7_scheme *sc, s7_int new_len);
* (set! (vect i j k) x) sets that element (vector-ref and vector-set! can also be used)
* (make-vector (list 2 3 4)) returns a 3-dimensional vector with the given dimension sizes
* (make-vector '(2 3) 1.0) returns a 2-dim vector with all elements set to 1.0
*/
*/
bool s7_is_hash_table(s7_pointer p); /* (hash-table? p) */
s7_pointer s7_make_hash_table(s7_scheme *sc, s7_int size); /* (make-hash-table size) */
......@@ -572,6 +566,12 @@ s7_pointer s7_fill(s7_scheme *sc, s7_pointer args); /* (fill! ...) */
s7_pointer s7_type_of(s7_scheme *sc, s7_pointer arg); /* (type-of arg) */
s7_int s7_print_length(s7_scheme *sc); /* value of (*s7* 'print-length) */
s7_int s7_set_print_length(s7_scheme *sc, s7_int new_len); /* sets (*s7* 'print-length), returns old value */
s7_int s7_float_format_precision(s7_scheme *sc); /* value of (*s7* 'float-format-precision) */
s7_int s7_set_float_format_precision(s7_scheme *sc, s7_int new_len); /* sets (*s7* 'float-format-precision), returns old value */
/* -------------------------------------------------------------------------------- */
/* c types/objects */
......@@ -854,6 +854,7 @@ void s7_gc_unprotect(s7_scheme *sc, s7_pointer x); /* used in CM */
*
* s7 changes
*
* 22-Mar: s7_float_format_precision. port-position. port-file.
* 4-Jan-19: morally-equal? -> equivalent?
* --------
* 29-Dec: s7_c_type_set_getter|setter (implicit c-object access).
......
......@@ -384,7 +384,7 @@ The following constants are predefined: pi, most-positive-fixnum, most-negative-
Other math-related differences between s7 and r5rs:
</p>
<ul>
<ul style="list-style-type:disc;">
<li>rational? and exact mean integer or ratio (i.e. not floating point), inexact means not exact.
<li>floor, ceiling, truncate, and round return (exact) integer results.
<li>"#" does not stand for an unknown digit.
......@@ -2393,17 +2393,17 @@ of the table sizes, or the order in which the key/value pairs were added.
</div>
<div class="indented">
<p>The third argument to make-hash-table (eq-func) is slightly complicated. If it is omitted,
<p>The second argument to make-hash-table (eq-func) is slightly complicated. If it is omitted,
s7 chooses the hashing equality and mapping functions based on the keys in the hash-table.
There are times when you know
in advance what equality function you want. If it's one of the built-in s7 equality
functions, eq?, eqv?, equal?, equivalent?, =, string=?, string-ci=?, char=?, or char-ci=?,
you can pass that function as the third argument. In any other case, you need to
you can pass that function as the second argument. In any other case, you need to
give s7 both the equality function and the mapping function. The latter takes any object
and returns the hash-table location for it (an integer). The problem here is that
for the arbitrary equality function to work, objects that are equal according to that
function have to be mapped to the same hash-table location. There's no way for s7 to intuit
what this mapping should be except in the built-in cases. So to specify some arbitrary function, the third
what this mapping should be except in the built-in cases. So to specify some arbitrary function, the second
argument is a cons: '(equality-checker mapper).
</p>
......@@ -2453,9 +2453,10 @@ Otherwise, for example, you could use NaN as a key, but then never be able to ac
'(27 . 196418) '(28 . 317811) '(29 . 514229) '(30 . 832040) '(31 . 1346269)
'(32 . 2178309) '(33 . 3524578) '(34 . 5702887)))</em>
</pre>
<p>but the tail recursive version of fib is simpler and almost as fast as the memoized version.</p>
</div>
<p>The fourth argument, typers, sets type checkers for the keys and values in the table.
<p>The third argument, typers, sets type checkers for the keys and values in the table.
It is a cons of the type functions (currently built-in functions only, as in vectors):
<code>(cons symbol? integer?)</code> for example. This says that all the keys must
be symbols and all the values integers.
......@@ -4019,11 +4020,29 @@ Other functions:
</p>
<ul>
<li>read-byte and write-byte: binary IO.
<li>read-line: line-at-a-time reads, optional third argument #t to include the newline.
<li>read-byte and write-byte: binary IO
<li>read-line: line-at-a-time reads, optional third argument #t to include the newline
<li>read-string (r7rs)
<li>current-error-port, set-current-error-port
<li><em class=def id="portfilename">port-filename</em> and
<em class=def id="portlinenumber">port-line-number</em> (input ports)
<li><em class=def id="portposition">port-position</em> (input port, settable)
<li><em class=def id="portfile">port-file</em>
</ul>
<p>Use length to get the length in bytes of an input port's file or string.
port-line-number is settable (for fancy *#readers*).
<b>port-position</b> is the position in bytes of the reader in the port. It is settable.
<b>port-file</b> is intended for use with the *libc* library. It returns a c-pointer
containing the FILE* pointer associated with the file port (except in Windows):
</p>
<pre class="indented">
(call-with-input-file "s7test.scm"
(lambda (p)
(with-let (sublet *libc* :file (<em class=red>port-file</em> p))
(fseek file 1000 SEEK_SET))))
</pre>
<p>The variable (*s7* 'print-length) sets
the upper limit on how many elements of a sequence are printed by object-&gt;string and format.
When running s7 behind a GUI, you often want input to come from and output to go to
......@@ -4685,10 +4704,10 @@ the initial value:
<b><em class=def id="loadpath">*load-path*</em></b> is a list of directories to search when loading a file.
<b><em class=def id="loadhook">*load-hook*</em></b> is a hook whose functions are called just before a file is loaded.
The hook function argument, named 'name, is the filename.
While loading, the <em class=def id="portfilename">port-filename</em> and
<em class=def id="portlinenumber">port-line-number</em> of the current-input-port can tell you
where you are in the file. This data is available after loading via <em class=def id="pairlinenumber">pair-line-number</em>
and <em class=def id="pairfilename">pair-filename</em>. port-line-number is settable (for fancy *#readers*).
While loading, port-filename and
port-line-number of the current-input-port can tell you
where you are in the file. This data is also available after loading via <em class=def id="pairlinenumber">pair-line-number</em>
and <em class=def id="pairfilename">pair-filename</em>.
</p>
<pre class="indented">
......@@ -4734,8 +4753,8 @@ at startup *features* is:
<pre class="indented">
&gt; *features*
<em class="gray">(snd-18.0 snd17 snd audio snd-s7 snd-gtk gsl alsa gtk2 xg clm6 clm sndlib linux
dlopen complex-numbers system-extras ratio s7-4.14 s7) </em>
<em class="gray">(snd-19.3 snd19 snd audio snd-s7 snd-motif gsl alsa xm clm6 clm sndlib linux
autoload dlopen history complex-numbers system-extras overflow-checks ratio s7-8.2 s7)</em>
&gt; (provided? 'gsl)
<em class="gray">#t</em>
</pre>
......@@ -4993,10 +5012,14 @@ Here we scan the symbol table looking for any function that doesn't have documen
(<em class=red>symbol-table</em>))
</pre>
<p>Or get a list of gensyms:</p>
<pre>
(map (lambda (sym) (if (gensym? sym) sym (values))) (<em class=red>symbol-table</em>))
</pre>
<div class="indented">
<p>Here's a better example, an automatic software tester.
<p>An automatic software tester (see tauto.scm and auto-tester.scm in snd tools for extensions):
</p>
<pre class="indented">
......@@ -5084,9 +5107,9 @@ some other thing, they satisfy the function equivalent?.
</p>
<pre class="indented">
&gt; (equivalent? 2 2.0) ; would "equal!?" be a better name?
&gt; (equivalent? 2 2.0)
<em class="gray">#t</em>
&gt; (equivalent? 1/0 1/0) ; NaN
&gt; (equivalent? 1/0 1/0) ; NaN
<em class="gray">#t</em>
&gt; (equivalent? .1 1/10)
<em class="gray">#t</em> ; floating-point epsilon here is 1.0e-15 or thereabouts
......@@ -5101,7 +5124,7 @@ some other thing, they satisfy the function equivalent?.
<p>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 a 'equivalent? method,
Finally, if either argument is an environment with an 'equivalent? method,
that method is invoked.
</p>
......@@ -5374,7 +5397,9 @@ the generic functions mechanism, much like a c-object:
<p>c-pointer-&gt;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.
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-&gt;string
of a c-pointer even if :readable is specified.
</p>
......@@ -5462,7 +5487,7 @@ int main(int argc, char **argv)
<p id="s7vsr5rs">Some other differences from r5rs:
</p>
<ul>
<ul style="list-style-type:disc;">
<li>no force or delay (see <a href="#r7rs">below</a>).
<li>no syntax-rules or any of its friends.
<li>no scheme-report-environment, null-environment, or interaction-environment (use curlet).
......@@ -5511,7 +5536,7 @@ definition, and a later redefinition does not affect earlier uses.
<p>Here are some changes I'd make to s7 if I didn't care about compatibility with other Schemes:
</p>
<ul>
<ul style="list-style-type:disc;">
<li>remove the exact/inexact distinction including #i and #e (done! #i means int-vector constant).
<li>remove call-with-values and its friends
<li>remove char-ready?
......@@ -5526,7 +5551,7 @@ definition, and a later redefinition does not affect earlier uses.
<p>(most of these are removed if you set the compiler flag WITH_PURE_S7), and perhaps:
</p>
<ul>
<ul style="list-style-type:disc;">
<li>remove even? and odd?, gcd and lcm.
<li>remove string-length and vector-length.
<li>remove list-ref|set!, string-ref|set!, vector-ref|set!, hash-table-ref|set!, set-car!|cdr!, and set-current-output|input|error-port.
......@@ -5607,7 +5632,7 @@ Better ideas are always welcome!
<p>And the built-in constants:
</p>
<ul>
<ul style="list-style-type:disc;">
<li>pi
<li>*stdin* *stdout* *stderr*
<li>*s7*
......@@ -5627,7 +5652,7 @@ Better ideas are always welcome!
<p>Currently WITH_PURE_S7:
</p>
<ul>
<ul style="list-style-type:disc;">
<li>places 'pure-s7 in *features*
<li>omits char-ready, char-ci*, string-ci*
<li>omits string-copy, string-fill!, vector-fill!, vector-append
......@@ -8371,7 +8396,7 @@ int main (int argc, char **argv)
<div class="header" id="gdb"><h4>gdb</h4></div>
<p>
gdbinit has some debugging commands, intended your ~/.gdbinit file.
gdbinit has some debugging commands, intended for your ~/.gdbinit file.
</p>