Commit e18ab5be authored by IOhannes m zmölnig's avatar IOhannes m zmölnig

New upstream version 19.0

parent 18b3700d
Snd is a sound editor written by Bill Schottstaedt (bil@ccrma.stanford.edu).
Except where otherwise noted, it is Copyright 1996-2006 The Board of Trustees
of Stanford University.
Except where otherwise noted, it is Copyright 1996-2016 Bill Schottstaedt.
......
Snd change log
2-Jan-19: Snd 19.0.
2019 ----------------------------------------------------------------
20-Nov: Snd 18.9.
8-Oct: Snd 18.8.
31-Aug: Snd 18.7.
......
Snd 18.9:
Snd 19.0
Kjetil updated the s7webserver directory
s7: added (*s7* 'history-enabled) at Kjetil's suggestion.
deprecated s7_gc_unprotect (use s7_gc_unprotect_at).
added weak-hash-table
s7: variables can be statically typed via the built-in type checkers like integer?
for example, (set! (setter 'x) integer?)
The main visible s7 change:
audio.c: added JACK_AUTO_SRC (defaults to 1).
hash-table* is now hash-table, and the old hash-table is gone.
This code can provide backwards compatibility except for some
corner cases involving map and for-each:
checked: FC 29 (gcc 8.2.1), macOS Mojave, sbcl 1.4.13
(when (string>=? (s7-version) "8.0")
(define hash-table* hash-table)
(define (hash-table . args)
(apply hash-table* (map (lambda (x)
(values (car x) (cdr x)))
args))))
checked: sbcl 1.4.14|15
Thanks!: Kjetil Matheussen
\ No newline at end of file
This source diff could not be displayed because it is too large. You can view the blob instead.
......@@ -408,11 +408,12 @@ Xen mus_optkey_to_procedure(Xen key, const char *caller, int n, Xen def, int req
/* ---------------- clm keywords ---------------- */
#if HAVE_SCHEME
static s7_pointer kw_frequency, kw_radius;
static s7_pointer kw_frequency, kw_radius, kw_readable;
static void init_keywords(void)
{
kw_frequency = Xen_make_keyword("frequency");
kw_radius = Xen_make_keyword("radius");
kw_readable = Xen_make_keyword("readable");
}
#else
......@@ -1331,7 +1332,7 @@ static s7_pointer mus_generator_to_string(s7_scheme *sc, s7_pointer args)
{
s7_pointer choice;
choice = s7_cadr(args);
if (choice == s7_make_keyword(sc, "readable"))
if (choice == kw_readable)
s7_error(sc, s7_make_symbol(sc, "out-of-range"), s7_list(sc, 1, s7_make_string(sc, "can't write a clm generator readably")));
}
return(s7_make_string(sc, mus_describe(((mus_xen *)s7_c_object_value(g))->gen)));
......
This diff is collapsed.
......@@ -5246,6 +5246,24 @@ fi
if test "$with_ruby" = yes ; then
if test x$PKG_CONFIG != xno ; then
if test "$ac_snd_extension_language" = none ; then
if $PKG_CONFIG ruby-2.6 --exists ; then
$as_echo "#define HAVE_RUBY 1" >>confdefs.h
XEN_CFLAGS="-fPIC `$PKG_CONFIG ruby-2.6 --cflags`"
# this depends on building ruby itself with the --enable-shared flag
XEN_LIBS="`$PKG_CONFIG ruby-2.6 --libs`"
LOCAL_LANGUAGE=Ruby-`$PKG_CONFIG ruby-2.6 --modversion`
ac_snd_extension_language=Ruby
if test "$ac_snd_gui_choice" = gtk ; then
S7_LIB="xg.o"
else
S7_LIB=""
fi
fi
fi
if test "$ac_snd_extension_language" = none ; then
if $PKG_CONFIG ruby-2.5 --exists ; then
$as_echo "#define HAVE_RUBY 1" >>confdefs.h
......
......@@ -386,7 +386,7 @@ fi
if test "$with_ruby" = yes ; then
if test x$PKG_CONFIG != xno ; then
m4_foreach([ruby_version], [[ruby-2.5], [ruby-2.4], [ruby-2.3], [ruby-2.2], [ruby-2.1], [ruby-2.0], [ruby], [ruby-1.9.3], [ruby-1.9], [ruby-1.8]],
m4_foreach([ruby_version], [[ruby-2.6], [ruby-2.5], [ruby-2.4], [ruby-2.3], [ruby-2.2], [ruby-2.1], [ruby-2.0], [ruby], [ruby-1.9.3], [ruby-1.9], [ruby-1.8]],
[
if test "$ac_snd_extension_language" = none ; then
if $PKG_CONFIG ruby_version --exists ; then
......
This diff is collapsed.
(define* (linear-expr-1D data (generations 100))
(let ((size 100)
(range 1.0)
(data-size (length data)))
(let ((population (make-vector size)))
(define (initial-generation)
(do ((i 0 (+ i 1)))
((= i size))
(set! (population i) (vector (- (random range) (/ range 2)) (- (random range) (/ range 2))))))
(define (distance coeff offset)
(let ((dist 0.0))
(do ((k 0 (+ k 1)))
((= k data-size) dist)
(let ((err (- (data k) (+ (* coeff k) offset))))
(set! dist (+ dist (* err err)))))))
(define (next-generation)
(let ((distances (make-vector size 0.0)))
(do ((i 0 (+ i 1)))
((= i size))
(set! (distances i) (cons (distance ((population i) 0) ((population i) 1)) i)))
(sort! distances (lambda (a b) (< (car a) (car b))))
(do ((i (/ size 2) (+ i 1))
(j 0 (+ j 1)))
((= i size))
(let* ((loc (cdr (distances j))) ; location (in population) of a good one
(coeff ((population loc) 0)) ; its coeff
(offset ((population loc) 1)) ; and offset
(new-loc (cdr (distances i)))) ; location of the bad one
;(format #t "~D: replace ~A using ~A~%" j (distances i) (distances j))
(set! (population new-loc) (vector (+ coeff (- (random range) (/ range 2)))
(+ offset (- (random range) (/ range 2)))))))
(distances 0)))
(initial-generation)
(let ((last-dist size)
(best #f))
(call-with-exit
(lambda (done)
(do ((i 0 (+ i 1)))
((= i generations))
(set! best (next-generation))
;(format #t "~D: ~A ~A ~A~%" i range (car best) (population (cdr best)))
(if (< (car best) 1e-9)
(done))
(let* ((new-dist (car best))
(improvement (abs (- new-dist last-dist))))
(if (< improvement range)
(set! range (max 0.001 (* range 0.5)))
(if (> improvement range)
(set! range (min 1024.0 (* 2 range)))))
(set! last-dist new-dist)))))
(let ((simpler-coeff (rationalize ((population (cdr best)) 0) .1))
(simpler-offset (rationalize ((population (cdr best)) 1) .1)))
(let ((dist (distance simpler-coeff simpler-offset)))
(if (< dist (* 2 (car best)))
(format #f "~A * k + ~A, err: ~A~%" simpler-coeff simpler-offset dist)
(format #f "~A * k + ~A, err: ~A~%" ((population (cdr best)) 0) ((population (cdr best)) 1) (car best)))))))))
#|
(linear-expr-1D (let ((v (make-vector 100)))
(do ((i 0 (+ i 1)))
((= i 100))
(set! (v i) (+ 1 (* i 2))) )
v))
"2 * k + 1, err: 0.0"
(linear-expr-1D (let ((v (make-vector 100)))
(do ((i 0 (+ i 1)))
((= i 100))
(set! (v i) (+ 1 (- (random .01) .005) (* i 2))))
v))
"2 * k + 1, err: 0.00079150685524436"
;; so noise is not a problem
|#
(define *show-progress* #f)
(define* (poly-expr data (generations 100) (top-power 10) (xscale 1.0))
(let ((size 100)
(range 1.0)
(data-size (length data)))
(let ((population (make-vector size)))
(define (new-coeffs good-coeffs bad-coeffs power)
(let* ((len (length good-coeffs))
(coeffs (make-vector len 0.0)))
(do ((k 0 (+ k 1)))
((> k power) coeffs)
(let ((local-diff (/ (- (good-coeffs k) (bad-coeffs k)) 2.0)))
(set! (coeffs k) (+ (good-coeffs k) local-diff (- (random range) (/ range 2))))))))
(define (initial-generation power)
(let ((len (+ 1 power)))
(do ((i 0 (+ i 1)))
((= i size))
(set! (population i) (new-coeffs (make-vector len 0.0) (make-vector len 0.0) power)))))
(define (poly coeffs x power)
;; 0 => offset, 1 => x, 2 => x^2 etc
(if (= power 1)
(+ (coeffs 0) (* (coeffs 1) x))
(let ((sum (coeffs power)))
(do ((k (- power 1) (- k 1)))
((< k 0) sum)
(set! sum (+ (coeffs k) (* x sum)))))))
(define (distance coeffs power)
(let ((dist 0.0))
(do ((k 0 (+ k 1)))
((= k data-size) dist)
(let ((err (- (data k) (poly coeffs (* xscale k) power))))
(set! dist (+ dist (* err err)))))))
(define (iterate-distance coeffs power)
;; distance if using iterated function, rather than just polynomial
(call-with-exit
(lambda (return)
(let* ((dist 0.0)
(y 0.0))
(do ((k 0 (+ k 1)))
((= k data-size) dist)
(let ((err (modulo (- (data k) y) 2.0)))
(if (nan? err) ; modulo returns NaN if either arg is inf
(return 1.0e50))
(if (> err 1.0)
(set! err (- 2.0 err)))
(set! dist (+ dist (* err err)))
(set! y (poly coeffs y power))))))))
(define (display-expr coeffs power)
(do ((k power (- k 1)))
((= k 1))
(format #t "~,3g k^~D + " (coeffs k) k))
(format #t "~,3g k + ~,3g" (coeffs 1) (coeffs 0)))
(define (next-generation power)
(let ((distances (make-vector size 0.0)))
(do ((i 0 (+ i 1)))
((= i size))
(set! (distances i) (cons (distance (population i) power) i)))
(sort! distances (lambda (a b) (< (car a) (car b))))
(do ((i (/ size 2) (+ i 1))
(j 0 (+ j 1)))
((= i size))
(let* ((good-loc (cdr (distances j))) ; location (in population) of a good one
(good-coeffs (population good-loc)) ; its coeffs
(bad-loc (cdr (distances i))) ; location of the bad one
(bad-coeffs (population bad-loc))) ; its coeffs
(set! (population bad-loc) (new-coeffs good-coeffs bad-coeffs power))))
(distances 0)))
(do ((power 1 (+ power 1)))
((> power top-power))
(initial-generation power)
(let ((last-dist size)
(best #f))
(call-with-exit
(lambda (done)
(do ((i 0 (+ i 1)))
((= i generations))
(let ((new-best (next-generation power)))
(if (and *show-progress*
best
(< (car new-best) (car best)))
(begin
(format #t " ")
(display-expr (population (cdr new-best)) power)
(format #t ", err: ~,3g~%" (car new-best))))
(set! best new-best))
(if (< (car best) 1e-9)
(done))
(let* ((new-dist (car best))
(improvement (abs (- new-dist last-dist))))
(if (< improvement range)
(set! range (max 0.001 (* range 0.5)))
(if (> improvement range)
(set! range (min 1024.0 (* 2 range)))))
(set! last-dist new-dist)))))
(let ((simpler-coeffs (apply vector (map (lambda (x) (rationalize x .1)) (population (cdr best))))))
(let ((dist (distance simpler-coeffs power)))
(if (< dist (* 2 (car best)))
(begin
(display-expr simpler-coeffs power)
(format #t ", err: ~,3g~%~%" dist))
(begin
(display-expr (population (cdr best)) power)
(format #t ", err: ~,3g~%~%" (car best)))))))))))
#|
:(poly-expr (let ((v (make-vector 100)))
(do ((i 0 (+ i 1)))
((= i 100))
(set! (v i) (+ 1.5 (* i 2))))
v)
100 2)
()
2 * k + 3/2, err: 0.0
0 * k^2 + 2 * k + 3/2, err: 0.0
:(poly-expr (let ((v (make-vector 100)))
(do ((i 0 (+ i 1)))
((= i 100))
(set! (v i) (+ 1.5 (* i 2) (* i i))))
v)
100 2)
()
101 * k + -3231/2, err: 55527780.0
1 * k^2 + 2 * k + 3/2, err: 0.0
(poly-expr (let ((v (make-vector 100)))
(do ((i 0 (+ i 1)))
((= i 100))
(set! (v i) (+ 10 (* i 3) (* i i) (* 2 i i i))))
v)
500 3)
71211/4 * k + -775493/2, err: 5073746188744.4
298 * k^2 + -46797/4 * k + 282358/3, err: 142657213706.32
1.9999646468097 * k^3 + 1.0060760943148 * k^2 + 2.7343239562578 * k + 10.395190849075, err: 341.7343511583
(poly-expr (let ((v (make-vector 100)))
(do ((i 0 (+ i 1)))
((= i 100))
(set! (v i) (+ 10 (* i 3) (* i i) (* .02 i i i))))
v)
500 3)
279 * k + -16405/3, err: 889433525.53111
4 * k^2 + -114 * k + 4756/5, err: 16055636.02
0.01993019520734 * k^3 + 1.0122316382516 * k^2 + 2.423061574187 * k + 16.287894409628, err: 451.01103769494
if scaled by .01:
(poly-expr (let ((v (make-vector 100)))
(do ((i 0 (+ i 1)))
((= i 100))
(set! (v i) (+ 1.0 (* i 32 .01) (* i i 3 .01 .01) (* 1 i i i .01 .01 .01))))
v)
500 3 .01)
179/5 k + 1/3, err: 11.3
4.48 k^2 + 31.4 k + 1.05, err: 0.0357
1 k^3 + 3 k^2 + 32 k + 1, err: 4.76e-28
|#
Freeverb - Free, studio-quality reverb SOURCE CODE in the public domain
-----------------------------------------------------------------------
Written by Jezar at Dreampoint - http://www.dreampoint.co.uk
Introduction
------------
Hello.
I'll try to keep this "readme" reasonably small. There are few things in the world that I hate more than long "readme" files. Except "coding conventions" - but more on that later...
In this zip file you will find two folders of C++ source code:
"Components" - Contains files that should clean-compile ON ANY TYPE OF COMPUTER OR SYSTEM WHATSOEVER. It should not be necessary to make ANY changes to these files to get them to compile, except to make up for inadequacies of certain compilers. These files create three classes - a comb filter, an allpass filter, and a reverb model made up of a number of instances of the filters, with some features to control the filters at a macro level. You will need to link these classes into another program that interfaces with them. The files in the components drawer are completely independant, and can be built without dependancies on anything else. Because of the simple interface, it should be possible to interface these files to any system - VST, DirectX, anything - without changing them AT ALL.
"FreeverbVST" - Contains a Steinberg VST implementation of this version of Freeverb, using the components in (surprise) the components folder. It was built on a PC but may compile properly for the Macintosh with no problems. I don't know - I don't have a Macintosh. If you've figured out how to compile the examples in the Steinberg VST Development Kit, then you should easilly figure out how to bring the files into a project and get it working in a few minutes. It should be very simple.
Note that this version of Freeverb doesn't contain predelay, or any EQ. I thought that might make it difficult to understand the "reverb" part of the code. Once you figure out how Freeverb works, you should find it trivial to add such features with little CPU overhead.
Also, the code in this version of Freeverb has been optimised. This has changed the sound *slightly*, but not significantly compared to how much processing power it saves.
Finally, note that there is also a built copy of this version of Freeverb called "Freeverb3.dll" - this is a VST plugin for the PC. If you want a version for the Mac or anything else, then you'll need to build it yourself from the code.
Technical Explanation
---------------------
Freeverb is a simple implementation of the standard Schroeder/Moorer reverb model. I guess the only reason why it sounds better than other reverbs, is simply because I spent a long while doing listening tests in order to create the values found in "tuning.h". It uses 8 comb filters on both the left and right channels), and you might possibly be able to get away with less if CPU power is a serious constraint for you. It then feeds the result of the reverb through 4 allpass filters on both the left and right channels. These "smooth" the sound. Adding more than four allpasses doesn't seem to add anything significant to the sound, and if you use less, the sound gets a bit "grainy". The filters on the right channel are slightly detuned compared to the left channel in order to create a stereo effect.
Hopefully, you should find the code in the components drawer a model of brevity and clarity. Notice that I don't use any "coding conventions". Personally, I think that coding conventions suck. They are meant to make the code "clearer", but they inevitably do the complete opposite, making the code completely unfathomable. Anyone whose done Windows programming with its - frankly stupid - "Hungarian notation" will know exactly what I mean. Coding conventions typically promote issues that are irrelevant up to the status of appearing supremely important. It may have helped back people in the days when compilers where somewhat feeble in their type-safety, but not in the new millenium with advanced C++ compilers.
Imagine if we rewrote the English language to conform to coding conventions. After all, The arguments should be just as valid for the English language as they are for a computer language. For example, we could put a lower-case "n" in front of every noun, a lower-case "p" in front of a persons name, a lower-case "v" in front of every verb, and a lower-case "a" in front of every adjective. Can you imagine what the English language would look like? All in the name of "clarity". It's just as stupid to do this for computer code as it would be to do it for the English language. I hope that the code for Freeverb in the components drawer demonstrates this, and helps start a movement back towards sanity in coding practices.
Background
----------
Why is the Freeverb code now public domain? Simple. I only intended to create Freeverb to provide me and my friends with studio-quality reverb for free. I never intended to make any money out of it. However, I simply do not have the time to develop it any further. I'm working on a "concept album" at the moment, and I'll never finish it if I spend any more time programming.
In any case, I make more far money as a contract programmer - making Mobile Internet products - than I ever could writing plugins, so it simply doesn't make financial sense for me to spend any more time on it.
Rather than give Freeverb to any particular individual or organisation to profit from it, I've decided to give it away to the internet community at large, so that quality, FREE (or at the very least, low-cost) reverbs can be developed for all platforms.
Feel free to use the source code for Freeverb in any of your own products, whether they are also available for free, or even if they are commercial - I really don't mind. You may do with the code whatever you wish. If you use it in a product (whether commercial or not), it would be very nice of you, if you were to send me a copy of your product - although I appreciate that this isn't always possible in all circumstances.
HOWEVER, please don't bug me with questions about how to use this code. I gave away Freeverb because I don't have time to maintain it. That means I *certainly* don't have time to answer questions about the source code, so please don't email questions to me. I *will* ignore them. If you can't figure the code for Freeverb out - then find somebody who can. I hope that either way, you enjoy experimenting with it.
Disclaimer
----------
This software and source code is given away for free, without any warranties of any kind. It has been given away to the internet community as a free gift, so please treat it in the same spirit.
I hope this code is useful and interesting to you all!
I hope you have lots of fun experimenting with it and make good products!
Very best regards,
Jezar.
Technology Consultant
Dreampoint Design and Engineering
http://www.dreampoint.co.uk
//ends
(define-envelope pna '(0 0 1 1 10 .6000 25 .3000 100 0 ))
(define-envelope ind2 '(0 1 25 .4000 75 .6000 100 0 ))
(define-envelope high_att_ind '(0 1 25 .2000 75 .4000 100 0 ))
(define-envelope no_att_ind '(0 .6000 75 .6000 100 0 ))
(define-envelope no_dec_ind '(0 1 25 .4000 75 .6000 100 .6000 ))
(define-envelope no_att_or_dec_ind '(0 .6000 100 .6000 ))
(define-envelope ampf '(0 0 25 1 60 .7000 75 1 100 0 ))
(define-envelope rampf '(0 0 100 1 ))
(define-envelope fast_up '(0 0 25 1 100 1 ))
(define-envelope slow_up '(0 0 25 0 100 1 ))
(define-envelope tapf '(0 0 1 1 99 1 100 0 ))
(define-envelope skwfrq '(0 -1 5 .2500 10 0 100 .1000 ))
(define-envelope oldpizzf '(0 0 1 1 5 .6000 10 .3000 25 .1000 100 0 ))
(define-envelope newpizzf '(0 0 1 1 5 .6000 10 .3000 25 .1000 99 .0200 100 0 ))
(define-envelope pizzf '(0 0 1 1 5 .6000 10 .3000 25 .1000 100 0 ))
(define-envelope legatof '(0 0 30 1 90 1 100 0 ))
(define-envelope marcatof '(0 0 3 1 10 .8000 95 1 100 0 ))
(define-envelope onef '(0 1 100 1 ))
(define-envelope mod_up '(0 0 25 0 75 1 100 1 ))
(define-envelope mod_down '(0 1 25 1 75 0 100 0 ))
(define-envelope one_to_zero '(0 1 75 1 100 0 ))
(define-envelope zero_to_one '(0 0 75 0 100 1 ))
(define-envelope down_flat '(0 1 25 0 75 .0500 100 0 ))
(define-envelope down_down '(0 1 25 0 75 .0500 100 -1 ))
(define-envelope down_up '(0 1 25 0 75 .0500 100 1 ))
(define-envelope flat_down '(0 -.1000 10 .1000 25 0 75 .0500 100 -1 ))
(define-envelope flat_up '(0 -.1000 10 .1000 25 0 75 0 100 1 ))
(define-envelope up_flat '(0 -1 25 .0500 75 0 100 0 ))
(define-envelope up_up '(0 -1 25 .0500 75 0 100 1 ))
(define-envelope up_down '(0 -1 25 .0500 75 0 100 -1 ))
(define-envelope swellf '(0 0 25 .8000 50 1 75 .8000 100 0 ))
(define-envelope fpf '(0 0 25 1 50 .3000 75 .3000 100 0 ))
(define-envelope indswell '(1 1 25 .4000 75 1 100 0 ))
(define-envelope pyr '(0 1 25 .1000 95 .1000 100 0 ))
(define-envelope fbell '(0 1 2 1.1000 25 .7500 75 .5000 100 .2000 ))
(define-envelope lowbell '(0 1 5 1.2500 25 .8000 75 .5000 100 .2000 ))
(define-envelope abell '(0 0 .1000 1 10 .6000 25 .3000 50 .1500 90 .1000 100 0 ))
(define-envelope dwnup '(0 1 10 .4000 20 1 35 .3000 45 .8000 60 .2000 80 .6000 100 0 ))
(define-envelope up50down '(0 0 50 1 100 0 ))
(define-envelope metalamp '(0 0 .5000 1 5 1 10 .5000 15 .2500 35 .1000 100 0 ))
(define-envelope slowupfastdown '(0 0 25 1 97 1 100 0 ))
(define-envelope slowup '(0 0 50 .1000 95 1 100 0 ))
(define-envelope indtoone '(0 1 25 .4000 100 .6500 ))
(define-envelope whoosh '(0 0 75 .1000 90 .3000 97 .6000 100 1 ))
(define-envelope mamp '(0 0 50 1 100 0 ))
(define-envelope n_amp '(0 0 65 1 100 0 ))
This diff is collapsed.
;;; use with-sound to write the data to a sound file
;;; use with-sound to write the data to a sound file: ./snd heart.scm medfly
(require snd-ws.scm)
;;; turn off clipping (the numbers will be between 70 and 150)
......
This source diff could not be displayed because it is too large. You can view the blob instead.
This diff is collapsed.
......@@ -113,7 +113,7 @@
eof-object? eq? equal? eqv? even? exact->inexact exact? exp expt
float? float-vector float-vector-ref float-vector? floor for-each funclet
gcd gensym gensym?
hash-table hash-table* hash-table-entries hash-table-ref hash-table? help hook-functions
hash-table hash-table-entries hash-table-ref hash-table? help hook-functions
if imag-part immutable? inexact->exact inexact? infinite? inlet input-port?
int-vector int-vector-ref int-vector? iterator-at-end? iterator-sequence integer->char
integer-decode-float integer-length integer? iterator?
......@@ -180,7 +180,7 @@
list->vector vector-fill! vector-length vector->list vector-ref vector-set! vector-dimensions
make-vector subvector vector float-vector make-float-vector float-vector-set!
float-vector-ref int-vector make-int-vector int-vector-set! int-vector-ref string->byte-vector
byte-vector make-byte-vector hash-table hash-table* make-hash-table hash-table-ref
byte-vector make-byte-vector hash-table make-hash-table hash-table-ref
hash-table-set! hash-table-entries cyclic-sequences call/cc call-with-current-continuation
call-with-exit load autoload eval eval-string apply for-each map dynamic-wind values
catch throw error documentation signature help procedure-source funclet
......@@ -200,7 +200,7 @@
make-string string string-copy copy list->string string->list string-append substring object->string
format cons list make-list reverse append vector-append list->vector vector->list make-vector
subvector vector make-float-vector float-vector make-int-vector int-vector byte-vector
hash-table hash-table* make-hash-table make-hook list-values append gentemp)) ; gentemp for other schemes
hash-table make-hash-table make-hook list-values append gentemp)) ; gentemp for other schemes
h))
(non-negative-ops (let ((h (make-hash-table)))
......@@ -310,10 +310,10 @@
define-values define-module define-method
define-syntax define-public define-inlinable define-integrable define^))
(cxars (hash-table '(car . ()) '(caar . car) '(cdar . cdr)
'(caaar . caar) '(cdaar . cdar) '(cddar . cddr) '(cadar . cadr)
'(caaaar . caaar) '(caadar . caadr) '(cadaar . cadar) '(caddar . caddr)
'(cdaaar . cdaar) '(cdadar . cdadr) '(cddaar . cddar) '(cdddar . cdddr)))
(cxars (hash-table 'car () 'caar 'car 'cdar 'cdr
'caaar 'caar 'cdaar 'cdar 'cddar 'cddr 'cadar 'cadr
'caaaar 'caaar 'caadar 'caadr 'cadaar 'cadar 'caddar 'caddr
'cdaaar 'cdaar 'cdadar 'cdadr 'cddaar 'cddar 'cdddar 'cdddr))
(outport #t)
(linted-files ())
......@@ -372,16 +372,15 @@
(define target-line-length 80) ; also 120 via let-temporarily
(denote (lint-truncate-string str)
(let ((len (length str)))
(if (< len target-line-length)
str
(do ((i (- target-line-length 6) (- i 1)))
(if (< (length str) target-line-length)
str
(do ((i (- target-line-length 6) (- i 1)))
((or (= i 40)
(char-whitespace? (string-ref str i)))
(string-append (substring str 0 (if (<= i 40)
(- target-line-length 6)
i))
"..."))))))
"...")))))
(denote (truncated-list->string form)
;; return form -> string with limits on its length
......@@ -2197,7 +2196,7 @@
(lambda (caller vname)
(set! sname (symbol->string vname)) ;(if (keyword? vname) (keyword->symbol vname) vname)))
(set! slen (length sname))
(set! s0 (sname 0))
(set! s0 (string-ref sname 0))
(cond ((assq s0 bad-var-names) =>
(lambda (baddies)
......@@ -6179,16 +6178,16 @@
(list (reverse ci) (reverse ic)))
|#
(define match-cxr
(let ((int->cxr (hash-table '(1 . car) '(2 . cdr)
'(5 . caar) '(6 . cadr) '(10 . cddr) '(9 . cdar)
'(21 . caaar) '(22 . caadr) '(26 . caddr) '(42 . cdddr) '(37 . cdaar) '(41 . cddar) '(25 . cadar) '(38 . cdadr)
'(106 . cadddr) '(170 . cddddr) '(85 . caaaar) '(86 . caaadr) '(89 . caadar) '(90 . caaddr) '(101 . cadaar) '(102 . cadadr)
'(105 . caddar) '(149 . cdaaar) '(150 . cdaadr) '(153 . cdadar) '(154 . cdaddr) '(165 . cddaar) '(166 . cddadr) '(169 . cdddar)))
(cxr->int (hash-table '(car . 1) '(cdr . 2)
'(caar . 5) '(cadr . 6) '(cddr . 10) '(cdar . 9)
'(caaar . 21) '(caadr . 22) '(caddr . 26) '(cdddr . 42) '(cdaar . 37) '(cddar . 41) '(cadar . 25) '(cdadr . 38)
'(cadddr . 106) '(cddddr . 170) '(caaaar . 85) '(caaadr . 86) '(caadar . 89) '(caaddr . 90) '(cadaar . 101) '(cadadr . 102)
'(caddar . 105) '(cdaaar . 149) '(cdaadr . 150) '(cdadar . 153) '(cdaddr . 154) '(cddaar . 165) '(cddadr . 166) '(cdddar . 169))))
(let ((int->cxr (hash-table 1 'car 2 'cdr
5 'caar 6 'cadr 10 'cddr 9 'cdar
21 'caaar 22 'caadr 26 'caddr 42 'cdddr 37 'cdaar 41 'cddar 25 'cadar 38 'cdadr
106 'cadddr 170 'cddddr 85 'caaaar 86 'caaadr 89 'caadar 90 'caaddr 101 'cadaar 102 'cadadr
105 'caddar 149 'cdaaar 150 'cdaadr 153 'cdadar 154 'cdaddr 165 'cddaar 166 'cddadr 169 'cdddar))
(cxr->int (hash-table 'car 1 'cdr 2
'caar 5 'cadr 6 'cddr 10 'cdar 9
'caaar 21 'caadr 22 'caddr 26 'cdddr 42 'cdaar 37 'cddar 41 'cadar 25 'cdadr 38
'cadddr 106 'cddddr 170 'caaaar 85 'caaadr 86 'caadar 89 'caaddr 90 'cadaar 101 'cadadr 102
'caddar 105 'cdaaar 149 'cdaadr 150 'cdadar 153 'cdaddr 154 'cddaar 165 'cddadr 166 'cdddar 169)))
(lambda (c1 c2)
(hash-table-ref int->cxr (logand (or (hash-table-ref cxr->int c1) 0)
(or (hash-table-ref cxr->int c2) 0))))))
......@@ -7535,7 +7534,7 @@
(list seq1 (caddr seq) (caddr form))))))
(if (memq (car seq) '(make-vector make-list vector list
make-float-vector make-int-vector float-vector int-vector
make-hash-table hash-table hash-table*
make-hash-table hash-table
inlet))
(lint-format "this doesn't make much sense: ~A" caller form)))
(when (eq? head 'list-ref)
......@@ -7599,7 +7598,7 @@
((memq (car target) '(make-vector vector make-string string make-list list append cons
vector-append inlet sublet copy vector-copy string-copy list-copy
int-vector float-vector byte-vector string-append make-byte-vector
make-int-vector make-float-vector make-hash-table hash-table hash-table*
make-int-vector make-float-vector make-hash-table hash-table
)) ;list-copy is from r7rs
(lint-format "~A is simply discarded; perhaps ~A" caller
(truncated-list->string target) ; (vector-set! (make-vector 3) 1 1) -- does this ever happen?
......@@ -9525,14 +9524,14 @@
(lint-format "perhaps use abs here: ~A" caller form)))
(hash-special 'magnitude sp-magnitude))
;; ---------------- hash-table* ----------------
;; ---------------- hash-table ----------------
(let ()
(define (sp-hash* caller head form env)
(define (sp-hash caller head form env)
(let ((len (length form)))
(if (and (positive? len)
(even? len))
(lint-format "key with no value? ~A" caller (truncated-list->string form)))))
(hash-special 'hash-table* sp-hash*))
(hash-special 'hash-table sp-hash))
;; ---------------- open-input-file open-output-file ----------------
(let ()
......@@ -11122,19 +11121,19 @@
(cons (car e1) lst)))))
(denote report-usage
(let ((unwrap-cxr (hash-table '(caar car) '(cadr cdr) '(cddr cdr) '(cdar car)
'(caaar caar car) '(caadr cadr cdr) '(caddr cddr cdr) '(cdddr cddr cdr)
'(cdaar caar car) '(cddar cdar car) '(cadar cadr car) '(cdadr cadr cdr)
'(cadddr cdddr cddr cdr) '(cddddr cdddr cddr cdr) '(caaaar caaar caar car) '(caaadr caadr cadr cdr)
'(caadar cadar cdar car) '(caaddr caddr cddr cdr) '(cadaar cdaar caar car) '(cadadr cdadr cadr cdr)
'(caddar cddar cdar car) '(cdaaar caaar caar car) '(cdaadr caadr cadr cdr) '(cdadar cadar cdar car)
'(cdaddr caddr cddr cdr) '(cddaar cdaar caar car) '(cddadr cdadr cadr cdr) '(cdddar cddar cdar car)))
(let ((unwrap-cxr (hash-table 'caar '(car) 'cadr '(cdr) 'cddr '(cdr) 'cdar '(car)
'caaar '(caar car) 'caadr '(cadr cdr) 'caddr '(cddr cdr) 'cdddr '(cddr cdr)
'cdaar '(caar car) 'cddar '(cdar car) 'cadar '(cadr car) 'cdadr '(cadr cdr)
'cadddr '(cdddr cddr cdr) 'cddddr '(cdddr cddr cdr) 'caaaar '(caaar caar car) 'caaadr '(caadr cadr cdr)
'caadar '(cadar cdar car) 'caaddr '(caddr cddr cdr) 'cadaar '(cdaar caar car) 'cadadr '(cdadr cadr cdr)
'caddar '(cddar cdar car) 'cdaaar '(caaar caar car) 'cdaadr '(caadr cadr cdr) 'cdadar '(cadar cdar car)
'cdaddr '(caddr cddr cdr) 'cddaar '(cdaar caar car) 'cddadr '(cdadr cadr cdr) 'cdddar '(cddar cdar car)))
(all-types-agree (lambda (v)
(let ((base-type (->lint-type (var-initial-value v)))
(vname (var-name v)))
(let ((typef (lambda (p)
(or (not (and (len>2? p)
(eq? (car p) 'set!)
(eq? (car p) 'set!)
(eq? vname (cadr p))))
(let ((nt (->lint-type (caddr p))))
(or (subsumes? base-type nt)
......@@ -21429,7 +21428,7 @@
(else
(set-outer outer-vars tree))))
(lambda (new-form leaves env fvar orig-form)
(unless (tree-set-memq '(define define*
;; these propagate backwards and we're not returning the new env in this loop,
......@@ -21526,7 +21525,7 @@
;; -------- walk head=symbol --------
(denote walk-symbol
(letrec ((unsafe-makers '(sublet inlet copy cons list append subvector vector hash-table hash-table*
(letrec ((unsafe-makers '(sublet inlet copy cons list append subvector vector hash-table
make-hash-table make-hook list-values append gentemp or and not))
(equal-ignoring-constants?
......
#! /bin/sh
# mkinstalldirs --- make directory hierarchy
# Author: Noah Friedman <friedman@prep.ai.mit.edu>
# Created: 1993-05-16
# Public domain
# $Id: mkinstalldirs,v 1.13 1999/01/05 03:18:55 bje Exp $
scriptversion=2009-04-28.21; # UTC
# Original author: Noah Friedman <friedman@prep.ai.mit.edu>
# Created: 1993-05-16
# Public domain.
#
# This file is maintained in Automake, please report
# bugs to <bug-automake@gnu.org> or send patches to
# <automake-patches@gnu.org>.
nl='
'
IFS=" "" $nl"
errstatus=0
dirmode=
usage="\
Usage: mkinstalldirs [-h] [--help] [--version] [-m MODE] DIR ...
Create each directory DIR (with mode MODE, if specified), including all
leading file name components.
Report bugs to <bug-automake@gnu.org>."
# process command line arguments
while test $# -gt 0 ; do
case $1 in
-h | --help | --h*) # -h for help
echo "$usage"
exit $?