diff options
| -rw-r--r-- | HISTORY.Snd | 1 | ||||
| -rw-r--r-- | NEWS | 10 | ||||
| -rw-r--r-- | clm.c | 1 | ||||
| -rwxr-xr-x | configure | 23 | ||||
| -rw-r--r-- | configure.ac | 7 | ||||
| -rw-r--r-- | debian/changelog | 9 | ||||
| -rw-r--r-- | debian/copyright_hints | 1 | ||||
| -rw-r--r-- | debian/upstream-changelog | 12 | ||||
| -rw-r--r-- | libc.scm | 552 | ||||
| -rw-r--r-- | libdl.scm | 2 | ||||
| -rw-r--r-- | libgdbm.scm | 2 | ||||
| -rw-r--r-- | libgsl.scm | 594 | ||||
| -rw-r--r-- | libm.scm | 2 | ||||
| -rw-r--r-- | libutf8proc.scm | 39 | ||||
| -rw-r--r-- | lint.scm | 16 | ||||
| -rw-r--r-- | mockery.scm | 3 | ||||
| -rw-r--r-- | s7.c | 1519 | ||||
| -rw-r--r-- | s7.h | 2 | ||||
| -rw-r--r-- | s7.html | 15 | ||||
| -rw-r--r-- | s7test.scm | 225 | ||||
| -rw-r--r-- | snd.h | 6 | ||||
| -rw-r--r-- | tools/auto-tester.scm | 36 | ||||
| -rw-r--r-- | tools/ffitest.c | 12 | ||||
| -rw-r--r-- | tools/sam.c | 1867 | ||||
| -rw-r--r-- | tools/t101.scm | 24 | ||||
| -rw-r--r-- | tools/tform.scm | 429 | ||||
| -rw-r--r-- | tools/timp.scm | 448 | ||||
| -rw-r--r-- | tools/utf8-tests.scm | 135 | ||||
| -rw-r--r-- | tools/valcall.scm | 4 |
29 files changed, 3508 insertions, 2488 deletions
diff --git a/HISTORY.Snd b/HISTORY.Snd index 7f8dd75..4e81bc5 100644 --- a/HISTORY.Snd +++ b/HISTORY.Snd @@ -1,5 +1,6 @@ Snd change log + 14-Apr: Snd 24.3. 12-Mar: Snd 24.2. 2-Feb: Snd 24.1. 1-Jan-24: Snd 24.0. @@ -1,7 +1,9 @@ -Snd 24.2 +Snd 24.3: -mostly work on optimizations in s7 +s7: format now always returns a string (where it used to return #f it + now returns "") +sam.c: bugfixes and improvements thanks to David Jaffe -checked: sbcl 2.4.2 +checked: sbcl 2.4.3 -Thanks!: James Hearon +Thanks!: Michael Edwards, Norman Gray, David Jaffe @@ -382,6 +382,7 @@ static char *int_array_to_string(int *arr, int num_ints, const char *name) { int i, len; char *intstr; + if (num_ints > 1024) num_ints = 1024; /* added 9-Apr-24 to try to make gcc happier */ len = num_ints * MAX_INT_SIZE + 64; descr = (char *)calloc(len, sizeof(char)); intstr = (char *)malloc(MAX_INT_SIZE * sizeof(char)); @@ -1,6 +1,6 @@ #! /bin/sh # Guess values for system-dependent variables and create Makefiles. -# Generated by GNU Autoconf 2.71 for snd 24.2. +# Generated by GNU Autoconf 2.71 for snd 24.3. # # Report bugs to <bil@ccrma.stanford.edu>. # @@ -611,8 +611,8 @@ MAKEFLAGS= # Identity of this package. PACKAGE_NAME='snd' PACKAGE_TARNAME='ftp://ccrma-ftp.stanford.edu/pub/Lisp/snd-24.tar.gz' -PACKAGE_VERSION='24.2' -PACKAGE_STRING='snd 24.2' +PACKAGE_VERSION='24.3' +PACKAGE_STRING='snd 24.3' PACKAGE_BUGREPORT='bil@ccrma.stanford.edu' PACKAGE_URL='' @@ -1346,7 +1346,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 24.2 to adapt to many kinds of systems. +\`configure' configures snd 24.3 to adapt to many kinds of systems. Usage: $0 [OPTION]... [VAR=VALUE]... @@ -1417,7 +1417,7 @@ fi if test -n "$ac_init_help"; then case $ac_init_help in - short | recursive ) echo "Configuration of snd 24.2:";; + short | recursive ) echo "Configuration of snd 24.3:";; esac cat <<\_ACEOF @@ -1537,7 +1537,7 @@ fi test -n "$ac_init_help" && exit $ac_status if $ac_init_version; then cat <<\_ACEOF -snd configure 24.2 +snd configure 24.3 generated by GNU Autoconf 2.71 Copyright (C) 2021 Free Software Foundation, Inc. @@ -2025,7 +2025,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 24.2, which was +It was created by snd $as_me 24.3, which was generated by GNU Autoconf 2.71. Invocation command line was $ $0$ac_configure_args_raw @@ -3967,7 +3967,7 @@ LOCAL_LANGUAGE="None" GRAPHICS_TOOLKIT="None" PACKAGE=Snd -VERSION=24.2 +VERSION=24.3 #-------------------------------------------------------------------------------- # configuration options @@ -6744,7 +6744,8 @@ case "$host" in if test "$GCC" = yes ; then SO_FLAGS="-fPIC $SO_FLAGS" SO_LD="$CC" - CFLAGS="$CFLAGS -Wno-format-truncation" +# CFLAGS="$CFLAGS -Wno-format-truncation" +# this gets a complaint from clang fi ;; @@ -7432,7 +7433,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 24.2, which was +This file was extended by snd $as_me 24.3, which was generated by GNU Autoconf 2.71. Invocation command line was CONFIG_FILES = $CONFIG_FILES @@ -7496,7 +7497,7 @@ ac_cs_config_escaped=`printf "%s\n" "$ac_cs_config" | sed "s/^ //; s/'/'\\\\\\\\ cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_cs_config='$ac_cs_config_escaped' ac_cs_version="\\ -snd config.status 24.2 +snd config.status 24.3 configured by $0, generated by GNU Autoconf 2.71, with options \\"\$ac_cs_config\\" diff --git a/configure.ac b/configure.ac index c134dae..2894316 100644 --- a/configure.ac +++ b/configure.ac @@ -5,7 +5,7 @@ # gmp, mpfr, and mpc deliberately have none! -AC_INIT(snd, 24.2, bil@ccrma.stanford.edu, ftp://ccrma-ftp.stanford.edu/pub/Lisp/snd-24.tar.gz) +AC_INIT(snd, 24.3, bil@ccrma.stanford.edu, ftp://ccrma-ftp.stanford.edu/pub/Lisp/snd-24.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=24.2 +VERSION=24.3 #-------------------------------------------------------------------------------- # configuration options @@ -674,7 +674,8 @@ case "$host" in if test "$GCC" = yes ; then SO_FLAGS="-fPIC $SO_FLAGS" SO_LD="$CC" - CFLAGS="$CFLAGS -Wno-format-truncation" +# CFLAGS="$CFLAGS -Wno-format-truncation" +# this gets a complaint from clang fi ;; diff --git a/debian/changelog b/debian/changelog index 324525e..d4215c2 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,12 @@ +snd (24.3-1) unstable; urgency=medium + + * New upstream version 24.3 + + Update d/upstream-changelog + * Update copyright information + + Re-generate d/copyright_hints + + -- IOhannes m zmölnig (Debian/GNU) <umlaeute@debian.org> Mon, 15 Apr 2024 09:00:56 +0200 + snd (24.2-1) unstable; urgency=medium * New upstream version 24.2 diff --git a/debian/copyright_hints b/debian/copyright_hints index 307e863..c7624c7 100644 --- a/debian/copyright_hints +++ b/debian/copyright_hints @@ -308,6 +308,7 @@ Files: HISTORY.Snd tools/tsort.scm tools/tstar.scm tools/tvect.scm + tools/utf8-tests.scm tools/va.scm tools/valcall.scm v.rb diff --git a/debian/upstream-changelog b/debian/upstream-changelog index 9c70750..a161b3b 100644 --- a/debian/upstream-changelog +++ b/debian/upstream-changelog @@ -1,3 +1,15 @@ +Snd 24.3: + +s7: format now always returns a string (where it used to return #f it + now returns "") +sam.c: bugfixes and improvements thanks to David Jaffe + +checked: sbcl 2.4.3 + +Thanks!: Michael Edwards, Norman Gray, David Jaffe + +=============================================================================== + Snd 24.2 mostly work on optimizations in s7 @@ -16,11 +16,11 @@ (unless (defined? '*libc*) (define *libc* - (with-let (unlet) + (with-let (sublet (unlet)) (set! *cload-library-name* "*libc*") (set! *libraries* (cons (cons "libc.scm" (curlet)) *libraries*)) - + ;; -------- stddef.h -------- (define NULL (c-pointer 0 'void*)) ;(define (c-null? p) (and (c-pointer? p) (zero? (car (c-pointer->list p))))) @@ -28,7 +28,7 @@ ;; -------- stdbool.h -------- ;(define false #f) ;(define true #t) - ;scheme objects like false or c-null in *libc* will not appear in *libc* normally: no s7_define -> shadow_rootlet, + ;scheme objects like false or c-null in *libc* will not appear in *libc* normally: no s7_define -> shadow_rootlet, ; and this file itself is not loaded except when libc_s7.c is written (when libc_s7.so is out of date) ;; -------- iso646.h -------- @@ -42,7 +42,7 @@ #| (define-expansion (assert assertion) (reader-cond ((not (defined? 'NDEBUG)) - `(if (not ,assertion) + `(if (not ,assertion) (error 'assert-failure "~S[~D]: ~A failed~%" (port-filename) (port-line-number) ',assertion))) (#t (values)))) @@ -58,47 +58,47 @@ ;; -------- sys/types.h inttypes.h getopt.h-------- ;; C type declarations - (c-define + (c-define '(;; -------- limits.h -------- - (C-macro (int (SCHAR_MIN SCHAR_MAX UCHAR_MAX CHAR_BIT CHAR_MIN CHAR_MAX __WORDSIZE + (C-macro (int (SCHAR_MIN SCHAR_MAX UCHAR_MAX CHAR_BIT CHAR_MIN CHAR_MAX __WORDSIZE SHRT_MIN SHRT_MAX USHRT_MAX INT_MIN INT_MAX UINT_MAX LONG_MIN LONG_MAX ULONG_MAX LLONG_MIN LLONG_MAX ULLONG_MAX - _POSIX_AIO_LISTIO_MAX _POSIX_AIO_MAX _POSIX_ARG_MAX _POSIX_CHILD_MAX _POSIX_DELAYTIMER_MAX _POSIX_HOST_NAME_MAX - _POSIX_LINK_MAX _POSIX_LOGIN_NAME_MAX _POSIX_MAX_CANON _POSIX_MAX_INPUT _POSIX_MQ_OPEN_MAX _POSIX_MQ_PRIO_MAX - _POSIX_NAME_MAX _POSIX_NGROUPS_MAX _POSIX_OPEN_MAX _POSIX_FD_SETSIZE _POSIX_PATH_MAX _POSIX_PIPE_BUF _POSIX_RE_DUP_MAX - _POSIX_RTSIG_MAX _POSIX_SEM_NSEMS_MAX _POSIX_SEM_VALUE_MAX _POSIX_SIGQUEUE_MAX _POSIX_SSIZE_MAX _POSIX_STREAM_MAX - _POSIX_SYMLINK_MAX _POSIX_SYMLOOP_MAX _POSIX_TIMER_MAX _POSIX_TTY_NAME_MAX _POSIX_TZNAME_MAX _POSIX_QLIMIT - _POSIX_HIWAT _POSIX_UIO_MAXIOV _POSIX_CLOCKRES_MIN SSIZE_MAX NGROUPS_MAX _POSIX2_BC_BASE_MAX _POSIX2_BC_DIM_MAX - _POSIX2_BC_SCALE_MAX _POSIX2_BC_STRING_MAX _POSIX2_COLL_WEIGHTS_MAX _POSIX2_EXPR_NEST_MAX _POSIX2_LINE_MAX - _POSIX2_RE_DUP_MAX _POSIX2_CHARCLASS_NAME_MAX BC_BASE_MAX BC_DIM_MAX BC_SCALE_MAX BC_STRING_MAX COLL_WEIGHTS_MAX + _POSIX_AIO_LISTIO_MAX _POSIX_AIO_MAX _POSIX_ARG_MAX _POSIX_CHILD_MAX _POSIX_DELAYTIMER_MAX _POSIX_HOST_NAME_MAX + _POSIX_LINK_MAX _POSIX_LOGIN_NAME_MAX _POSIX_MAX_CANON _POSIX_MAX_INPUT _POSIX_MQ_OPEN_MAX _POSIX_MQ_PRIO_MAX + _POSIX_NAME_MAX _POSIX_NGROUPS_MAX _POSIX_OPEN_MAX _POSIX_FD_SETSIZE _POSIX_PATH_MAX _POSIX_PIPE_BUF _POSIX_RE_DUP_MAX + _POSIX_RTSIG_MAX _POSIX_SEM_NSEMS_MAX _POSIX_SEM_VALUE_MAX _POSIX_SIGQUEUE_MAX _POSIX_SSIZE_MAX _POSIX_STREAM_MAX + _POSIX_SYMLINK_MAX _POSIX_SYMLOOP_MAX _POSIX_TIMER_MAX _POSIX_TTY_NAME_MAX _POSIX_TZNAME_MAX _POSIX_QLIMIT + _POSIX_HIWAT _POSIX_UIO_MAXIOV _POSIX_CLOCKRES_MIN SSIZE_MAX NGROUPS_MAX _POSIX2_BC_BASE_MAX _POSIX2_BC_DIM_MAX + _POSIX2_BC_SCALE_MAX _POSIX2_BC_STRING_MAX _POSIX2_COLL_WEIGHTS_MAX _POSIX2_EXPR_NEST_MAX _POSIX2_LINE_MAX + _POSIX2_RE_DUP_MAX _POSIX2_CHARCLASS_NAME_MAX BC_BASE_MAX BC_DIM_MAX BC_SCALE_MAX BC_STRING_MAX COLL_WEIGHTS_MAX EXPR_NEST_MAX LINE_MAX CHARCLASS_NAME_MAX RE_DUP_MAX))) - + ;; -------- float.h -------- (C-macro (int (FLT_RADIX FLT_MANT_DIG DBL_MANT_DIG LDBL_MANT_DIG FLT_DIG DBL_DIG LDBL_DIG FLT_MIN_EXP DBL_MIN_EXP LDBL_MIN_EXP FLT_MIN_10_EXP DBL_MIN_10_EXP LDBL_MIN_10_EXP FLT_MAX_EXP DBL_MAX_EXP LDBL_MAX_EXP FLT_MAX_10_EXP DBL_MAX_10_EXP LDBL_MAX_10_EXP FLT_ROUNDS FLT_EVAL_METHOD))) (C-macro (double (FLT_MAX DBL_MAX LDBL_MAX FLT_EPSILON DBL_EPSILON LDBL_EPSILON FLT_MIN DBL_MIN LDBL_MIN))) - - + + ;; -------- stdint.h -------- - (C-macro (int (INT8_MIN INT16_MIN INT32_MIN INT64_MIN INT8_MAX INT16_MAX INT32_MAX INT64_MAX UINT8_MAX UINT16_MAX - UINT32_MAX UINT64_MAX INT_LEAST8_MIN INT_LEAST16_MIN INT_LEAST32_MIN INT_LEAST64_MIN INT_LEAST8_MAX - INT_LEAST16_MAX INT_LEAST32_MAX INT_LEAST64_MAX UINT_LEAST8_MAX UINT_LEAST16_MAX UINT_LEAST32_MAX - UINT_LEAST64_MAX INT_FAST8_MIN INT_FAST16_MIN INT_FAST32_MIN INT_FAST64_MIN INT_FAST8_MAX INT_FAST16_MAX - INT_FAST32_MAX INT_FAST64_MAX UINT_FAST8_MAX UINT_FAST16_MAX UINT_FAST32_MAX UINT_FAST64_MAX INTPTR_MIN - INTPTR_MAX UINTPTR_MAX INTMAX_MIN INTMAX_MAX UINTMAX_MAX PTRDIFF_MIN PTRDIFF_MAX SIG_ATOMIC_MIN SIG_ATOMIC_MAX + (C-macro (int (INT8_MIN INT16_MIN INT32_MIN INT64_MIN INT8_MAX INT16_MAX INT32_MAX INT64_MAX UINT8_MAX UINT16_MAX + UINT32_MAX UINT64_MAX INT_LEAST8_MIN INT_LEAST16_MIN INT_LEAST32_MIN INT_LEAST64_MIN INT_LEAST8_MAX + INT_LEAST16_MAX INT_LEAST32_MAX INT_LEAST64_MAX UINT_LEAST8_MAX UINT_LEAST16_MAX UINT_LEAST32_MAX + UINT_LEAST64_MAX INT_FAST8_MIN INT_FAST16_MIN INT_FAST32_MIN INT_FAST64_MIN INT_FAST8_MAX INT_FAST16_MAX + INT_FAST32_MAX INT_FAST64_MAX UINT_FAST8_MAX UINT_FAST16_MAX UINT_FAST32_MAX UINT_FAST64_MAX INTPTR_MIN + INTPTR_MAX UINTPTR_MAX INTMAX_MIN INTMAX_MAX UINTMAX_MAX PTRDIFF_MIN PTRDIFF_MAX SIG_ATOMIC_MIN SIG_ATOMIC_MAX SIZE_MAX WCHAR_MIN WCHAR_MAX WINT_MIN WINT_MAX ))) - + (FILE* (stdin stdout stderr)) - + ;; -------- endian.h -------- ;; also has htobe16 etc (C-macro (int (__BYTE_ORDER __BIG_ENDIAN __LITTLE_ENDIAN))) - - + + (in-C " - static s7_pointer g_c_pointer_to_string(s7_scheme *sc, s7_pointer args) + static s7_pointer g_c_pointer_to_string(s7_scheme *sc, s7_pointer args) {return(s7_make_string_with_length(sc, (const char *)s7_c_pointer(s7_car(args)), s7_integer(s7_cadr(args))));} static s7_pointer g_string_to_c_pointer(s7_scheme *sc, s7_pointer args) { @@ -106,10 +106,10 @@ return(s7_make_c_pointer_with_type(sc, (void *)s7_string(s7_car(args)), s7_make_symbol(sc, \"void*\"), s7_f(sc))); return(s7_car(args)); }") - + (C-function ("c-pointer->string" g_c_pointer_to_string "" 2)) (C-function ("string->c-pointer" g_string_to_c_pointer "" 1)) - + ;; -------- ctype.h -------- (int isalnum (int)) (int isalpha (int)) @@ -126,12 +126,12 @@ (int toupper (int)) ;; -------- fcntl.h -------- - (C-macro (int (S_IFMT S_IFDIR S_IFCHR S_IFBLK S_IFREG S_IFIFO __S_IFLNK S_IFSOCK S_ISUID S_ISGID S_IRUSR - S_IWUSR S_IXUSR S_IRWXU S_IRGRP S_IWGRP S_IXGRP S_IRWXG S_IROTH S_IWOTH S_IXOTH S_IRWXO R_OK W_OK X_OK - F_OK SEEK_SET SEEK_CUR SEEK_END F_ULOCK F_LOCK F_TLOCK F_TEST O_ACCMODE O_RDONLY O_WRONLY O_RDWR O_CREAT - O_EXCL O_NOCTTY O_TRUNC O_APPEND O_NONBLOCK O_NDELAY O_SYNC O_FSYNC O_ASYNC O_DSYNC O_RSYNC O_LARGEFILE - F_DUPFD F_GETFD F_SETFD F_GETFL F_SETFL F_GETLK F_SETLK F_SETLKW F_GETLK64 F_SETLK64 F_SETLKW64 - FD_CLOEXEC F_RDLCK F_WRLCK F_UNLCK POSIX_FADV_NORMAL POSIX_FADV_RANDOM POSIX_FADV_SEQUENTIAL + (C-macro (int (S_IFMT S_IFDIR S_IFCHR S_IFBLK S_IFREG S_IFIFO __S_IFLNK S_IFSOCK S_ISUID S_ISGID S_IRUSR + S_IWUSR S_IXUSR S_IRWXU S_IRGRP S_IWGRP S_IXGRP S_IRWXG S_IROTH S_IWOTH S_IXOTH S_IRWXO R_OK W_OK X_OK + F_OK SEEK_SET SEEK_CUR SEEK_END F_ULOCK F_LOCK F_TLOCK F_TEST O_ACCMODE O_RDONLY O_WRONLY O_RDWR O_CREAT + O_EXCL O_NOCTTY O_TRUNC O_APPEND O_NONBLOCK O_NDELAY O_SYNC O_FSYNC O_ASYNC O_DSYNC O_RSYNC O_LARGEFILE + F_DUPFD F_GETFD F_SETFD F_GETFL F_SETFL F_GETLK F_SETLK F_SETLKW F_GETLK64 F_SETLK64 F_SETLKW64 + FD_CLOEXEC F_RDLCK F_WRLCK F_UNLCK POSIX_FADV_NORMAL POSIX_FADV_RANDOM POSIX_FADV_SEQUENTIAL POSIX_FADV_WILLNEED POSIX_FADV_DONTNEED POSIX_FADV_NOREUSE))) (int fcntl (int int)) (in-C " @@ -161,11 +161,11 @@ (C-function ("open" g_c_open "" 2 1)) (int creat (char* (mode_t int))) (int lockf (int int int)) - (reader-cond ((provided? 'linux) + (reader-cond ((provided? 'linux) (int posix_fadvise (int int int int)) (int posix_fallocate (int int int)))) - - + + ;; -------- fenv.h -------- (C-macro (int (FE_INEXACT FE_DIVBYZERO FE_UNDERFLOW FE_OVERFLOW FE_INVALID FE_ALL_EXCEPT FE_TONEAREST FE_UPWARD FE_DOWNWARD FE_TOWARDZERO))) @@ -182,17 +182,17 @@ (int feupdateenv (fenv_t*)) ;(C-macro (fenv_t* (FE_DFL_ENV))) (in-C " - static s7_pointer g_fenv_t_make(s7_scheme *sc, s7_pointer args) + static s7_pointer g_fenv_t_make(s7_scheme *sc, s7_pointer args) {return(s7_make_c_pointer_with_type(sc, (void *)calloc(1, sizeof(fenv_t)), s7_make_symbol(sc, \"fenv_t*\"), s7_f(sc)));}") (C-function ("fenv_t.make" g_fenv_t_make "" 0)) - - + + ;; -------- fnmatch.h -------- (C-macro (int (FNM_PATHNAME FNM_NOESCAPE FNM_PERIOD FNM_FILE_NAME FNM_LEADING_DIR FNM_CASEFOLD FNM_EXTMATCH FNM_NOMATCH))) (int fnmatch (char* char* int)) - - + + ;; -------- string.h -------- (void* memcpy (void* void* size_t)) (void* memmove (void* void* size_t)) @@ -220,9 +220,9 @@ (char* strerror (int)) (int strcasecmp (char* char*)) (int strncasecmp (char* char* size_t)) - + #| - (reader-cond + (reader-cond ((provided? 'linux) ;; -------- semaphore.h -------- (int sem_init (sem_t* int int)) @@ -234,11 +234,11 @@ (int sem_post (sem_t*)))) ;; not in clang?? |# - + ;; -------- stdio.h -------- (C-macro (int (_IOFBF _IOLBF _IONBF BUFSIZ EOF L_tmpnam TMP_MAX FILENAME_MAX L_ctermid L_cuserid FOPEN_MAX IOV_MAX))) (C-macro (char* P_tmpdir)) - + (int remove (char*)) (int rename (char* char*)) (FILE* tmpfile (void)) @@ -283,22 +283,22 @@ (void funlockfile (FILE*)) ;; int fprintf (FILE* char* ...) ;; int printf (char* ...) - ;; int sprintf (char* char* ...) + ;; int sprintf (char* char* ...) ;; int vfprintf (FILE* char* va_list) ;; int vprintf (char* va_list) - ;; int vsprintf (char* char* va_list) + ;; int vsprintf (char* char* va_list) ;; int snprintf (char* size_t char* ...) ;; int vsnprintf (char* size_t char* va_list) ;; int vasprintf (char** char* va_list) ;; int asprintf (char** char* ...) ;; int fscanf (FILE* char* ...) ;; int scanf (char* ...) - ;; int sscanf (char* char* ...) + ;; int sscanf (char* char* ...) ;; int vfscanf (FILE* char* va_list) ;; int vscanf (char* va_list) ;; int vsscanf (char* char* va_list) - - + + ;; -------- stdlib.h -------- (C-macro (int (RAND_MAX EXIT_FAILURE EXIT_SUCCESS MB_CUR_MAX))) (double atof (char*)) @@ -327,9 +327,9 @@ ; (char* realpath (char* char*)) (int abs (int)) (int labs (int)) - + (in-C " - static s7_pointer g_llabs(s7_scheme *sc, s7_pointer args) + static s7_pointer g_llabs(s7_scheme *sc, s7_pointer args) { #if ((__GNUC__) && ((__GNUC__ < 4) || ((__GNUC__ == 4) && (__GNUC_MINOR__ < 4)))) return(s7_make_integer(sc, labs(s7_integer(s7_car(args))))); @@ -349,11 +349,11 @@ } static s7_pointer g_free(s7_scheme *sc, s7_pointer args) {free(s7_c_pointer(s7_car(args))); return(s7_f(sc));} - static s7_pointer g_strtod(s7_scheme *sc, s7_pointer args) + static s7_pointer g_strtod(s7_scheme *sc, s7_pointer args) {return(s7_make_real(sc, strtod(s7_string(s7_car(args)), NULL)));} - static s7_pointer g_strtof(s7_scheme *sc, s7_pointer args) + static s7_pointer g_strtof(s7_scheme *sc, s7_pointer args) {return(s7_make_real(sc, strtof(s7_string(s7_car(args)), NULL)));} - static s7_pointer g_strtol(s7_scheme *sc, s7_pointer args) + static s7_pointer g_strtol(s7_scheme *sc, s7_pointer args) {return(s7_make_integer(sc, strtol(s7_string(s7_car(args)), NULL, s7_integer(s7_cadr(args)))));} static s7_pointer g_strtoll(s7_scheme *sc, s7_pointer args) {return(s7_make_integer(sc, strtoll(s7_string(s7_car(args)), NULL, s7_integer(s7_cadr(args)))));} @@ -375,8 +375,8 @@ (C-function ("div" g_ldiv "" 2)) (C-function ("ldiv" g_ldiv "" 2)) (C-function ("realpath" g_realpath "" 2)) - - + + ;; -------- errno.h -------- ;; pws for errno? (C-macro (int (__GLIBC__ __GLIBC_MINOR__ ; features.h from errno.h @@ -391,10 +391,10 @@ static s7_pointer g_set_errno(s7_scheme *sc, s7_pointer args) {errno = (int)s7_integer(s7_car(args)); return(s7_car(args));}") (C-function ("errno" g_errno "" 0)) (C-function ("set_errno" g_set_errno "" 1)) - - + + ;; -------- locale.h -------- - (C-macro (int (LC_CTYPE LC_NUMERIC LC_TIME LC_COLLATE LC_MONETARY LC_MESSAGES LC_ALL LC_PAPER LC_NAME + (C-macro (int (LC_CTYPE LC_NUMERIC LC_TIME LC_COLLATE LC_MONETARY LC_MESSAGES LC_ALL LC_PAPER LC_NAME LC_ADDRESS LC_TELEPHONE LC_MEASUREMENT LC_IDENTIFICATION))) (char* setlocale (int char*)) (in-C " @@ -413,7 +413,7 @@ s7_make_symbol(sc, \"mon_grouping\"), s7_make_string(sc, lc->mon_grouping), s7_make_symbol(sc, \"positive_sign\"), s7_make_string(sc, lc->positive_sign), s7_make_symbol(sc, \"negative_sign\"), s7_make_string(sc, lc->negative_sign), - + s7_make_symbol(sc, \"int_frac_digits\"), s7_make_integer(sc, lc->int_frac_digits), s7_make_symbol(sc, \"frac_digits\"), s7_make_integer(sc, lc->frac_digits), s7_make_symbol(sc, \"p_cs_precedes\"), s7_make_integer(sc, lc->p_cs_precedes), @@ -424,37 +424,37 @@ s7_make_symbol(sc, \"n_sign_posn\"), s7_make_integer(sc, lc->n_sign_posn)))); }") (C-function ("localeconv" g_localeconv "" 0)) - - + + ;; -------- sys/utsname.h -------- (in-C " static s7_pointer g_uname(s7_scheme *sc, s7_pointer args) { struct utsname buf; uname(&buf); - return(s7_list(sc, 5, s7_make_string(sc, buf.sysname), - s7_make_string(sc, buf.machine), - s7_make_string(sc, buf.nodename), - s7_make_string(sc, buf.version), + return(s7_list(sc, 5, s7_make_string(sc, buf.sysname), + s7_make_string(sc, buf.machine), + s7_make_string(sc, buf.nodename), + s7_make_string(sc, buf.version), s7_make_string(sc, buf.release))); }") (C-function ("uname" g_uname "" 0)) - - - ;; -------- unistd.h -------- + + + ;; -------- unistd.h -------- (C-macro (int (_POSIX_VERSION _POSIX2_VERSION _POSIX_JOB_CONTROL _POSIX_SAVED_IDS _POSIX_PRIORITY_SCHEDULING _POSIX_SYNCHRONIZED_IO _POSIX_FSYNC _POSIX_MAPPED_FILES _POSIX_MEMLOCK _POSIX_MEMLOCK_RANGE _POSIX_MEMORY_PROTECTION _POSIX_CHOWN_RESTRICTED _POSIX_VDISABLE _POSIX_NO_TRUNC _POSIX_THREADS _POSIX_REENTRANT_FUNCTIONS _POSIX_THREAD_SAFE_FUNCTIONS _POSIX_THREAD_PRIORITY_SCHEDULING _POSIX_THREAD_ATTR_STACKSIZE _POSIX_THREAD_ATTR_STACKADDR _POSIX_THREAD_PRIO_INHERIT _POSIX_THREAD_PRIO_PROTECT _POSIX_SEMAPHORES _POSIX_REALTIME_SIGNALS _POSIX_ASYNCHRONOUS_IO _POSIX_ASYNC_IO _POSIX_PRIORITIZED_IO _POSIX_SHARED_MEMORY_OBJECTS _POSIX_CPUTIME _POSIX_THREAD_CPUTIME _POSIX_REGEXP - _POSIX_READER_WRITER_LOCKS _POSIX_SHELL _POSIX_TIMEOUTS _POSIX_SPIN_LOCKS _POSIX_SPAWN _POSIX_TIMERS + _POSIX_READER_WRITER_LOCKS _POSIX_SHELL _POSIX_TIMEOUTS _POSIX_SPIN_LOCKS _POSIX_SPAWN _POSIX_TIMERS _POSIX_BARRIERS _POSIX_MESSAGE_PASSING _POSIX_THREAD_PROCESS_SHARED _POSIX_MONOTONIC_CLOCK _POSIX_CLOCK_SELECTION _POSIX_ADVISORY_INFO _POSIX_IPV6 _POSIX_RAW_SOCKETS _POSIX2_CHAR_TERM _POSIX_SPORADIC_SERVER _POSIX_THREAD_SPORADIC_SERVER - _POSIX_TRACE _POSIX_TRACE_EVENT_FILTER _POSIX_TRACE_INHERIT _POSIX_TRACE_LOG _POSIX_TYPED_MEMORY_OBJECTS + _POSIX_TRACE _POSIX_TRACE_EVENT_FILTER _POSIX_TRACE_INHERIT _POSIX_TRACE_LOG _POSIX_TYPED_MEMORY_OBJECTS STDIN_FILENO STDOUT_FILENO STDERR_FILENO))) - - (C-macro + + (C-macro (int (_PC_LINK_MAX _PC_MAX_CANON _PC_MAX_INPUT _PC_NAME_MAX _PC_PATH_MAX _PC_PIPE_BUF _PC_CHOWN_RESTRICTED _PC_NO_TRUNC _PC_VDISABLE _PC_SYNC_IO _PC_ASYNC_IO _PC_PRIO_IO _PC_SOCK_MAXBUF _PC_FILESIZEBITS _PC_REC_INCR_XFER_SIZE _PC_REC_MAX_XFER_SIZE _PC_REC_MIN_XFER_SIZE _PC_REC_XFER_ALIGN _PC_ALLOC_SIZE_MIN _PC_SYMLINK_MAX _PC_2_SYMLINKS _SC_ARG_MAX _SC_CHILD_MAX _SC_CLK_TCK @@ -464,11 +464,11 @@ _SC_DELAYTIMER_MAX _SC_MQ_OPEN_MAX _SC_MQ_PRIO_MAX _SC_VERSION _SC_PAGESIZE _SC_PAGE_SIZE _SC_RTSIG_MAX _SC_SEM_NSEMS_MAX _SC_SEM_VALUE_MAX _SC_SIGQUEUE_MAX _SC_TIMER_MAX _SC_BC_BASE_MAX _SC_BC_DIM_MAX _SC_BC_SCALE_MAX _SC_BC_STRING_MAX _SC_COLL_WEIGHTS_MAX _SC_EQUIV_CLASS_MAX _SC_EXPR_NEST_MAX _SC_LINE_MAX _SC_RE_DUP_MAX _SC_CHARCLASS_NAME_MAX _SC_2_VERSION _SC_2_C_BIND _SC_2_C_DEV _SC_2_FORT_DEV _SC_2_FORT_RUN - _SC_2_SW_DEV _SC_2_LOCALEDEF _SC_PII _SC_PII_XTI _SC_PII_SOCKET _SC_PII_INTERNET _SC_PII_OSI _SC_POLL _SC_SELECT _SC_UIO_MAXIOV + _SC_2_SW_DEV _SC_2_LOCALEDEF _SC_PII _SC_PII_XTI _SC_PII_SOCKET _SC_PII_INTERNET _SC_PII_OSI _SC_POLL _SC_SELECT _SC_UIO_MAXIOV _SC_IOV_MAX _SC_PII_INTERNET_STREAM _SC_PII_INTERNET_DGRAM _SC_PII_OSI_COTS _SC_PII_OSI_CLTS _SC_PII_OSI_M _SC_T_IOV_MAX _SC_THREADS - _SC_THREAD_SAFE_FUNCTIONS _SC_GETGR_R_SIZE_MAX _SC_GETPW_R_SIZE_MAX _SC_LOGIN_NAME_MAX _SC_TTY_NAME_MAX _SC_THREAD_DESTRUCTOR_ITERATIONS - _SC_THREAD_KEYS_MAX _SC_THREAD_STACK_MIN _SC_THREAD_THREADS_MAX _SC_THREAD_ATTR_STACKADDR _SC_THREAD_ATTR_STACKSIZE - _SC_THREAD_PRIO_INHERIT _SC_THREAD_PRIO_PROTECT _SC_THREAD_PROCESS_SHARED _SC_NPROCESSORS_CONF _SC_NPROCESSORS_ONLN _SC_PHYS_PAGES + _SC_THREAD_SAFE_FUNCTIONS _SC_GETGR_R_SIZE_MAX _SC_GETPW_R_SIZE_MAX _SC_LOGIN_NAME_MAX _SC_TTY_NAME_MAX _SC_THREAD_DESTRUCTOR_ITERATIONS + _SC_THREAD_KEYS_MAX _SC_THREAD_STACK_MIN _SC_THREAD_THREADS_MAX _SC_THREAD_ATTR_STACKADDR _SC_THREAD_ATTR_STACKSIZE + _SC_THREAD_PRIO_INHERIT _SC_THREAD_PRIO_PROTECT _SC_THREAD_PROCESS_SHARED _SC_NPROCESSORS_CONF _SC_NPROCESSORS_ONLN _SC_PHYS_PAGES _SC_AVPHYS_PAGES _SC_ATEXIT_MAX _SC_PASS_MAX _SC_2_CHAR_TERM _SC_2_C_VERSION _SC_2_UPE _SC_CHAR_BIT _SC_CHAR_MAX _SC_CHAR_MIN _SC_INT_MAX _SC_INT_MIN _SC_LONG_BIT _SC_WORD_BIT _SC_MB_LEN_MAX _SC_NZERO _SC_SSIZE_MAX _SC_SCHAR_MAX _SC_SCHAR_MIN _SC_SHRT_MAX _SC_SHRT_MIN _SC_UCHAR_MAX _SC_UINT_MAX _SC_ULONG_MAX _SC_USHRT_MAX _SC_NL_ARGMAX _SC_NL_LANGMAX _SC_NL_MSGMAX _SC_NL_NMAX _SC_NL_SETMAX @@ -479,12 +479,12 @@ _SC_SYSTEM_DATABASE _SC_SYSTEM_DATABASE_R _SC_TIMEOUTS _SC_TYPED_MEMORY_OBJECTS _SC_USER_GROUPS _SC_USER_GROUPS_R _SC_2_PBS _SC_2_PBS_ACCOUNTING _SC_2_PBS_LOCATE _SC_2_PBS_MESSAGE _SC_2_PBS_TRACK _SC_SYMLOOP_MAX _SC_STREAMS _SC_2_PBS_CHECKPOINT _SC_HOST_NAME_MAX _SC_TRACE _SC_TRACE_EVENT_FILTER _SC_TRACE_INHERIT _SC_TRACE_LOG _SC_LEVEL1_ICACHE_SIZE _SC_LEVEL1_ICACHE_ASSOC - _SC_LEVEL1_ICACHE_LINESIZE _SC_LEVEL1_DCACHE_SIZE _SC_LEVEL1_DCACHE_ASSOC _SC_LEVEL1_DCACHE_LINESIZE _SC_LEVEL2_CACHE_SIZE - _SC_LEVEL2_CACHE_LINESIZE _SC_LEVEL3_CACHE_SIZE _SC_LEVEL3_CACHE_ASSOC _SC_LEVEL3_CACHE_LINESIZE _SC_LEVEL4_CACHE_SIZE + _SC_LEVEL1_ICACHE_LINESIZE _SC_LEVEL1_DCACHE_SIZE _SC_LEVEL1_DCACHE_ASSOC _SC_LEVEL1_DCACHE_LINESIZE _SC_LEVEL2_CACHE_SIZE + _SC_LEVEL2_CACHE_LINESIZE _SC_LEVEL3_CACHE_SIZE _SC_LEVEL3_CACHE_ASSOC _SC_LEVEL3_CACHE_LINESIZE _SC_LEVEL4_CACHE_SIZE _SC_LEVEL4_CACHE_LINESIZE _SC_IPV6 _SC_RAW_SOCKETS _SC_SS_REPL_MAX _SC_TRACE_EVENT_NAME_MAX _SC_TRACE_NAME_MAX _SC_TRACE_SYS_MAX - _SC_TRACE_USER_EVENT_MAX _SC_THREAD_ROBUST_PRIO_INHERIT _SC_THREAD_ROBUST_PRIO_PROTECT _CS_PATH _CS_GNU_LIBC_VERSION + _SC_TRACE_USER_EVENT_MAX _SC_THREAD_ROBUST_PRIO_INHERIT _SC_THREAD_ROBUST_PRIO_PROTECT _CS_PATH _CS_GNU_LIBC_VERSION _SC_THREAD_PRIORITY_SCHEDULING _SC_LEVEL2_CACHE_ASSOC _SC_LEVEL4_CACHE_ASSOC _CS_GNU_LIBPTHREAD_VERSION))) - + (int access (char* int)) (int lseek (int int int)) (int close (int)) @@ -530,9 +530,9 @@ (char* getlogin (void)) (int truncate (char* int)) (int ftruncate (int int)) - + (in-C " - extern char **environ; + extern char **environ; static s7_pointer getenvs(s7_scheme *sc, s7_pointer args) { s7_pointer p; @@ -572,7 +572,7 @@ ") (C-function ("getenvs" getenvs "(getenvs) returns all the environment variables in an alist" 0)) (C-function ("getgroups" g_getgroups "" 1)) - + ;; perhaps call these as (define* n (path ...) = args? and use execve for all? ;; but are these useful in this context? How is fork used here? ;; int execve (char* path char* argv[] char* envp[]) @@ -581,41 +581,41 @@ ;; int execl (char* path char* arg ...) ;; int execvp (char* file char* argv[]) ;; int execlp (char* file char* arg ...) - - + + ;; -------- dirent.h -------- (DIR* opendir (char*)) (int closedir (DIR*)) (void rewinddir (DIR*)) (in-C " static char *read_dir(DIR *p) - { - struct dirent *dirp; - dirp = readdir(p); - if (!dirp) return(NULL); - else return(dirp->d_name); + { + struct dirent *dirp; + dirp = readdir(p); + if (!dirp) return(NULL); + else return(dirp->d_name); }") (char* read_dir (DIR*)) ;; int scandir (char* dirent*** func func) ;; int alphasort (dirent** dirent**) - - + + ;; -------- ftw.h -------- (C-macro (int (FTW_F FTW_D FTW_DNR FTW_NS))) (in-C " static s7_scheme *internal_ftw_sc = NULL; static s7_pointer internal_ftw_closure = NULL, internal_ftw_arglist = NULL; - + static int internal_ftw_function(const char *fpath, const struct stat *sb, int typeflag) { s7_list_set(internal_ftw_sc, internal_ftw_arglist, 0, s7_make_string(internal_ftw_sc, fpath)); - s7_list_set(internal_ftw_sc, internal_ftw_arglist, 1, + s7_list_set(internal_ftw_sc, internal_ftw_arglist, 1, s7_make_c_pointer_with_type(internal_ftw_sc, (void *)sb, /* need cast due to const */ s7_make_symbol(internal_ftw_sc, \"stat*\"), s7_f(internal_ftw_sc))); s7_list_set(internal_ftw_sc, internal_ftw_arglist, 2, s7_make_integer(internal_ftw_sc, typeflag)); return((int)s7_integer(s7_call(internal_ftw_sc, internal_ftw_closure, internal_ftw_arglist))); } - + static s7_pointer g_ftw(s7_scheme *sc, s7_pointer args) { /* ftw(file-name, function(path, stat, type), nopenfd=max open dirs) */ @@ -626,77 +626,77 @@ return(s7_make_integer(sc, ftw(s7_string(s7_car(args)), internal_ftw_function, s7_integer(s7_caddr(args))))); }") (C-function ("ftw" g_ftw "" 3)) - - + + ;; -------- sys/stat.h -------- (C-macro (int S_IFLNK)) - + (in-C " static s7_pointer g_stat(s7_scheme *sc, s7_pointer args) - {return(s7_make_integer(sc, stat(s7_string(s7_car(args)), + {return(s7_make_integer(sc, stat(s7_string(s7_car(args)), (struct stat *)s7_c_pointer_with_type(sc, s7_cadr(args), s7_make_symbol(sc, \"stat*\"), __func__, 1))));} static s7_pointer g_fstat(s7_scheme *sc, s7_pointer args) - {return(s7_make_integer(sc, fstat(s7_integer(s7_car(args)), + {return(s7_make_integer(sc, fstat(s7_integer(s7_car(args)), (struct stat *)s7_c_pointer_with_type(sc, s7_cadr(args), s7_make_symbol(sc, \"stat*\"), __func__, 1))));} static s7_pointer g_lstat(s7_scheme *sc, s7_pointer args) - {return(s7_make_integer(sc, lstat(s7_string(s7_car(args)), + {return(s7_make_integer(sc, lstat(s7_string(s7_car(args)), (struct stat *)s7_c_pointer_with_type(sc, s7_cadr(args), s7_make_symbol(sc, \"stat*\"), __func__, 1))));} ") (C-function ("stat" g_stat "" 2)) (C-function ("fstat" g_fstat "" 2)) (C-function ("lstat" g_lstat "" 2)) - + (int chmod (char* int)) (int mkdir (char* int)) (int mknod (char* int int)) (int mkfifo (char* int)) - + (in-C " - static s7_pointer g_isdir(s7_scheme *sc, s7_pointer args) + static s7_pointer g_isdir(s7_scheme *sc, s7_pointer args) {return(s7_make_boolean(sc, S_ISDIR(s7_integer(s7_car(args)))));} - static s7_pointer g_ischr(s7_scheme *sc, s7_pointer args) + static s7_pointer g_ischr(s7_scheme *sc, s7_pointer args) {return(s7_make_boolean(sc, S_ISCHR(s7_integer(s7_car(args)))));} - static s7_pointer g_isblk(s7_scheme *sc, s7_pointer args) + static s7_pointer g_isblk(s7_scheme *sc, s7_pointer args) {return(s7_make_boolean(sc, S_ISBLK(s7_integer(s7_car(args)))));} - static s7_pointer g_isreg(s7_scheme *sc, s7_pointer args) + static s7_pointer g_isreg(s7_scheme *sc, s7_pointer args) {return(s7_make_boolean(sc, S_ISREG(s7_integer(s7_car(args)))));} - static s7_pointer g_isfifo(s7_scheme *sc, s7_pointer args) + static s7_pointer g_isfifo(s7_scheme *sc, s7_pointer args) {return(s7_make_boolean(sc, S_ISFIFO(s7_integer(s7_car(args)))));} - static s7_pointer g_islnk(s7_scheme *sc, s7_pointer args) + static s7_pointer g_islnk(s7_scheme *sc, s7_pointer args) {return(s7_make_boolean(sc, S_ISLNK(s7_integer(s7_car(args)))));} - static s7_pointer g_issock(s7_scheme *sc, s7_pointer args) + static s7_pointer g_issock(s7_scheme *sc, s7_pointer args) {return(s7_make_boolean(sc, S_ISSOCK(s7_integer(s7_car(args)))));} - static s7_pointer g_st_dev(s7_scheme *sc, s7_pointer args) + static s7_pointer g_st_dev(s7_scheme *sc, s7_pointer args) {return(s7_make_integer(sc, ((struct stat *)s7_c_pointer_with_type(sc, s7_car(args), s7_make_symbol(sc, \"stat*\"), __func__, 1))->st_dev));} - static s7_pointer g_st_ino(s7_scheme *sc, s7_pointer args) + static s7_pointer g_st_ino(s7_scheme *sc, s7_pointer args) {return(s7_make_integer(sc, ((struct stat *)s7_c_pointer_with_type(sc, s7_car(args), s7_make_symbol(sc, \"stat*\"), __func__, 1))->st_ino));} - static s7_pointer g_st_mode(s7_scheme *sc, s7_pointer args) + static s7_pointer g_st_mode(s7_scheme *sc, s7_pointer args) {return(s7_make_integer(sc, ((struct stat *)s7_c_pointer_with_type(sc, s7_car(args), s7_make_symbol(sc, \"stat*\"), __func__, 1))->st_mode));} - static s7_pointer g_st_nlink(s7_scheme *sc, s7_pointer args) + static s7_pointer g_st_nlink(s7_scheme *sc, s7_pointer args) {return(s7_make_integer(sc, ((struct stat *)s7_c_pointer_with_type(sc, s7_car(args), s7_make_symbol(sc, \"stat*\"), __func__, 1))->st_nlink));} - static s7_pointer g_st_uid(s7_scheme *sc, s7_pointer args) + static s7_pointer g_st_uid(s7_scheme *sc, s7_pointer args) {return(s7_make_integer(sc, ((struct stat *)s7_c_pointer_with_type(sc, s7_car(args), s7_make_symbol(sc, \"stat*\"), __func__, 1))->st_uid));} - static s7_pointer g_st_gid(s7_scheme *sc, s7_pointer args) + static s7_pointer g_st_gid(s7_scheme *sc, s7_pointer args) {return(s7_make_integer(sc, ((struct stat *)s7_c_pointer_with_type(sc, s7_car(args), s7_make_symbol(sc, \"stat*\"), __func__, 1))->st_gid));} - static s7_pointer g_st_rdev(s7_scheme *sc, s7_pointer args) + static s7_pointer g_st_rdev(s7_scheme *sc, s7_pointer args) {return(s7_make_integer(sc, ((struct stat *)s7_c_pointer_with_type(sc, s7_car(args), s7_make_symbol(sc, \"stat*\"), __func__, 1))->st_rdev));} - static s7_pointer g_st_size(s7_scheme *sc, s7_pointer args) + static s7_pointer g_st_size(s7_scheme *sc, s7_pointer args) {return(s7_make_integer(sc, ((struct stat *)s7_c_pointer_with_type(sc, s7_car(args), s7_make_symbol(sc, \"stat*\"), __func__, 1))->st_size));} - static s7_pointer g_st_blksize(s7_scheme *sc, s7_pointer args) + static s7_pointer g_st_blksize(s7_scheme *sc, s7_pointer args) {return(s7_make_integer(sc, ((struct stat *)s7_c_pointer_with_type(sc, s7_car(args), s7_make_symbol(sc, \"stat*\"), __func__, 1))->st_blksize));} - static s7_pointer g_st_blocks(s7_scheme *sc, s7_pointer args) + static s7_pointer g_st_blocks(s7_scheme *sc, s7_pointer args) {return(s7_make_integer(sc, ((struct stat *)s7_c_pointer_with_type(sc, s7_car(args), s7_make_symbol(sc, \"stat*\"), __func__, 1))->st_blocks));} - static s7_pointer g_st_atime(s7_scheme *sc, s7_pointer args) + static s7_pointer g_st_atime(s7_scheme *sc, s7_pointer args) {return(s7_make_integer(sc, ((struct stat *)s7_c_pointer_with_type(sc, s7_car(args), s7_make_symbol(sc, \"stat*\"), __func__, 1))->st_atime));} - static s7_pointer g_st_mtime(s7_scheme *sc, s7_pointer args) + static s7_pointer g_st_mtime(s7_scheme *sc, s7_pointer args) {return(s7_make_integer(sc, ((struct stat *)s7_c_pointer_with_type(sc, s7_car(args), s7_make_symbol(sc, \"stat*\"), __func__, 1))->st_mtime));} - static s7_pointer g_st_ctime(s7_scheme *sc, s7_pointer args) + static s7_pointer g_st_ctime(s7_scheme *sc, s7_pointer args) {return(s7_make_integer(sc, ((struct stat *)s7_c_pointer_with_type(sc, s7_car(args), s7_make_symbol(sc, \"stat*\"), __func__, 1))->st_ctime));} static s7_pointer g_stat_make(s7_scheme *sc, s7_pointer args) {return(s7_make_c_pointer_with_type(sc, (void *)calloc(1, sizeof(struct stat)), s7_make_symbol(sc, \"stat*\"), s7_f(sc)));} static s7_pointer g_stat_free(s7_scheme *sc, s7_pointer args) {free(s7_c_pointer(s7_car(args))); return(s7_f(sc));} ") - + (C-function ("S_ISDIR" g_isdir "" 1)) (C-function ("S_ISCHR" g_ischr "" 1)) (C-function ("S_ISBLK" g_isblk "" 1)) @@ -704,7 +704,7 @@ (C-function ("S_ISFIFO" g_isfifo "" 1)) (C-function ("S_ISLNK" g_islnk "" 1)) (C-function ("S_ISSOCK" g_issock "" 1)) - + (C-function ("stat.st_dev" g_st_dev "" 1)) (C-function ("stat.st_ino" g_st_ino "" 1)) (C-function ("stat.st_mode" g_st_mode "" 1)) @@ -720,25 +720,25 @@ (C-function ("stat.st_ctime" g_st_ctime "" 1)) (C-function ("stat.free" g_stat_free "" 1)) (C-function ("stat.make" g_stat_make "" 0)) - - + + ;; -------- time.h sys/time.h -------- - (C-macro (int (CLOCKS_PER_SEC CLOCK_REALTIME CLOCK_MONOTONIC CLOCK_PROCESS_CPUTIME_ID CLOCK_THREAD_CPUTIME_ID + (C-macro (int (CLOCKS_PER_SEC CLOCK_REALTIME CLOCK_MONOTONIC CLOCK_PROCESS_CPUTIME_ID CLOCK_THREAD_CPUTIME_ID CLOCK_MONOTONIC_RAW CLOCK_REALTIME_COARSE CLOCK_MONOTONIC_COARSE))) ; also CLOCK_TAI in linux (int clock (void)) - + (int time (time_t*)) (double difftime ((time_t integer) (time_t integer))) (tm* gmtime (time_t*)) (char* ctime (time_t*)) (tm* localtime (time_t*)) - + (in-C " - static s7_pointer g_mktime(s7_scheme *sc, s7_pointer args) + static s7_pointer g_mktime(s7_scheme *sc, s7_pointer args) { return(s7_make_integer(sc, (s7_int)mktime((struct tm *)s7_c_pointer(s7_car(args))))); } - static s7_pointer g_time_make(s7_scheme *sc, s7_pointer args) + static s7_pointer g_time_make(s7_scheme *sc, s7_pointer args) { time_t *tm; tm = (time_t *)calloc(1, sizeof(time_t)); @@ -746,11 +746,11 @@ return(s7_make_c_pointer_with_type(sc, (void *)tm, s7_make_symbol(sc, \"time_t*\"), s7_f(sc))); } static s7_pointer g_time_free(s7_scheme *sc, s7_pointer args) {free(s7_c_pointer(s7_car(args))); return(s7_f(sc));} - static s7_pointer g_strftime(s7_scheme *sc, s7_pointer args) + static s7_pointer g_strftime(s7_scheme *sc, s7_pointer args) { - return(s7_make_integer(sc, (s7_int)strftime((char *)s7_string(s7_car(args)), - (size_t)s7_integer(s7_cadr(args)), - s7_string(s7_caddr(args)), + return(s7_make_integer(sc, (s7_int)strftime((char *)s7_string(s7_car(args)), + (size_t)s7_integer(s7_cadr(args)), + s7_string(s7_caddr(args)), (const struct tm *)s7_c_pointer(s7_cadddr(args))))); } static s7_pointer g_gettimeofday(s7_scheme *sc, s7_pointer args) @@ -832,8 +832,8 @@ (C-function ("clock_settime" g_clock_settime "" 3)) (reader-cond ((not (provided? 'solaris)) (C-function ("clock_getcpuclockid" g_clock_getcpuclockid "" 1)))) (C-function ("clock_nanosleep" g_clock_nanosleep "" 4)) - - + + ;; -------- utime.h -------- (in-C " static s7_pointer g_utime(s7_scheme *sc, s7_pointer args) @@ -844,20 +844,20 @@ return(s7_make_integer(sc, utime(s7_string(s7_car(args)), &tb))); }") (C-function ("utime" g_utime "" 3)) - - + + ;; -------- termios.h -------- - (C-macro (int (VINTR VQUIT VERASE VKILL VEOF VTIME VMIN VSWTC VSTART VSTOP VSUSP VEOL VREPRINT - VDISCARD VWERASE VLNEXT VEOL2 IGNBRK BRKINT IGNPAR PARMRK INPCK ISTRIP INLCR - IGNCR ICRNL IUCLC IXON IXANY IXOFF IMAXBEL IUTF8 OPOST OLCUC ONLCR OCRNL ONOCR - ONLRET OFILL OFDEL ISIG ICANON ECHO ECHOE ECHOK ECHONL NOFLSH TOSTOP IEXTEN + (C-macro (int (VINTR VQUIT VERASE VKILL VEOF VTIME VMIN VSWTC VSTART VSTOP VSUSP VEOL VREPRINT + VDISCARD VWERASE VLNEXT VEOL2 IGNBRK BRKINT IGNPAR PARMRK INPCK ISTRIP INLCR + IGNCR ICRNL IUCLC IXON IXANY IXOFF IMAXBEL IUTF8 OPOST OLCUC ONLCR OCRNL ONOCR + ONLRET OFILL OFDEL ISIG ICANON ECHO ECHOE ECHOK ECHONL NOFLSH TOSTOP IEXTEN TCOOFF TCOON TCIOFF TCION TCIFLUSH TCOFLUSH TCIOFLUSH TCSANOW TCSADRAIN TCSAFLUSH))) - + (int tcsendbreak (int int)) (int tcdrain (int)) (int tcflush (int int)) (int tcflow (int int)) - + (in-C " static s7_pointer g_cfgetospeed(s7_scheme *sc, s7_pointer args) { @@ -921,7 +921,7 @@ ") ;; tcflag_t c_iflag, c_oflag, c_cflag; cc_t c_line; ;; cc_t c_cc[NCCS]; - + (C-function ("cfgetospeed" g_cfgetospeed "" 1)) (C-function ("cfgetispeed" g_cfgetispeed "" 1)) (C-function ("cfsetospeed" g_cfsetospeed "" 2)) @@ -932,31 +932,31 @@ (C-function ("termios.c_lflag" g_termios_c_lflag "" 1)) (C-function ("termios.set_c_lflag" g_termios_set_c_lflag "" 2)) (C-function ("termios.set_c_cc" g_termios_set_c_cc "" 3)) - - + + ;; -------- grp.h -------- (in-C " static s7_pointer g_getgrgid(s7_scheme *sc, s7_pointer args) {return(s7_make_c_pointer_with_type(sc, getgrgid(s7_integer(s7_car(args))), s7_make_symbol(sc, \"group*\"), s7_f(sc)));} static s7_pointer g_getgrnam(s7_scheme *sc, s7_pointer args) {return(s7_make_c_pointer_with_type(sc, getgrnam(s7_string(s7_car(args))), s7_make_symbol(sc, \"group*\"), s7_f(sc)));} - static s7_pointer g_group_gr_name(s7_scheme *sc, s7_pointer args) + static s7_pointer g_group_gr_name(s7_scheme *sc, s7_pointer args) { - struct group *g; + struct group *g; g = (struct group *)s7_c_pointer_with_type(sc, s7_car(args), s7_make_symbol(sc, \"group*\"), __func__, 1); if (!g) return(s7_make_string(sc, \"\")); return(s7_make_string(sc, ((struct group *)g)->gr_name)); } - static s7_pointer g_group_gr_passwd(s7_scheme *sc, s7_pointer args) + static s7_pointer g_group_gr_passwd(s7_scheme *sc, s7_pointer args) { - struct group *g; + struct group *g; g = (struct group *)s7_c_pointer_with_type(sc, s7_car(args), s7_make_symbol(sc, \"group*\"), __func__, 1); if (!g) return(s7_make_string(sc, \"\")); return(s7_make_string(sc, ((struct group *)s7_c_pointer_with_type(sc, s7_car(args), s7_make_symbol(sc, \"group*\"), __func__, 1))->gr_passwd)); } - static s7_pointer g_group_gr_gid(s7_scheme *sc, s7_pointer args) + static s7_pointer g_group_gr_gid(s7_scheme *sc, s7_pointer args) { - struct group *g; + struct group *g; g = (struct group *)s7_c_pointer_with_type(sc, s7_car(args), s7_make_symbol(sc, \"group*\"), __func__, 1); if (!g) return(s7_make_integer(sc, -1)); return(s7_make_integer(sc, (s7_int)(((struct group *)s7_c_pointer_with_type(sc, s7_car(args), s7_make_symbol(sc, \"group*\"), __func__, 1))->gr_gid))); @@ -982,8 +982,8 @@ ;; ((*libc* 'group.gr_name) ((*libc* 'getgrnam) "wheel")) -> "wheel" (if any) ;; ((*libc* 'group.gr_name) ((*libc* 'getgrgid) 0)) -> "root" ;; ((*libc* 'group.gr_gid) ((*libc* 'getgrnam) "root")) -> 0 - - + + ;; -------- pwd.h -------- (C-macro (int NSS_BUFLEN_PASSWD)) (void setpwent (void)) @@ -992,19 +992,19 @@ (passwd* getpwuid (int)) (passwd* getpwnam (char*)) (in-C " - static s7_pointer g_passwd_pw_name(s7_scheme *sc, s7_pointer args) + static s7_pointer g_passwd_pw_name(s7_scheme *sc, s7_pointer args) {return(s7_make_string(sc, ((struct passwd *)s7_c_pointer_with_type(sc, s7_car(args), s7_make_symbol(sc, \"passwd*\"), __func__, 1))->pw_name));} - static s7_pointer g_passwd_pw_passwd(s7_scheme *sc, s7_pointer args) + static s7_pointer g_passwd_pw_passwd(s7_scheme *sc, s7_pointer args) {return(s7_make_string(sc, ((struct passwd *)s7_c_pointer_with_type(sc, s7_car(args), s7_make_symbol(sc, \"passwd*\"), __func__, 1))->pw_passwd));} - static s7_pointer g_passwd_pw_uid(s7_scheme *sc, s7_pointer args) + static s7_pointer g_passwd_pw_uid(s7_scheme *sc, s7_pointer args) {return(s7_make_integer(sc, ((struct passwd *)s7_c_pointer_with_type(sc, s7_car(args), s7_make_symbol(sc, \"passwd*\"), __func__, 1))->pw_uid));} - static s7_pointer g_passwd_pw_gid(s7_scheme *sc, s7_pointer args) + static s7_pointer g_passwd_pw_gid(s7_scheme *sc, s7_pointer args) {return(s7_make_integer(sc, ((struct passwd *)s7_c_pointer_with_type(sc, s7_car(args), s7_make_symbol(sc, \"passwd*\"), __func__, 1))->pw_gid));} - static s7_pointer g_passwd_pw_gecos(s7_scheme *sc, s7_pointer args) + static s7_pointer g_passwd_pw_gecos(s7_scheme *sc, s7_pointer args) {return(s7_make_string(sc, ((struct passwd *)s7_c_pointer_with_type(sc, s7_car(args), s7_make_symbol(sc, \"passwd*\"), __func__, 1))->pw_gecos));} - static s7_pointer g_passwd_pw_dir(s7_scheme *sc, s7_pointer args) + static s7_pointer g_passwd_pw_dir(s7_scheme *sc, s7_pointer args) {return(s7_make_string(sc, ((struct passwd *)s7_c_pointer_with_type(sc, s7_car(args), s7_make_symbol(sc, \"passwd*\"), __func__, 1))->pw_dir));} - static s7_pointer g_passwd_pw_shell(s7_scheme *sc, s7_pointer args) + static s7_pointer g_passwd_pw_shell(s7_scheme *sc, s7_pointer args) {return(s7_make_string(sc, ((struct passwd *)s7_c_pointer_with_type(sc, s7_car(args), s7_make_symbol(sc, \"passwd*\"), __func__, 1))->pw_shell));} ") (C-function ("passwd.pw_name" g_passwd_pw_name "" 1)) @@ -1015,11 +1015,11 @@ (C-function ("passwd.pw_dir" g_passwd_pw_dir "" 1)) (C-function ("passwd.pw_shell" g_passwd_pw_shell "" 1)) ;; ((*libc* 'passwd.pw_name) ((*libc* 'getpwnam) "bil")) -> "bil" - - + + ;; -------- wordexp.h -------- (reader-cond ((not (provided? 'openbsd)) - (int (WRDE_DOOFFS WRDE_APPEND WRDE_NOCMD WRDE_REUSE WRDE_SHOWERR WRDE_UNDEF + (int (WRDE_DOOFFS WRDE_APPEND WRDE_NOCMD WRDE_REUSE WRDE_SHOWERR WRDE_UNDEF WRDE_NOSPACE WRDE_BADCHAR WRDE_BADVAL WRDE_CMDSUB WRDE_SYNTAX)) (int wordexp (char* wordexp_t* int)) (void wordfree (wordexp_t*)) @@ -1045,12 +1045,12 @@ (C-function ("wordexp.we_wordc" g_wordexp_we_wordc "" 1)) (C-function ("wordexp.we_wordv" g_wordexp_we_wordv "" 1)))) ;; (with-let (sublet *libc*) (let ((w (wordexp.make))) (wordexp "~/cl/snd-gdraw" w 0) (wordexp.we_wordv w))) -> ("/home/bil/cl/snd-gdraw") - - + + ;; -------- glob.h -------- ;; does any of this work in openbsd? - (C-macro (int (GLOB_ERR GLOB_MARK GLOB_NOSORT GLOB_DOOFFS GLOB_NOCHECK GLOB_APPEND GLOB_NOESCAPE GLOB_PERIOD - GLOB_MAGCHAR GLOB_ALTDIRFUNC GLOB_BRACE GLOB_NOMAGIC GLOB_TILDE GLOB_ONLYDIR GLOB_TILDE_CHECK + (C-macro (int (GLOB_ERR GLOB_MARK GLOB_NOSORT GLOB_DOOFFS GLOB_NOCHECK GLOB_APPEND GLOB_NOESCAPE GLOB_PERIOD + GLOB_MAGCHAR GLOB_ALTDIRFUNC GLOB_BRACE GLOB_NOMAGIC GLOB_TILDE GLOB_ONLYDIR GLOB_TILDE_CHECK GLOB_NOSPACE GLOB_ABORTED GLOB_NOMATCH GLOB_NOSYS))) (void globfree (glob_t*)) (in-C " @@ -1059,7 +1059,7 @@ static s7_pointer g_glob_gl_pathc(s7_scheme *sc, s7_pointer args) {return(s7_make_integer(sc, ((glob_t *)s7_c_pointer_with_type(sc, s7_car(args), s7_make_symbol(sc, \"glob_t*\"), __func__, 1))->gl_pathc));} static s7_pointer g_glob(s7_scheme *sc, s7_pointer args) - {return(s7_make_integer(sc, glob(s7_string(s7_car(args)), s7_integer(s7_cadr(args)), NULL, + {return(s7_make_integer(sc, glob(s7_string(s7_car(args)), s7_integer(s7_cadr(args)), NULL, (glob_t *)s7_c_pointer_with_type(sc, s7_caddr(args), s7_make_symbol(sc, \"glob_t*\"), __func__, 1))));} static s7_pointer g_glob_gl_pathv(s7_scheme *sc, s7_pointer args) { @@ -1076,27 +1076,27 @@ (C-function ("glob.gl_pathc" g_glob_gl_pathc "" 1)) (C-function ("glob.gl_pathv" g_glob_gl_pathv "" 1)) (C-function ("glob" g_glob "" 3)) - - + + ;; -------- signal.h sys/wait.h -------- - (C-macro (int (SIGHUP SIGINT SIGQUIT SIGILL SIGTRAP SIGABRT SIGIOT SIGBUS SIGFPE - SIGKILL SIGUSR1 SIGSEGV SIGUSR2 SIGPIPE SIGALRM SIGTERM SIGSTKFLT - SIGCLD SIGCHLD SIGCONT SIGSTOP SIGTSTP SIGTTIN SIGTTOU SIGURG - SIGXCPU SIGXFSZ SIGVTALRM SIGPROF SIGWINCH SIGPOLL SIGIO SIGPWR SIGSYS + (C-macro (int (SIGHUP SIGINT SIGQUIT SIGILL SIGTRAP SIGABRT SIGIOT SIGBUS SIGFPE + SIGKILL SIGUSR1 SIGSEGV SIGUSR2 SIGPIPE SIGALRM SIGTERM SIGSTKFLT + SIGCLD SIGCHLD SIGCONT SIGSTOP SIGTSTP SIGTTIN SIGTTOU SIGURG + SIGXCPU SIGXFSZ SIGVTALRM SIGPROF SIGWINCH SIGPOLL SIGIO SIGPWR SIGSYS (reader-cond ((not (provided? 'osx)) SIGUNUSED)) WNOHANG WUNTRACED WSTOPPED WEXITED WCONTINUED WNOWAIT - RLIMIT_CPU RLIMIT_FSIZE RLIMIT_DATA RLIMIT_STACK RLIMIT_CORE RLIMIT_RSS - RLIMIT_NOFILE RLIMIT_OFILE RLIMIT_AS RLIMIT_NPROC RLIMIT_MEMLOCK RLIMIT_LOCKS - RLIMIT_SIGPENDING RLIMIT_MSGQUEUE RLIMIT_NICE RLIMIT_RTPRIO RLIMIT_NLIMITS - RLIM_NLIMITS RLIM_INFINITY RLIM_SAVED_MAX RLIM_SAVED_CUR RUSAGE_SELF - RUSAGE_CHILDREN RUSAGE_THREAD RUSAGE_LWP + RLIMIT_CPU RLIMIT_FSIZE RLIMIT_DATA RLIMIT_STACK RLIMIT_CORE RLIMIT_RSS + RLIMIT_NOFILE RLIMIT_OFILE RLIMIT_AS RLIMIT_NPROC RLIMIT_MEMLOCK RLIMIT_LOCKS + RLIMIT_SIGPENDING RLIMIT_MSGQUEUE RLIMIT_NICE RLIMIT_RTPRIO RLIMIT_NLIMITS + RLIM_NLIMITS RLIM_INFINITY RLIM_SAVED_MAX RLIM_SAVED_CUR RUSAGE_SELF + RUSAGE_CHILDREN RUSAGE_THREAD RUSAGE_LWP PRIO_MIN PRIO_MAX PRIO_PROCESS PRIO_PGRP PRIO_USER - SA_NOCLDSTOP SA_NOCLDWAIT SA_SIGINFO SA_ONSTACK SA_RESTART SA_NODEFER SA_RESETHAND SA_NOMASK SA_ONESHOT SA_STACK + SA_NOCLDSTOP SA_NOCLDWAIT SA_SIGINFO SA_ONSTACK SA_RESTART SA_NODEFER SA_RESETHAND SA_NOMASK SA_ONESHOT SA_STACK SIG_BLOCK SIG_UNBLOCK SIG_SETMASK ))) - + ;; (let ((v (rusage.make))) (getrusage (*libc* 'RUSAGE_SELF) v) (let ((mem (rusage.ru_maxrss v))) (free v) mem)) - + (int kill (int int)) (int raise (int)) (int sigemptyset (sigset_t*)) @@ -1108,8 +1108,8 @@ (int sigsuspend (sigset_t*)) (int sigpending (sigset_t*)) (int getpriority (int int)) - (int setpriority (int int int)) - + (int setpriority (int int int)) + (in-C " static s7_pointer g_rlimit_make(s7_scheme *sc, s7_pointer args) {return(s7_make_c_pointer_with_type(sc, (void *)calloc(1, sizeof(struct rlimit)), s7_make_symbol(sc, \"rlimit*\"), s7_f(sc)));} @@ -1139,7 +1139,7 @@ static s7_pointer g_rusage_ru_stime(s7_scheme *sc, s7_pointer args) {return(s7_make_c_pointer(sc, &(((struct rusage *)s7_c_pointer_with_type(sc, s7_car(args), s7_make_symbol(sc, \"rusage*\"), __func__, 1))->ru_stime)));} static s7_pointer g_getrusage(s7_scheme *sc, s7_pointer args) - {return(s7_make_integer(sc, getrusage(s7_integer(s7_car(args)), + {return(s7_make_integer(sc, getrusage(s7_integer(s7_car(args)), (struct rusage *)s7_c_pointer_with_type(sc, s7_cadr(args), s7_make_symbol(sc, \"rusage*\"), __func__, 1))));} static s7_pointer g_sigset_make(s7_scheme *sc, s7_pointer args) @@ -1197,7 +1197,7 @@ static s7_pointer g_sigtimedwait(s7_scheme *sc, s7_pointer args) { #if (__linux__) - return(s7_make_integer(sc, sigtimedwait((const sigset_t *)s7_c_pointer(s7_car(args)), + return(s7_make_integer(sc, sigtimedwait((const sigset_t *)s7_c_pointer(s7_car(args)), (siginfo_t *)s7_c_pointer(s7_cadr(args)), (const struct timespec *)s7_c_pointer(s7_caddr(args))))); #else @@ -1236,12 +1236,12 @@ static s7_pointer g_siginfo_si_fd(s7_scheme *sc, s7_pointer args) {return(s7_make_integer(sc, ((siginfo_t *)s7_c_pointer_with_type(sc, s7_car(args), s7_make_symbol(sc, \"siginfo_t*\"), __func__, 1))->si_fd));} static s7_pointer g_siginfo_si_ptr(s7_scheme *sc, s7_pointer args) - {return(s7_make_c_pointer_with_type(sc, - ((siginfo_t *)s7_c_pointer_with_type(sc, s7_car(args), s7_make_symbol(sc, \"siginfo_t*\"), __func__, 1))->si_ptr, + {return(s7_make_c_pointer_with_type(sc, + ((siginfo_t *)s7_c_pointer_with_type(sc, s7_car(args), s7_make_symbol(sc, \"siginfo_t*\"), __func__, 1))->si_ptr, s7_make_symbol(sc, \"siginfo_t*\"), s7_f(sc)));} static s7_pointer g_siginfo_si_addr(s7_scheme *sc, s7_pointer args) - {return(s7_make_c_pointer_with_type(sc, - ((siginfo_t *)s7_c_pointer_with_type(sc, s7_car(args), s7_make_symbol(sc, \"siginfo_t*\"), __func__, 1))->si_addr, + {return(s7_make_c_pointer_with_type(sc, + ((siginfo_t *)s7_c_pointer_with_type(sc, s7_car(args), s7_make_symbol(sc, \"siginfo_t*\"), __func__, 1))->si_addr, s7_make_symbol(sc, \"siginfo_t*\"), s7_f(sc)));} #endif @@ -1296,10 +1296,10 @@ if (s7_c_pointer(s7_cadr(args)) == (void *)SIG_IGN) ((struct sigaction *)s7_c_pointer(s7_car(args)))->sa_handler = SIG_IGN; }} - else + else { ((struct sigaction *)s7_c_pointer_with_type(sc, s7_car(args), s7_make_symbol(sc, \"sigaction*\"), __func__, 1))->sa_handler = s7_signal_handler; - s7_vector_set(sighandlers_s7, sighandlers, SIGUNUSED, + s7_vector_set(sighandlers_s7, sighandlers, SIGUNUSED, s7_cons(sc, s7_cons(sc, s7_car(args), s7_cadr(args)), s7_vector_ref(sighandlers_s7, sighandlers, SIGUNUSED))); } return(s7_cadr(args)); @@ -1342,11 +1342,11 @@ return(s7_make_c_pointer(sc, (void *)signal(sig, s7_signal_handler))); } ") - + (C-function ("rlimit.make" g_rlimit_make "" 0)) (C-function ("rlimit.rlim_cur" g_rlimit_rlim_cur "" 1)) (C-function ("rlimit.rlim_max" g_rlimit_rlim_max "" 1)) - + (C-function ("rusage.make" g_rusage_make "" 0)) (C-function ("getrusage" g_getrusage "" 2)) (C-function ("rusage.ru_maxrss" g_rusage_ru_maxrss "" 1)) @@ -1358,8 +1358,8 @@ (C-function ("rusage.ru_nivcsw" g_rusage_ru_nivcsw "" 1)) (C-function ("rusage.ru_utime" g_rusage_ru_utime "" 1)) (C-function ("rusage.ru_stime" g_rusage_ru_stime "" 1)) - - (reader-cond ((provided? 'linux) + + (reader-cond ((provided? 'linux) (C-function ("siginfo.make" g_siginfo_make "" 0)) (C-function ("siginfo.si_signo" g_siginfo_si_signo "" 1)) (C-function ("siginfo.si_errno" g_siginfo_si_errno "" 1)) @@ -1377,18 +1377,18 @@ (C-function ("siginfo.si_fd" g_siginfo_si_fd "" 1)) (C-function ("siginfo.si_ptr" g_siginfo_si_ptr "" 1)) (C-function ("siginfo.si_addr" g_siginfo_si_addr "" 1)))) - + (C-function ("timespec.make" g_timespec_make "" 0)) (C-function ("timespec.tv_sec" g_timespec_tv_sec "" 1)) (C-function ("timespec.tv_nsec" g_timespec_tv_nsec "" 1)) - + (C-function ("sigaction.make" g_sigaction_make "" 0)) (C-function ("sigaction.sa_handler" g_sigaction_sa_handler "" 1)) (C-function ("sigaction.sa_flags" g_sigaction_sa_flags "" 1)) (C-function ("sigaction.sa_mask" g_sigaction_sa_mask "" 1)) (C-function ("sigaction.set_sa_handler" g_sigaction_set_sa_handler "" 2)) (C-function ("sigaction.set_sa_flags" g_sigaction_set_sa_flags "" 2)) -#| +#| (with-let (sublet *libc*) (let ((sa (sigaction.make))) (sigemptyset (sigaction.sa_mask sa)) @@ -1400,15 +1400,15 @@ (do ((i 0 (+ i 1))) ((= i 10)) (sleep 1)))) -|# - (reader-cond ((provided? 'linux) +|# + (reader-cond ((provided? 'linux) (C-function ("WEXITSTATUS" g_WEXITSTATUS "" 1)) (C-function ("WTERMSIG" g_WTERMSIG "" 1)) (C-function ("WSTOPSIG" g_WSTOPSIG "" 1)) (C-function ("WIFEXITED" g_WIFEXITED "" 1)) (C-function ("WIFSIGNALED" g_WIFSIGNALED "" 1)) (C-function ("WIFSTOPPED" g_WIFSTOPPED "" 1)))) - + (C-function ("wait" g_wait "" 0)) (C-function ("waitpid" g_waitpid "" 2)) (C-function ("sigqueue" g_sigqueue "" 3)) @@ -1416,25 +1416,25 @@ (C-function ("sigaction" g_sigaction "" 3)) (C-function ("sigtimedwait" g_sigtimedwait "" 3)) (C-function ("sigset.make" g_sigset_make "" 0)) - + (C-function ("signal" g_signal "" 2)) - + (int getrlimit (int struct-rlimit*)) (int setrlimit (int struct-rlimit*)) - (reader-cond ((provided? 'linux) + (reader-cond ((provided? 'linux) (int sigwaitinfo (sigset_t* siginfo_t*)) (int waitid ((idtype_t int) int siginfo_t* int)))) (c-pointer (SIG_ERR SIG_DFL SIG_IGN)) - - + + ;; -------- netdb.h -------- (reader-cond ((provided? 'linux) (int (IPPORT_ECHO IPPORT_DISCARD IPPORT_SYSTAT IPPORT_DAYTIME IPPORT_NETSTAT IPPORT_FTP IPPORT_TELNET IPPORT_SMTP IPPORT_TIMESERVER IPPORT_NAMESERVER IPPORT_WHOIS IPPORT_MTP IPPORT_TFTP IPPORT_RJE IPPORT_FINGER IPPORT_TTYLINK IPPORT_SUPDUP IPPORT_EXECSERVER IPPORT_LOGINSERVER IPPORT_CMDSERVER IPPORT_EFSSERVER IPPORT_BIFFUDP IPPORT_WHOSERVER IPPORT_ROUTESERVER IPPORT_RESERVED IPPORT_USERRESERVED)))) - + (C-macro (int (AI_PASSIVE AI_CANONNAME AI_NUMERICHOST AI_V4MAPPED AI_ALL AI_ADDRCONFIG AI_NUMERICSERV EAI_BADFLAGS EAI_NONAME EAI_AGAIN EAI_FAIL EAI_FAMILY EAI_SOCKTYPE EAI_SERVICE EAI_MEMORY EAI_SYSTEM EAI_OVERFLOW NI_NUMERICHOST NI_NUMERICSERV NI_NOFQDN NI_NAMEREQD NI_DGRAM @@ -1457,7 +1457,7 @@ SHUT_RD SHUT_WR SHUT_RDWR))) (C-macro (char* (_PATH_HEQUIV _PATH_HOSTS _PATH_NETWORKS _PATH_NSSWITCH_CONF _PATH_PROTOCOLS _PATH_SERVICES))) - + (reader-cond ((not (provided? 'msys)) (hostent* gethostent (void)) (void setnetent (int)) @@ -1465,33 +1465,33 @@ (netent* getnetent (void)) (netent* getnetbyname (char*)) (netent* getnetbyaddr (int int)))) - + (void sethostent (int)) (void endhostent (void)) - + (void setservent (int)) (void endservent (void)) (servent* getservent (void)) - + (void setprotoent (int)) (void endprotoent (void)) (protoent* getprotoent (void)) - - + + (int socket (int int int)) (int listen (int int)) (int shutdown (int int)) - + (hostent* gethostbyname (char*)) (hostent* gethostbyaddr (void* int int)) (servent* getservbyname (char* char*)) (servent* getservbyport (int char*)) (protoent* getprotobyname (char*)) (protoent* getprotobynumber (int)) - + (void freeaddrinfo (struct-addrinfo*)) (char* gai_strerror (int)) - + (int bind (int const-struct-sockaddr* int)) (int connect (int const-struct-sockaddr* int)) (int send (int void* int int)) @@ -1499,79 +1499,79 @@ (int sendto (int void* int int const-struct-sockaddr* int)) (int sendmsg (int const-struct-msghdr* int)) (int recvmsg (int struct-msghdr* int)) - + (in-C " static s7_pointer g_ntohl(s7_scheme *sc, s7_pointer args) {return(s7_make_integer(sc, ntohl(s7_integer(s7_car(args)))));} static s7_pointer g_ntohs(s7_scheme *sc, s7_pointer args) {return(s7_make_integer(sc, ntohs(s7_integer(s7_car(args)))));} static s7_pointer g_htonl(s7_scheme *sc, s7_pointer args) {return(s7_make_integer(sc, htonl(s7_integer(s7_car(args)))));} static s7_pointer g_htons(s7_scheme *sc, s7_pointer args) {return(s7_make_integer(sc, htons(s7_integer(s7_car(args)))));} - static s7_pointer g_addrinfo_make(s7_scheme *sc, s7_pointer args) + static s7_pointer g_addrinfo_make(s7_scheme *sc, s7_pointer args) { return(s7_make_c_pointer_with_type(sc, (void *)calloc(1, sizeof(struct addrinfo)), s7_make_symbol(sc, \"addrinfo*\"), s7_f(sc))); } - static s7_pointer g_addrinfo_ai_flags(s7_scheme *sc, s7_pointer args) + static s7_pointer g_addrinfo_ai_flags(s7_scheme *sc, s7_pointer args) { return(s7_make_integer(sc, ((struct addrinfo *)s7_c_pointer_with_type(sc, s7_car(args), s7_make_symbol(sc, \"addrinfo*\"), __func__, 1))->ai_flags)); } - static s7_pointer g_addrinfo_set_ai_flags(s7_scheme *sc, s7_pointer args) + static s7_pointer g_addrinfo_set_ai_flags(s7_scheme *sc, s7_pointer args) { ((struct addrinfo *)s7_c_pointer_with_type(sc, s7_car(args), s7_make_symbol(sc, \"addrinfo*\"), __func__, 1))->ai_flags = (int)s7_integer(s7_cadr(args)); return(s7_cadr(args)); } - static s7_pointer g_addrinfo_ai_family(s7_scheme *sc, s7_pointer args) + static s7_pointer g_addrinfo_ai_family(s7_scheme *sc, s7_pointer args) { return(s7_make_integer(sc, ((struct addrinfo *)s7_c_pointer_with_type(sc, s7_car(args), s7_make_symbol(sc, \"addrinfo*\"), __func__, 1))->ai_family)); } - static s7_pointer g_addrinfo_set_ai_family(s7_scheme *sc, s7_pointer args) + static s7_pointer g_addrinfo_set_ai_family(s7_scheme *sc, s7_pointer args) { ((struct addrinfo *)s7_c_pointer_with_type(sc, s7_car(args), s7_make_symbol(sc, \"addrinfo*\"), __func__, 1))->ai_family = (int)s7_integer(s7_cadr(args)); return(s7_cadr(args)); } - static s7_pointer g_addrinfo_ai_socktype(s7_scheme *sc, s7_pointer args) + static s7_pointer g_addrinfo_ai_socktype(s7_scheme *sc, s7_pointer args) { return(s7_make_integer(sc, ((struct addrinfo *)s7_c_pointer_with_type(sc, s7_car(args), s7_make_symbol(sc, \"addrinfo*\"), __func__, 1))->ai_socktype)); } - static s7_pointer g_addrinfo_set_ai_socktype(s7_scheme *sc, s7_pointer args) + static s7_pointer g_addrinfo_set_ai_socktype(s7_scheme *sc, s7_pointer args) { ((struct addrinfo *)s7_c_pointer_with_type(sc, s7_car(args), s7_make_symbol(sc, \"addrinfo*\"), __func__, 1))->ai_socktype = (int)s7_integer(s7_cadr(args)); return(s7_cadr(args)); } - static s7_pointer g_addrinfo_ai_protocol(s7_scheme *sc, s7_pointer args) + static s7_pointer g_addrinfo_ai_protocol(s7_scheme *sc, s7_pointer args) { return(s7_make_integer(sc, ((struct addrinfo *)s7_c_pointer_with_type(sc, s7_car(args), s7_make_symbol(sc, \"addrinfo*\"), __func__, 1))->ai_protocol)); } - static s7_pointer g_addrinfo_set_ai_protocol(s7_scheme *sc, s7_pointer args) + static s7_pointer g_addrinfo_set_ai_protocol(s7_scheme *sc, s7_pointer args) { ((struct addrinfo *)s7_c_pointer_with_type(sc, s7_car(args), s7_make_symbol(sc, \"addrinfo*\"), __func__, 1))->ai_protocol = (int)s7_integer(s7_cadr(args)); return(s7_cadr(args)); } - static s7_pointer g_addrinfo_ai_canonname(s7_scheme *sc, s7_pointer args) + static s7_pointer g_addrinfo_ai_canonname(s7_scheme *sc, s7_pointer args) { return(s7_make_string(sc, ((struct addrinfo *)s7_c_pointer_with_type(sc, s7_car(args), s7_make_symbol(sc, \"addrinfo*\"), __func__, 1))->ai_canonname)); } - static s7_pointer g_addrinfo_ai_next(s7_scheme *sc, s7_pointer args) + static s7_pointer g_addrinfo_ai_next(s7_scheme *sc, s7_pointer args) { return(s7_make_c_pointer_with_type(sc, (void *)(((struct addrinfo *)s7_c_pointer_with_type(sc, s7_car(args), s7_make_symbol(sc, \"addrinfo*\"), __func__, 1))->ai_next), s7_make_symbol(sc, \"addrinfo*\"), s7_f(sc))); } - static s7_pointer g_getaddrinfo(s7_scheme *sc, s7_pointer args) + static s7_pointer g_getaddrinfo(s7_scheme *sc, s7_pointer args) { struct addrinfo *result; int err; - err = getaddrinfo(s7_string(s7_car(args)), + err = getaddrinfo(s7_string(s7_car(args)), s7_string(s7_cadr(args)), (const struct addrinfo *)s7_c_pointer_with_type(sc, s7_caddr(args), s7_make_symbol(sc, \"addrinfo*\"), __func__, 1), &result); - return(s7_list(sc, 2, s7_make_integer(sc, err), + return(s7_list(sc, 2, s7_make_integer(sc, err), s7_make_c_pointer_with_type(sc, (void *)result, s7_make_symbol(sc, \"addrinfo*\"), s7_f(sc)))); } - static s7_pointer g_getnameinfo(s7_scheme *sc, s7_pointer args) + static s7_pointer g_getnameinfo(s7_scheme *sc, s7_pointer args) { #ifndef NI_MAXHOST #define NI_MAXHOST 1025 @@ -1589,16 +1589,16 @@ s7_integer(s7_caddr(args))); return(s7_list(sc, 3, s7_make_integer(sc, err), s7_make_string(sc, host), s7_make_string(sc, service))); } - - static s7_pointer g_socketpair(s7_scheme *sc, s7_pointer args) + + static s7_pointer g_socketpair(s7_scheme *sc, s7_pointer args) { int fds[2]; int err; err = socketpair(s7_integer(s7_car(args)), s7_integer(s7_cadr(args)), s7_integer(s7_caddr(args)), fds); return(s7_list(sc, 3, s7_make_integer(sc, err), s7_make_integer(sc, fds[0]), s7_make_integer(sc, fds[1]))); } - - static s7_pointer g_getsockname(s7_scheme *sc, s7_pointer args) + + static s7_pointer g_getsockname(s7_scheme *sc, s7_pointer args) { int err; socklen_t res; @@ -1606,7 +1606,7 @@ err = getsockname(s7_integer(s7_car(args)), (struct sockaddr *)s7_c_pointer(s7_cadr(args)), &res); return(s7_list(sc, 2, s7_make_integer(sc, err), s7_make_integer(sc, res))); } - static s7_pointer g_getpeername(s7_scheme *sc, s7_pointer args) + static s7_pointer g_getpeername(s7_scheme *sc, s7_pointer args) { int err; socklen_t res; @@ -1614,7 +1614,7 @@ err = getpeername(s7_integer(s7_car(args)), (struct sockaddr *)s7_c_pointer(s7_cadr(args)), &res); return(s7_list(sc, 2, s7_make_integer(sc, err), s7_make_integer(sc, res))); } - static s7_pointer g_accept(s7_scheme *sc, s7_pointer args) + static s7_pointer g_accept(s7_scheme *sc, s7_pointer args) { int err; socklen_t res; @@ -1622,7 +1622,7 @@ err = accept(s7_integer(s7_car(args)), (struct sockaddr *)s7_c_pointer(s7_cadr(args)), &res); return(s7_list(sc, 2, s7_make_integer(sc, err), s7_make_integer(sc, res))); } - static s7_pointer g_getsockopt(s7_scheme *sc, s7_pointer args) + static s7_pointer g_getsockopt(s7_scheme *sc, s7_pointer args) { int err; socklen_t res; @@ -1630,22 +1630,22 @@ err = getsockopt(s7_integer(s7_car(args)), s7_integer(s7_cadr(args)), s7_integer(s7_caddr(args)), s7_c_pointer(s7_cadddr(args)), &res); return(s7_list(sc, 2, s7_make_integer(sc, err), s7_make_integer(sc, (s7_int)res))); } - static s7_pointer g_setsockopt(s7_scheme *sc, s7_pointer args) + static s7_pointer g_setsockopt(s7_scheme *sc, s7_pointer args) { socklen_t res; res = (socklen_t)s7_integer(s7_list_ref(sc, args, 4)); - return(s7_make_integer(sc, setsockopt(s7_integer(s7_car(args)), s7_integer(s7_cadr(args)), + return(s7_make_integer(sc, setsockopt(s7_integer(s7_car(args)), s7_integer(s7_cadr(args)), s7_integer(s7_caddr(args)), s7_c_pointer(s7_cadddr(args)), res))); } - static s7_pointer g_recvfrom(s7_scheme *sc, s7_pointer args) + static s7_pointer g_recvfrom(s7_scheme *sc, s7_pointer args) { int err; socklen_t res; res = (socklen_t)s7_integer(s7_list_ref(sc, args, 5)); - err = recvfrom(s7_integer(s7_car(args)), + err = recvfrom(s7_integer(s7_car(args)), s7_c_pointer(s7_cadr(args)), /* void* buf */ - s7_integer(s7_caddr(args)), - s7_integer(s7_cadddr(args)), + s7_integer(s7_caddr(args)), + s7_integer(s7_cadddr(args)), (struct sockaddr *)s7_c_pointer(s7_list_ref(sc, args, 4)), &res); return(s7_list(sc, 2, s7_make_integer(sc, err), s7_make_integer(sc, (s7_int)res))); @@ -1678,7 +1678,7 @@ static s7_pointer g_hostent_h_aliases(s7_scheme *sc, s7_pointer args) { s7_pointer p; - char **str; + char **str; struct hostent *h; p = s7_nil(sc); h = (struct hostent *)s7_c_pointer_with_type(sc, s7_car(args), s7_make_symbol(sc, \"hostent*\"), __func__, 1); @@ -1689,7 +1689,7 @@ static s7_pointer g_servent_s_aliases(s7_scheme *sc, s7_pointer args) { s7_pointer p; - char **str; + char **str; struct servent *h; p = s7_nil(sc); h = (struct servent *)s7_c_pointer_with_type(sc, s7_car(args), s7_make_symbol(sc, \"servent*\"), __func__, 1); @@ -1700,7 +1700,7 @@ static s7_pointer g_netent_n_aliases(s7_scheme *sc, s7_pointer args) { s7_pointer p; - char **str; + char **str; struct netent *h; p = s7_nil(sc); h = (struct netent *)s7_c_pointer_with_type(sc, s7_car(args), s7_make_symbol(sc, \"netvent*\"), __func__, 1); @@ -1711,7 +1711,7 @@ static s7_pointer g_protoent_p_aliases(s7_scheme *sc, s7_pointer args) { s7_pointer p; - char **str; + char **str; struct protoent *h; p = s7_nil(sc); h = (struct protoent *)s7_c_pointer_with_type(sc, s7_car(args), s7_make_symbol(sc, \"protoent*\"), __func__, 1); @@ -1724,7 +1724,7 @@ (C-function ("htons" g_htons "" 1)) (C-function ("ntohl" g_ntohl "" 1)) (C-function ("ntohs" g_ntohs "" 1)) - + (C-function ("getaddrinfo" g_getaddrinfo "" 3)) (C-function ("getnameinfo" g_getnameinfo "" 3)) (C-function ("addrinfo.make" g_addrinfo_make "" 0)) @@ -1738,7 +1738,7 @@ (C-function ("addrinfo.set_ai_protocol" g_addrinfo_set_ai_protocol "" 2)) (C-function ("addrinfo.ai_canonname" g_addrinfo_ai_canonname "" 1)) (C-function ("addrinfo.ai_next" g_addrinfo_ai_next "" 1)) - + (C-function ("hostent.h_name" g_hostent_h_name "" 1)) (C-function ("netent.n_name" g_netent_n_name "" 1)) (C-function ("servent.s_name" g_servent_s_name "" 1)) @@ -1750,14 +1750,14 @@ (C-function ("netent.n_net" g_netent_n_net "" 1)) (C-function ("servent.s_port" g_servent_s_port "" 1)) (C-function ("protoent.p_proto" g_protoent_p_proto "" 1)) - + (C-function ("hostent.h_aliases" g_hostent_h_aliases "" 1)) (C-function ("servent.s_aliases" g_servent_s_aliases "" 1)) (C-function ("netent.n_aliases" g_netent_n_aliases "" 1)) (C-function ("protoent.p_aliases" g_protoent_p_aliases "" 1)) ;; (define h (gethostbyname "fatty4")) ;; ((*libc* 'hostent.h_aliases) h) -> ("localhost" "localhost.localdomain") - + (C-function ("socketpair" g_socketpair "" 3)) (C-function ("getsockname" g_getsockname "" 3)) (C-function ("getpeername" g_getpeername "" 3)) @@ -1777,9 +1777,9 @@ int res, flags; regex_t *regexp; const char *str; - if (!s7_is_string(s7_cadr(args))) + if (!s7_is_string(s7_cadr(args))) return(s7_wrong_type_error(sc, s7_make_string_wrapper_with_length(sc, \"(*libc* 'regcomp)\", 17), 2, s7_cadr(args), string_string)); - if (!s7_is_integer(s7_caddr(args))) + if (!s7_is_integer(s7_caddr(args))) return(s7_wrong_type_error(sc, s7_make_string_wrapper_with_length(sc, \"(*libc* 'regcomp)\", 17), 3, s7_caddr(args), integer_string)); regexp = (regex_t *)s7_c_pointer_with_type(sc, s7_car(args), s7_make_symbol(sc, \"regex_t*\"), __func__, 1); str = (const char *)s7_string(s7_cadr(args)); @@ -1797,11 +1797,11 @@ s7_pointer subs; s7_int *els; - if (!s7_is_string(s7_cadr(args))) + if (!s7_is_string(s7_cadr(args))) return(s7_wrong_type_error(sc, s7_make_string_wrapper_with_length(sc, \"(*libc* 'regexec)\", 17), 2, s7_cadr(args), string_string)); - if (!s7_is_integer(s7_caddr(args))) + if (!s7_is_integer(s7_caddr(args))) return(s7_wrong_type_error(sc, s7_make_string_wrapper_with_length(sc, \"(*libc* 'regexec)\", 17), 3, s7_caddr(args), integer_string)); - if (!s7_is_integer(s7_cadddr(args))) + if (!s7_is_integer(s7_cadddr(args))) return(s7_wrong_type_error(sc, s7_make_string_wrapper_with_length(sc, \"(*libc* 'regexec)\", 17), 4, s7_cadddr(args), integer_string)); regexp = (regex_t *)s7_c_pointer_with_type(sc, s7_car(args), s7_make_symbol(sc, \"regex_t*\"), __func__, 1); str = (const char *)s7_string(s7_cadr(args)); @@ -1865,24 +1865,24 @@ (C-function ("regex.free" g_regex_free "" 1)) (C-function ("regfree" g_regfree "" 1)) (C-function ("regcomp" g_regcomp "" 3)) - (C-function ("regexec" g_regexec "" 4)) ; (regexec regex string nmatches flags) + (C-function ("regexec" g_regexec "" 4)) ; (regexec regex string nmatches flags) (C-function ("regerror" g_regerror "" 2)) ) - - "" - (list "limits.h" "ctype.h" "errno.h" "float.h" "stdint.h" "locale.h" "stdlib.h" "string.h" "fcntl.h" + + "" + (list "limits.h" "ctype.h" "errno.h" "float.h" "stdint.h" "locale.h" "stdlib.h" "string.h" "fcntl.h" "fenv.h" "stdio.h" "sys/utsname.h" "unistd.h" "dirent.h" "ftw.h" "sys/stat.h" "time.h" "sys/time.h" - "utime.h" "termios.h" "grp.h" "pwd.h" "fnmatch.h" "glob.h" "signal.h" "sys/wait.h" "netdb.h" + "utime.h" "termios.h" "grp.h" "pwd.h" "fnmatch.h" "glob.h" "signal.h" "sys/wait.h" "netdb.h" "sys/resource.h" "regex.h" (reader-cond ((provided? 'linux) "semaphore.h")) (reader-cond ((not (provided? 'openbsd)) "wordexp.h")) (reader-cond ((provided? 'freebsd) "sys/socket.h" "netinet/in.h")) ) - "" - (if (provided? 'linux) "-lrt" + "" + (if (provided? 'linux) "-lrt" (if (provided? 'openbsd) "-pthread" "")) "libc_s7") - + (curlet)))) *libc* @@ -19,7 +19,7 @@ (if (not (defined? '*libdl*)) (define *libdl* - (with-let (unlet) + (with-let (sublet (unlet)) (set! *libraries* (cons (cons "libdl.scm" (curlet)) *libraries*)) (set! *cload-library-name* "*libdl*") (c-define '((void* dlopen (char* int)) diff --git a/libgdbm.scm b/libgdbm.scm index bdf751a..578c7b0 100644 --- a/libgdbm.scm +++ b/libgdbm.scm @@ -19,7 +19,7 @@ (if (not (defined? '*libgdbm*)) (define *libgdbm* - (with-let (unlet) + (with-let (sublet (unlet)) (set! *libraries* (cons (cons "libgdbm.scm" (curlet)) *libraries*)) (set! *cload-library-name* "*libgdbm*") @@ -43,7 +43,7 @@ (unless (defined? '*libgsl*) (define *libgsl* - (with-let (unlet) + (with-let (sublet (unlet)) (define GSL_REAL real-part) (define GSL_IMAG imag-part) (define GSL_COMPLEX_EQ equal?) @@ -64,102 +64,102 @@ (define GSL_MIN_DBL min) (define gsl_max max) (define gsl_min min) - + (set! *libraries* (cons (cons "libgsl.scm" (curlet)) *libraries*)) (set! *cload-library-name* "*libgsl*") - (c-define - '((C-macro (double (GSL_CONST_CGS_SPEED_OF_LIGHT GSL_CONST_CGS_GRAVITATIONAL_CONSTANT GSL_CONST_CGS_PLANCKS_CONSTANT_H - GSL_CONST_CGS_PLANCKS_CONSTANT_HBAR GSL_CONST_CGS_ASTRONOMICAL_UNIT GSL_CONST_CGS_LIGHT_YEAR - GSL_CONST_CGS_PARSEC GSL_CONST_CGS_GRAV_ACCEL GSL_CONST_CGS_ELECTRON_VOLT GSL_CONST_CGS_MASS_ELECTRON - GSL_CONST_CGS_MASS_MUON GSL_CONST_CGS_MASS_PROTON GSL_CONST_CGS_MASS_NEUTRON GSL_CONST_CGS_RYDBERG - GSL_CONST_CGS_BOLTZMANN GSL_CONST_CGS_MOLAR_GAS GSL_CONST_CGS_STANDARD_GAS_VOLUME GSL_CONST_CGS_MINUTE - GSL_CONST_CGS_HOUR GSL_CONST_CGS_DAY GSL_CONST_CGS_WEEK GSL_CONST_CGS_INCH GSL_CONST_CGS_FOOT - GSL_CONST_CGS_YARD GSL_CONST_CGS_MILE GSL_CONST_CGS_NAUTICAL_MILE GSL_CONST_CGS_FATHOM GSL_CONST_CGS_MIL - GSL_CONST_CGS_POINT GSL_CONST_CGS_TEXPOINT GSL_CONST_CGS_MICRON GSL_CONST_CGS_ANGSTROM GSL_CONST_CGS_HECTARE - GSL_CONST_CGS_ACRE GSL_CONST_CGS_BARN GSL_CONST_CGS_LITER GSL_CONST_CGS_US_GALLON GSL_CONST_CGS_QUART - GSL_CONST_CGS_PINT GSL_CONST_CGS_CUP GSL_CONST_CGS_FLUID_OUNCE GSL_CONST_CGS_TABLESPOON GSL_CONST_CGS_TEASPOON - GSL_CONST_CGS_CANADIAN_GALLON GSL_CONST_CGS_UK_GALLON GSL_CONST_CGS_MILES_PER_HOUR GSL_CONST_CGS_KILOMETERS_PER_HOUR - GSL_CONST_CGS_KNOT GSL_CONST_CGS_POUND_MASS GSL_CONST_CGS_OUNCE_MASS GSL_CONST_CGS_TON GSL_CONST_CGS_METRIC_TON - GSL_CONST_CGS_UK_TON GSL_CONST_CGS_TROY_OUNCE GSL_CONST_CGS_CARAT GSL_CONST_CGS_UNIFIED_ATOMIC_MASS - GSL_CONST_CGS_GRAM_FORCE GSL_CONST_CGS_POUND_FORCE GSL_CONST_CGS_KILOPOUND_FORCE GSL_CONST_CGS_POUNDAL - GSL_CONST_CGS_CALORIE GSL_CONST_CGS_BTU GSL_CONST_CGS_THERM GSL_CONST_CGS_HORSEPOWER GSL_CONST_CGS_BAR - GSL_CONST_CGS_STD_ATMOSPHERE GSL_CONST_CGS_TORR GSL_CONST_CGS_METER_OF_MERCURY GSL_CONST_CGS_INCH_OF_MERCURY - GSL_CONST_CGS_INCH_OF_WATER GSL_CONST_CGS_PSI GSL_CONST_CGS_POISE GSL_CONST_CGS_STOKES GSL_CONST_CGS_STILB - GSL_CONST_CGS_LUMEN GSL_CONST_CGS_LUX GSL_CONST_CGS_PHOT GSL_CONST_CGS_FOOTCANDLE GSL_CONST_CGS_LAMBERT - GSL_CONST_CGS_FOOTLAMBERT GSL_CONST_CGS_CURIE GSL_CONST_CGS_ROENTGEN GSL_CONST_CGS_RAD GSL_CONST_CGS_SOLAR_MASS - GSL_CONST_CGS_BOHR_RADIUS GSL_CONST_CGS_NEWTON GSL_CONST_CGS_DYNE GSL_CONST_CGS_JOULE GSL_CONST_CGS_ERG - GSL_CONST_CGS_STEFAN_BOLTZMANN_CONSTANT GSL_CONST_CGS_THOMSON_CROSS_SECTION GSL_CONST_CGSM_SPEED_OF_LIGHT - GSL_CONST_CGSM_GRAVITATIONAL_CONSTANT GSL_CONST_CGSM_PLANCKS_CONSTANT_H GSL_CONST_CGSM_PLANCKS_CONSTANT_HBAR - GSL_CONST_CGSM_ASTRONOMICAL_UNIT GSL_CONST_CGSM_LIGHT_YEAR GSL_CONST_CGSM_PARSEC GSL_CONST_CGSM_GRAV_ACCEL - GSL_CONST_CGSM_ELECTRON_VOLT GSL_CONST_CGSM_MASS_ELECTRON GSL_CONST_CGSM_MASS_MUON GSL_CONST_CGSM_MASS_PROTON - GSL_CONST_CGSM_MASS_NEUTRON GSL_CONST_CGSM_RYDBERG GSL_CONST_CGSM_BOLTZMANN GSL_CONST_CGSM_MOLAR_GAS - GSL_CONST_CGSM_STANDARD_GAS_VOLUME GSL_CONST_CGSM_MINUTE GSL_CONST_CGSM_HOUR GSL_CONST_CGSM_DAY - GSL_CONST_CGSM_WEEK GSL_CONST_CGSM_INCH GSL_CONST_CGSM_FOOT GSL_CONST_CGSM_YARD GSL_CONST_CGSM_MILE - GSL_CONST_CGSM_NAUTICAL_MILE GSL_CONST_CGSM_FATHOM GSL_CONST_CGSM_MIL GSL_CONST_CGSM_POINT GSL_CONST_CGSM_TEXPOINT - GSL_CONST_CGSM_MICRON GSL_CONST_CGSM_ANGSTROM GSL_CONST_CGSM_HECTARE GSL_CONST_CGSM_ACRE GSL_CONST_CGSM_BARN - GSL_CONST_CGSM_LITER GSL_CONST_CGSM_US_GALLON GSL_CONST_CGSM_QUART GSL_CONST_CGSM_PINT GSL_CONST_CGSM_CUP - GSL_CONST_CGSM_FLUID_OUNCE GSL_CONST_CGSM_TABLESPOON GSL_CONST_CGSM_TEASPOON GSL_CONST_CGSM_CANADIAN_GALLON - GSL_CONST_CGSM_UK_GALLON GSL_CONST_CGSM_MILES_PER_HOUR GSL_CONST_CGSM_KILOMETERS_PER_HOUR GSL_CONST_CGSM_KNOT - GSL_CONST_CGSM_POUND_MASS GSL_CONST_CGSM_OUNCE_MASS GSL_CONST_CGSM_TON GSL_CONST_CGSM_METRIC_TON - GSL_CONST_CGSM_UK_TON GSL_CONST_CGSM_TROY_OUNCE GSL_CONST_CGSM_CARAT GSL_CONST_CGSM_UNIFIED_ATOMIC_MASS - GSL_CONST_CGSM_GRAM_FORCE GSL_CONST_CGSM_POUND_FORCE GSL_CONST_CGSM_KILOPOUND_FORCE GSL_CONST_CGSM_POUNDAL - GSL_CONST_CGSM_CALORIE GSL_CONST_CGSM_BTU GSL_CONST_CGSM_THERM GSL_CONST_CGSM_HORSEPOWER GSL_CONST_CGSM_BAR - GSL_CONST_CGSM_STD_ATMOSPHERE GSL_CONST_CGSM_TORR GSL_CONST_CGSM_METER_OF_MERCURY GSL_CONST_CGSM_INCH_OF_MERCURY - GSL_CONST_CGSM_INCH_OF_WATER GSL_CONST_CGSM_PSI GSL_CONST_CGSM_POISE GSL_CONST_CGSM_STOKES GSL_CONST_CGSM_STILB - GSL_CONST_CGSM_LUMEN GSL_CONST_CGSM_LUX GSL_CONST_CGSM_PHOT GSL_CONST_CGSM_FOOTCANDLE GSL_CONST_CGSM_LAMBERT - GSL_CONST_CGSM_FOOTLAMBERT GSL_CONST_CGSM_CURIE GSL_CONST_CGSM_ROENTGEN GSL_CONST_CGSM_RAD GSL_CONST_CGSM_SOLAR_MASS - GSL_CONST_CGSM_BOHR_RADIUS GSL_CONST_CGSM_NEWTON GSL_CONST_CGSM_DYNE GSL_CONST_CGSM_JOULE GSL_CONST_CGSM_ERG - GSL_CONST_CGSM_STEFAN_BOLTZMANN_CONSTANT GSL_CONST_CGSM_THOMSON_CROSS_SECTION GSL_CONST_CGSM_BOHR_MAGNETON - GSL_CONST_CGSM_NUCLEAR_MAGNETON GSL_CONST_CGSM_ELECTRON_MAGNETIC_MOMENT GSL_CONST_CGSM_PROTON_MAGNETIC_MOMENT - GSL_CONST_CGSM_FARADAY GSL_CONST_CGSM_ELECTRON_CHARGE GSL_CONST_MKS_SPEED_OF_LIGHT GSL_CONST_MKS_GRAVITATIONAL_CONSTANT - GSL_CONST_MKS_PLANCKS_CONSTANT_H GSL_CONST_MKS_PLANCKS_CONSTANT_HBAR GSL_CONST_MKS_ASTRONOMICAL_UNIT - GSL_CONST_MKS_LIGHT_YEAR GSL_CONST_MKS_PARSEC GSL_CONST_MKS_GRAV_ACCEL GSL_CONST_MKS_ELECTRON_VOLT - GSL_CONST_MKS_MASS_ELECTRON GSL_CONST_MKS_MASS_MUON GSL_CONST_MKS_MASS_PROTON GSL_CONST_MKS_MASS_NEUTRON - GSL_CONST_MKS_RYDBERG GSL_CONST_MKS_BOLTZMANN GSL_CONST_MKS_MOLAR_GAS GSL_CONST_MKS_STANDARD_GAS_VOLUME - GSL_CONST_MKS_MINUTE GSL_CONST_MKS_HOUR GSL_CONST_MKS_DAY GSL_CONST_MKS_WEEK GSL_CONST_MKS_INCH GSL_CONST_MKS_FOOT - GSL_CONST_MKS_YARD GSL_CONST_MKS_MILE GSL_CONST_MKS_NAUTICAL_MILE GSL_CONST_MKS_FATHOM GSL_CONST_MKS_MIL - GSL_CONST_MKS_POINT GSL_CONST_MKS_TEXPOINT GSL_CONST_MKS_MICRON GSL_CONST_MKS_ANGSTROM GSL_CONST_MKS_HECTARE - GSL_CONST_MKS_ACRE GSL_CONST_MKS_BARN GSL_CONST_MKS_LITER GSL_CONST_MKS_US_GALLON GSL_CONST_MKS_QUART - GSL_CONST_MKS_PINT GSL_CONST_MKS_CUP GSL_CONST_MKS_FLUID_OUNCE GSL_CONST_MKS_TABLESPOON GSL_CONST_MKS_TEASPOON - GSL_CONST_MKS_CANADIAN_GALLON GSL_CONST_MKS_UK_GALLON GSL_CONST_MKS_MILES_PER_HOUR GSL_CONST_MKS_KILOMETERS_PER_HOUR - GSL_CONST_MKS_KNOT GSL_CONST_MKS_POUND_MASS GSL_CONST_MKS_OUNCE_MASS GSL_CONST_MKS_TON GSL_CONST_MKS_METRIC_TON - GSL_CONST_MKS_UK_TON GSL_CONST_MKS_TROY_OUNCE GSL_CONST_MKS_CARAT GSL_CONST_MKS_UNIFIED_ATOMIC_MASS - GSL_CONST_MKS_GRAM_FORCE GSL_CONST_MKS_POUND_FORCE GSL_CONST_MKS_KILOPOUND_FORCE GSL_CONST_MKS_POUNDAL - GSL_CONST_MKS_CALORIE GSL_CONST_MKS_BTU GSL_CONST_MKS_THERM GSL_CONST_MKS_HORSEPOWER GSL_CONST_MKS_BAR - GSL_CONST_MKS_STD_ATMOSPHERE GSL_CONST_MKS_TORR GSL_CONST_MKS_METER_OF_MERCURY GSL_CONST_MKS_INCH_OF_MERCURY - GSL_CONST_MKS_INCH_OF_WATER GSL_CONST_MKS_PSI GSL_CONST_MKS_POISE GSL_CONST_MKS_STOKES GSL_CONST_MKS_STILB - GSL_CONST_MKS_LUMEN GSL_CONST_MKS_LUX GSL_CONST_MKS_PHOT GSL_CONST_MKS_FOOTCANDLE GSL_CONST_MKS_LAMBERT GSL_CONST_MKS_FOOTLAMBERT - GSL_CONST_MKS_CURIE GSL_CONST_MKS_ROENTGEN GSL_CONST_MKS_RAD GSL_CONST_MKS_SOLAR_MASS GSL_CONST_MKS_BOHR_RADIUS - GSL_CONST_MKS_NEWTON GSL_CONST_MKS_DYNE GSL_CONST_MKS_JOULE GSL_CONST_MKS_ERG GSL_CONST_MKS_STEFAN_BOLTZMANN_CONSTANT - GSL_CONST_MKS_THOMSON_CROSS_SECTION GSL_CONST_MKS_BOHR_MAGNETON GSL_CONST_MKS_NUCLEAR_MAGNETON - GSL_CONST_MKS_ELECTRON_MAGNETIC_MOMENT GSL_CONST_MKS_PROTON_MAGNETIC_MOMENT GSL_CONST_MKS_FARADAY - GSL_CONST_MKS_ELECTRON_CHARGE GSL_CONST_MKS_VACUUM_PERMITTIVITY GSL_CONST_MKS_VACUUM_PERMEABILITY GSL_CONST_MKS_DEBYE - GSL_CONST_MKS_GAUSS GSL_CONST_MKSA_SPEED_OF_LIGHT GSL_CONST_MKSA_GRAVITATIONAL_CONSTANT GSL_CONST_MKSA_PLANCKS_CONSTANT_H - GSL_CONST_MKSA_PLANCKS_CONSTANT_HBAR GSL_CONST_MKSA_ASTRONOMICAL_UNIT GSL_CONST_MKSA_LIGHT_YEAR GSL_CONST_MKSA_PARSEC - GSL_CONST_MKSA_GRAV_ACCEL GSL_CONST_MKSA_ELECTRON_VOLT GSL_CONST_MKSA_MASS_ELECTRON GSL_CONST_MKSA_MASS_MUON - GSL_CONST_MKSA_MASS_PROTON GSL_CONST_MKSA_MASS_NEUTRON GSL_CONST_MKSA_RYDBERG GSL_CONST_MKSA_BOLTZMANN - GSL_CONST_MKSA_MOLAR_GAS GSL_CONST_MKSA_STANDARD_GAS_VOLUME GSL_CONST_MKSA_MINUTE GSL_CONST_MKSA_HOUR - GSL_CONST_MKSA_DAY GSL_CONST_MKSA_WEEK GSL_CONST_MKSA_INCH GSL_CONST_MKSA_FOOT GSL_CONST_MKSA_YARD - GSL_CONST_MKSA_MILE GSL_CONST_MKSA_NAUTICAL_MILE GSL_CONST_MKSA_FATHOM GSL_CONST_MKSA_MIL GSL_CONST_MKSA_POINT - GSL_CONST_MKSA_TEXPOINT GSL_CONST_MKSA_MICRON GSL_CONST_MKSA_ANGSTROM GSL_CONST_MKSA_HECTARE GSL_CONST_MKSA_ACRE - GSL_CONST_MKSA_BARN GSL_CONST_MKSA_LITER GSL_CONST_MKSA_US_GALLON GSL_CONST_MKSA_QUART GSL_CONST_MKSA_PINT - GSL_CONST_MKSA_CUP GSL_CONST_MKSA_FLUID_OUNCE GSL_CONST_MKSA_TABLESPOON GSL_CONST_MKSA_TEASPOON GSL_CONST_MKSA_CANADIAN_GALLON - GSL_CONST_MKSA_UK_GALLON GSL_CONST_MKSA_MILES_PER_HOUR GSL_CONST_MKSA_KILOMETERS_PER_HOUR GSL_CONST_MKSA_KNOT - GSL_CONST_MKSA_POUND_MASS GSL_CONST_MKSA_OUNCE_MASS GSL_CONST_MKSA_TON GSL_CONST_MKSA_METRIC_TON GSL_CONST_MKSA_UK_TON - GSL_CONST_MKSA_TROY_OUNCE GSL_CONST_MKSA_CARAT GSL_CONST_MKSA_UNIFIED_ATOMIC_MASS GSL_CONST_MKSA_GRAM_FORCE - GSL_CONST_MKSA_POUND_FORCE GSL_CONST_MKSA_KILOPOUND_FORCE GSL_CONST_MKSA_POUNDAL GSL_CONST_MKSA_CALORIE GSL_CONST_MKSA_BTU - GSL_CONST_MKSA_THERM GSL_CONST_MKSA_HORSEPOWER GSL_CONST_MKSA_BAR GSL_CONST_MKSA_STD_ATMOSPHERE GSL_CONST_MKSA_TORR - GSL_CONST_MKSA_METER_OF_MERCURY GSL_CONST_MKSA_INCH_OF_MERCURY GSL_CONST_MKSA_INCH_OF_WATER GSL_CONST_MKSA_PSI - GSL_CONST_MKSA_POISE GSL_CONST_MKSA_STOKES GSL_CONST_MKSA_STILB GSL_CONST_MKSA_LUMEN GSL_CONST_MKSA_LUX GSL_CONST_MKSA_PHOT - GSL_CONST_MKSA_FOOTCANDLE GSL_CONST_MKSA_LAMBERT GSL_CONST_MKSA_FOOTLAMBERT GSL_CONST_MKSA_CURIE GSL_CONST_MKSA_ROENTGEN - GSL_CONST_MKSA_RAD GSL_CONST_MKSA_SOLAR_MASS GSL_CONST_MKSA_BOHR_RADIUS GSL_CONST_MKSA_NEWTON GSL_CONST_MKSA_DYNE - GSL_CONST_MKSA_JOULE GSL_CONST_MKSA_ERG GSL_CONST_MKSA_STEFAN_BOLTZMANN_CONSTANT GSL_CONST_MKSA_THOMSON_CROSS_SECTION - GSL_CONST_MKSA_BOHR_MAGNETON GSL_CONST_MKSA_NUCLEAR_MAGNETON GSL_CONST_MKSA_ELECTRON_MAGNETIC_MOMENT - GSL_CONST_MKSA_PROTON_MAGNETIC_MOMENT GSL_CONST_MKSA_FARADAY GSL_CONST_MKSA_ELECTRON_CHARGE GSL_CONST_MKSA_VACUUM_PERMITTIVITY - GSL_CONST_MKSA_VACUUM_PERMEABILITY GSL_CONST_MKSA_DEBYE GSL_CONST_MKSA_GAUSS GSL_CONST_NUM_FINE_STRUCTURE GSL_CONST_NUM_AVOGADRO - GSL_CONST_NUM_YOTTA GSL_CONST_NUM_ZETTA GSL_CONST_NUM_EXA GSL_CONST_NUM_PETA GSL_CONST_NUM_TERA GSL_CONST_NUM_GIGA - GSL_CONST_NUM_MEGA GSL_CONST_NUM_KILO GSL_CONST_NUM_MILLI GSL_CONST_NUM_MICRO GSL_CONST_NUM_NANO GSL_CONST_NUM_PICO + (c-define + '((C-macro (double (GSL_CONST_CGS_SPEED_OF_LIGHT GSL_CONST_CGS_GRAVITATIONAL_CONSTANT GSL_CONST_CGS_PLANCKS_CONSTANT_H + GSL_CONST_CGS_PLANCKS_CONSTANT_HBAR GSL_CONST_CGS_ASTRONOMICAL_UNIT GSL_CONST_CGS_LIGHT_YEAR + GSL_CONST_CGS_PARSEC GSL_CONST_CGS_GRAV_ACCEL GSL_CONST_CGS_ELECTRON_VOLT GSL_CONST_CGS_MASS_ELECTRON + GSL_CONST_CGS_MASS_MUON GSL_CONST_CGS_MASS_PROTON GSL_CONST_CGS_MASS_NEUTRON GSL_CONST_CGS_RYDBERG + GSL_CONST_CGS_BOLTZMANN GSL_CONST_CGS_MOLAR_GAS GSL_CONST_CGS_STANDARD_GAS_VOLUME GSL_CONST_CGS_MINUTE + GSL_CONST_CGS_HOUR GSL_CONST_CGS_DAY GSL_CONST_CGS_WEEK GSL_CONST_CGS_INCH GSL_CONST_CGS_FOOT + GSL_CONST_CGS_YARD GSL_CONST_CGS_MILE GSL_CONST_CGS_NAUTICAL_MILE GSL_CONST_CGS_FATHOM GSL_CONST_CGS_MIL + GSL_CONST_CGS_POINT GSL_CONST_CGS_TEXPOINT GSL_CONST_CGS_MICRON GSL_CONST_CGS_ANGSTROM GSL_CONST_CGS_HECTARE + GSL_CONST_CGS_ACRE GSL_CONST_CGS_BARN GSL_CONST_CGS_LITER GSL_CONST_CGS_US_GALLON GSL_CONST_CGS_QUART + GSL_CONST_CGS_PINT GSL_CONST_CGS_CUP GSL_CONST_CGS_FLUID_OUNCE GSL_CONST_CGS_TABLESPOON GSL_CONST_CGS_TEASPOON + GSL_CONST_CGS_CANADIAN_GALLON GSL_CONST_CGS_UK_GALLON GSL_CONST_CGS_MILES_PER_HOUR GSL_CONST_CGS_KILOMETERS_PER_HOUR + GSL_CONST_CGS_KNOT GSL_CONST_CGS_POUND_MASS GSL_CONST_CGS_OUNCE_MASS GSL_CONST_CGS_TON GSL_CONST_CGS_METRIC_TON + GSL_CONST_CGS_UK_TON GSL_CONST_CGS_TROY_OUNCE GSL_CONST_CGS_CARAT GSL_CONST_CGS_UNIFIED_ATOMIC_MASS + GSL_CONST_CGS_GRAM_FORCE GSL_CONST_CGS_POUND_FORCE GSL_CONST_CGS_KILOPOUND_FORCE GSL_CONST_CGS_POUNDAL + GSL_CONST_CGS_CALORIE GSL_CONST_CGS_BTU GSL_CONST_CGS_THERM GSL_CONST_CGS_HORSEPOWER GSL_CONST_CGS_BAR + GSL_CONST_CGS_STD_ATMOSPHERE GSL_CONST_CGS_TORR GSL_CONST_CGS_METER_OF_MERCURY GSL_CONST_CGS_INCH_OF_MERCURY + GSL_CONST_CGS_INCH_OF_WATER GSL_CONST_CGS_PSI GSL_CONST_CGS_POISE GSL_CONST_CGS_STOKES GSL_CONST_CGS_STILB + GSL_CONST_CGS_LUMEN GSL_CONST_CGS_LUX GSL_CONST_CGS_PHOT GSL_CONST_CGS_FOOTCANDLE GSL_CONST_CGS_LAMBERT + GSL_CONST_CGS_FOOTLAMBERT GSL_CONST_CGS_CURIE GSL_CONST_CGS_ROENTGEN GSL_CONST_CGS_RAD GSL_CONST_CGS_SOLAR_MASS + GSL_CONST_CGS_BOHR_RADIUS GSL_CONST_CGS_NEWTON GSL_CONST_CGS_DYNE GSL_CONST_CGS_JOULE GSL_CONST_CGS_ERG + GSL_CONST_CGS_STEFAN_BOLTZMANN_CONSTANT GSL_CONST_CGS_THOMSON_CROSS_SECTION GSL_CONST_CGSM_SPEED_OF_LIGHT + GSL_CONST_CGSM_GRAVITATIONAL_CONSTANT GSL_CONST_CGSM_PLANCKS_CONSTANT_H GSL_CONST_CGSM_PLANCKS_CONSTANT_HBAR + GSL_CONST_CGSM_ASTRONOMICAL_UNIT GSL_CONST_CGSM_LIGHT_YEAR GSL_CONST_CGSM_PARSEC GSL_CONST_CGSM_GRAV_ACCEL + GSL_CONST_CGSM_ELECTRON_VOLT GSL_CONST_CGSM_MASS_ELECTRON GSL_CONST_CGSM_MASS_MUON GSL_CONST_CGSM_MASS_PROTON + GSL_CONST_CGSM_MASS_NEUTRON GSL_CONST_CGSM_RYDBERG GSL_CONST_CGSM_BOLTZMANN GSL_CONST_CGSM_MOLAR_GAS + GSL_CONST_CGSM_STANDARD_GAS_VOLUME GSL_CONST_CGSM_MINUTE GSL_CONST_CGSM_HOUR GSL_CONST_CGSM_DAY + GSL_CONST_CGSM_WEEK GSL_CONST_CGSM_INCH GSL_CONST_CGSM_FOOT GSL_CONST_CGSM_YARD GSL_CONST_CGSM_MILE + GSL_CONST_CGSM_NAUTICAL_MILE GSL_CONST_CGSM_FATHOM GSL_CONST_CGSM_MIL GSL_CONST_CGSM_POINT GSL_CONST_CGSM_TEXPOINT + GSL_CONST_CGSM_MICRON GSL_CONST_CGSM_ANGSTROM GSL_CONST_CGSM_HECTARE GSL_CONST_CGSM_ACRE GSL_CONST_CGSM_BARN + GSL_CONST_CGSM_LITER GSL_CONST_CGSM_US_GALLON GSL_CONST_CGSM_QUART GSL_CONST_CGSM_PINT GSL_CONST_CGSM_CUP + GSL_CONST_CGSM_FLUID_OUNCE GSL_CONST_CGSM_TABLESPOON GSL_CONST_CGSM_TEASPOON GSL_CONST_CGSM_CANADIAN_GALLON + GSL_CONST_CGSM_UK_GALLON GSL_CONST_CGSM_MILES_PER_HOUR GSL_CONST_CGSM_KILOMETERS_PER_HOUR GSL_CONST_CGSM_KNOT + GSL_CONST_CGSM_POUND_MASS GSL_CONST_CGSM_OUNCE_MASS GSL_CONST_CGSM_TON GSL_CONST_CGSM_METRIC_TON + GSL_CONST_CGSM_UK_TON GSL_CONST_CGSM_TROY_OUNCE GSL_CONST_CGSM_CARAT GSL_CONST_CGSM_UNIFIED_ATOMIC_MASS + GSL_CONST_CGSM_GRAM_FORCE GSL_CONST_CGSM_POUND_FORCE GSL_CONST_CGSM_KILOPOUND_FORCE GSL_CONST_CGSM_POUNDAL + GSL_CONST_CGSM_CALORIE GSL_CONST_CGSM_BTU GSL_CONST_CGSM_THERM GSL_CONST_CGSM_HORSEPOWER GSL_CONST_CGSM_BAR + GSL_CONST_CGSM_STD_ATMOSPHERE GSL_CONST_CGSM_TORR GSL_CONST_CGSM_METER_OF_MERCURY GSL_CONST_CGSM_INCH_OF_MERCURY + GSL_CONST_CGSM_INCH_OF_WATER GSL_CONST_CGSM_PSI GSL_CONST_CGSM_POISE GSL_CONST_CGSM_STOKES GSL_CONST_CGSM_STILB + GSL_CONST_CGSM_LUMEN GSL_CONST_CGSM_LUX GSL_CONST_CGSM_PHOT GSL_CONST_CGSM_FOOTCANDLE GSL_CONST_CGSM_LAMBERT + GSL_CONST_CGSM_FOOTLAMBERT GSL_CONST_CGSM_CURIE GSL_CONST_CGSM_ROENTGEN GSL_CONST_CGSM_RAD GSL_CONST_CGSM_SOLAR_MASS + GSL_CONST_CGSM_BOHR_RADIUS GSL_CONST_CGSM_NEWTON GSL_CONST_CGSM_DYNE GSL_CONST_CGSM_JOULE GSL_CONST_CGSM_ERG + GSL_CONST_CGSM_STEFAN_BOLTZMANN_CONSTANT GSL_CONST_CGSM_THOMSON_CROSS_SECTION GSL_CONST_CGSM_BOHR_MAGNETON + GSL_CONST_CGSM_NUCLEAR_MAGNETON GSL_CONST_CGSM_ELECTRON_MAGNETIC_MOMENT GSL_CONST_CGSM_PROTON_MAGNETIC_MOMENT + GSL_CONST_CGSM_FARADAY GSL_CONST_CGSM_ELECTRON_CHARGE GSL_CONST_MKS_SPEED_OF_LIGHT GSL_CONST_MKS_GRAVITATIONAL_CONSTANT + GSL_CONST_MKS_PLANCKS_CONSTANT_H GSL_CONST_MKS_PLANCKS_CONSTANT_HBAR GSL_CONST_MKS_ASTRONOMICAL_UNIT + GSL_CONST_MKS_LIGHT_YEAR GSL_CONST_MKS_PARSEC GSL_CONST_MKS_GRAV_ACCEL GSL_CONST_MKS_ELECTRON_VOLT + GSL_CONST_MKS_MASS_ELECTRON GSL_CONST_MKS_MASS_MUON GSL_CONST_MKS_MASS_PROTON GSL_CONST_MKS_MASS_NEUTRON + GSL_CONST_MKS_RYDBERG GSL_CONST_MKS_BOLTZMANN GSL_CONST_MKS_MOLAR_GAS GSL_CONST_MKS_STANDARD_GAS_VOLUME + GSL_CONST_MKS_MINUTE GSL_CONST_MKS_HOUR GSL_CONST_MKS_DAY GSL_CONST_MKS_WEEK GSL_CONST_MKS_INCH GSL_CONST_MKS_FOOT + GSL_CONST_MKS_YARD GSL_CONST_MKS_MILE GSL_CONST_MKS_NAUTICAL_MILE GSL_CONST_MKS_FATHOM GSL_CONST_MKS_MIL + GSL_CONST_MKS_POINT GSL_CONST_MKS_TEXPOINT GSL_CONST_MKS_MICRON GSL_CONST_MKS_ANGSTROM GSL_CONST_MKS_HECTARE + GSL_CONST_MKS_ACRE GSL_CONST_MKS_BARN GSL_CONST_MKS_LITER GSL_CONST_MKS_US_GALLON GSL_CONST_MKS_QUART + GSL_CONST_MKS_PINT GSL_CONST_MKS_CUP GSL_CONST_MKS_FLUID_OUNCE GSL_CONST_MKS_TABLESPOON GSL_CONST_MKS_TEASPOON + GSL_CONST_MKS_CANADIAN_GALLON GSL_CONST_MKS_UK_GALLON GSL_CONST_MKS_MILES_PER_HOUR GSL_CONST_MKS_KILOMETERS_PER_HOUR + GSL_CONST_MKS_KNOT GSL_CONST_MKS_POUND_MASS GSL_CONST_MKS_OUNCE_MASS GSL_CONST_MKS_TON GSL_CONST_MKS_METRIC_TON + GSL_CONST_MKS_UK_TON GSL_CONST_MKS_TROY_OUNCE GSL_CONST_MKS_CARAT GSL_CONST_MKS_UNIFIED_ATOMIC_MASS + GSL_CONST_MKS_GRAM_FORCE GSL_CONST_MKS_POUND_FORCE GSL_CONST_MKS_KILOPOUND_FORCE GSL_CONST_MKS_POUNDAL + GSL_CONST_MKS_CALORIE GSL_CONST_MKS_BTU GSL_CONST_MKS_THERM GSL_CONST_MKS_HORSEPOWER GSL_CONST_MKS_BAR + GSL_CONST_MKS_STD_ATMOSPHERE GSL_CONST_MKS_TORR GSL_CONST_MKS_METER_OF_MERCURY GSL_CONST_MKS_INCH_OF_MERCURY + GSL_CONST_MKS_INCH_OF_WATER GSL_CONST_MKS_PSI GSL_CONST_MKS_POISE GSL_CONST_MKS_STOKES GSL_CONST_MKS_STILB + GSL_CONST_MKS_LUMEN GSL_CONST_MKS_LUX GSL_CONST_MKS_PHOT GSL_CONST_MKS_FOOTCANDLE GSL_CONST_MKS_LAMBERT GSL_CONST_MKS_FOOTLAMBERT + GSL_CONST_MKS_CURIE GSL_CONST_MKS_ROENTGEN GSL_CONST_MKS_RAD GSL_CONST_MKS_SOLAR_MASS GSL_CONST_MKS_BOHR_RADIUS + GSL_CONST_MKS_NEWTON GSL_CONST_MKS_DYNE GSL_CONST_MKS_JOULE GSL_CONST_MKS_ERG GSL_CONST_MKS_STEFAN_BOLTZMANN_CONSTANT + GSL_CONST_MKS_THOMSON_CROSS_SECTION GSL_CONST_MKS_BOHR_MAGNETON GSL_CONST_MKS_NUCLEAR_MAGNETON + GSL_CONST_MKS_ELECTRON_MAGNETIC_MOMENT GSL_CONST_MKS_PROTON_MAGNETIC_MOMENT GSL_CONST_MKS_FARADAY + GSL_CONST_MKS_ELECTRON_CHARGE GSL_CONST_MKS_VACUUM_PERMITTIVITY GSL_CONST_MKS_VACUUM_PERMEABILITY GSL_CONST_MKS_DEBYE + GSL_CONST_MKS_GAUSS GSL_CONST_MKSA_SPEED_OF_LIGHT GSL_CONST_MKSA_GRAVITATIONAL_CONSTANT GSL_CONST_MKSA_PLANCKS_CONSTANT_H + GSL_CONST_MKSA_PLANCKS_CONSTANT_HBAR GSL_CONST_MKSA_ASTRONOMICAL_UNIT GSL_CONST_MKSA_LIGHT_YEAR GSL_CONST_MKSA_PARSEC + GSL_CONST_MKSA_GRAV_ACCEL GSL_CONST_MKSA_ELECTRON_VOLT GSL_CONST_MKSA_MASS_ELECTRON GSL_CONST_MKSA_MASS_MUON + GSL_CONST_MKSA_MASS_PROTON GSL_CONST_MKSA_MASS_NEUTRON GSL_CONST_MKSA_RYDBERG GSL_CONST_MKSA_BOLTZMANN + GSL_CONST_MKSA_MOLAR_GAS GSL_CONST_MKSA_STANDARD_GAS_VOLUME GSL_CONST_MKSA_MINUTE GSL_CONST_MKSA_HOUR + GSL_CONST_MKSA_DAY GSL_CONST_MKSA_WEEK GSL_CONST_MKSA_INCH GSL_CONST_MKSA_FOOT GSL_CONST_MKSA_YARD + GSL_CONST_MKSA_MILE GSL_CONST_MKSA_NAUTICAL_MILE GSL_CONST_MKSA_FATHOM GSL_CONST_MKSA_MIL GSL_CONST_MKSA_POINT + GSL_CONST_MKSA_TEXPOINT GSL_CONST_MKSA_MICRON GSL_CONST_MKSA_ANGSTROM GSL_CONST_MKSA_HECTARE GSL_CONST_MKSA_ACRE + GSL_CONST_MKSA_BARN GSL_CONST_MKSA_LITER GSL_CONST_MKSA_US_GALLON GSL_CONST_MKSA_QUART GSL_CONST_MKSA_PINT + GSL_CONST_MKSA_CUP GSL_CONST_MKSA_FLUID_OUNCE GSL_CONST_MKSA_TABLESPOON GSL_CONST_MKSA_TEASPOON GSL_CONST_MKSA_CANADIAN_GALLON + GSL_CONST_MKSA_UK_GALLON GSL_CONST_MKSA_MILES_PER_HOUR GSL_CONST_MKSA_KILOMETERS_PER_HOUR GSL_CONST_MKSA_KNOT + GSL_CONST_MKSA_POUND_MASS GSL_CONST_MKSA_OUNCE_MASS GSL_CONST_MKSA_TON GSL_CONST_MKSA_METRIC_TON GSL_CONST_MKSA_UK_TON + GSL_CONST_MKSA_TROY_OUNCE GSL_CONST_MKSA_CARAT GSL_CONST_MKSA_UNIFIED_ATOMIC_MASS GSL_CONST_MKSA_GRAM_FORCE + GSL_CONST_MKSA_POUND_FORCE GSL_CONST_MKSA_KILOPOUND_FORCE GSL_CONST_MKSA_POUNDAL GSL_CONST_MKSA_CALORIE GSL_CONST_MKSA_BTU + GSL_CONST_MKSA_THERM GSL_CONST_MKSA_HORSEPOWER GSL_CONST_MKSA_BAR GSL_CONST_MKSA_STD_ATMOSPHERE GSL_CONST_MKSA_TORR + GSL_CONST_MKSA_METER_OF_MERCURY GSL_CONST_MKSA_INCH_OF_MERCURY GSL_CONST_MKSA_INCH_OF_WATER GSL_CONST_MKSA_PSI + GSL_CONST_MKSA_POISE GSL_CONST_MKSA_STOKES GSL_CONST_MKSA_STILB GSL_CONST_MKSA_LUMEN GSL_CONST_MKSA_LUX GSL_CONST_MKSA_PHOT + GSL_CONST_MKSA_FOOTCANDLE GSL_CONST_MKSA_LAMBERT GSL_CONST_MKSA_FOOTLAMBERT GSL_CONST_MKSA_CURIE GSL_CONST_MKSA_ROENTGEN + GSL_CONST_MKSA_RAD GSL_CONST_MKSA_SOLAR_MASS GSL_CONST_MKSA_BOHR_RADIUS GSL_CONST_MKSA_NEWTON GSL_CONST_MKSA_DYNE + GSL_CONST_MKSA_JOULE GSL_CONST_MKSA_ERG GSL_CONST_MKSA_STEFAN_BOLTZMANN_CONSTANT GSL_CONST_MKSA_THOMSON_CROSS_SECTION + GSL_CONST_MKSA_BOHR_MAGNETON GSL_CONST_MKSA_NUCLEAR_MAGNETON GSL_CONST_MKSA_ELECTRON_MAGNETIC_MOMENT + GSL_CONST_MKSA_PROTON_MAGNETIC_MOMENT GSL_CONST_MKSA_FARADAY GSL_CONST_MKSA_ELECTRON_CHARGE GSL_CONST_MKSA_VACUUM_PERMITTIVITY + GSL_CONST_MKSA_VACUUM_PERMEABILITY GSL_CONST_MKSA_DEBYE GSL_CONST_MKSA_GAUSS GSL_CONST_NUM_FINE_STRUCTURE GSL_CONST_NUM_AVOGADRO + GSL_CONST_NUM_YOTTA GSL_CONST_NUM_ZETTA GSL_CONST_NUM_EXA GSL_CONST_NUM_PETA GSL_CONST_NUM_TERA GSL_CONST_NUM_GIGA + GSL_CONST_NUM_MEGA GSL_CONST_NUM_KILO GSL_CONST_NUM_MILLI GSL_CONST_NUM_MICRO GSL_CONST_NUM_NANO GSL_CONST_NUM_PICO GSL_CONST_NUM_FEMTO GSL_CONST_NUM_ATTO GSL_CONST_NUM_ZEPTO GSL_CONST_NUM_YOCTO GSL_DBL_EPSILON GSL_SQRT_DBL_EPSILON GSL_ROOT3_DBL_EPSILON GSL_ROOT4_DBL_EPSILON GSL_ROOT5_DBL_EPSILON GSL_ROOT6_DBL_EPSILON GSL_LOG_DBL_EPSILON GSL_DBL_MIN GSL_SQRT_DBL_MIN GSL_ROOT3_DBL_MIN GSL_ROOT4_DBL_MIN @@ -171,7 +171,7 @@ GSL_ROOT6_FLT_MAX GSL_LOG_FLT_MAX GSL_SFLT_EPSILON GSL_SQRT_SFLT_EPSILON GSL_ROOT3_SFLT_EPSILON GSL_ROOT4_SFLT_EPSILON GSL_ROOT5_SFLT_EPSILON GSL_ROOT6_SFLT_EPSILON GSL_LOG_SFLT_EPSILON GSL_MACH_EPS GSL_SQRT_MACH_EPS GSL_ROOT3_MACH_EPS GSL_ROOT4_MACH_EPS GSL_ROOT5_MACH_EPS GSL_ROOT6_MACH_EPS GSL_LOG_MACH_EPS))) - + (int (GSL_SUCCESS GSL_FAILURE GSL_CONTINUE GSL_EDOM GSL_ERANGE GSL_EFAULT GSL_EINVAL GSL_EFAILED GSL_EFACTOR GSL_ESANITY GSL_ENOMEM GSL_EBADFUNC GSL_ERUNAWAY GSL_EMAXITER GSL_EZERODIV GSL_EBADTOL GSL_ETOL GSL_EUNDRFLW GSL_EOVRFLW GSL_ELOSS GSL_EROUND GSL_EBADLEN GSL_ENOTSQR GSL_ESING GSL_EDIVERGE GSL_EUNSUP GSL_EUNIMPL GSL_ECACHE GSL_ETABLE @@ -188,20 +188,20 @@ GSL_MESSAGE_MASK_A GSL_MESSAGE_MASK_B GSL_MESSAGE_MASK_C GSL_MESSAGE_MASK_D GSL_MESSAGE_MASK_E GSL_MESSAGE_MASK_F GSL_MESSAGE_MASK_G GSL_MESSAGE_MASK_H gsl_wavelet_forward gsl_wavelet_backward)) - + (C-macro (int (GSL_PREC_DOUBLE GSL_PREC_SINGLE GSL_PREC_APPROX GSL_SF_MATHIEU_COEFF GSL_SF_FACT_NMAX GSL_SF_DOUBLEFACT_NMAX GSL_MAJOR_VERSION GSL_MINOR_VERSION - GSL_MODE_DEFAULT + GSL_MODE_DEFAULT GSL_INTEG_COSINE GSL_INTEG_SINE))) - + (C-macro (double (GSL_SF_GAMMA_XMAX GSL_POSINF GSL_NEGINF GSL_NAN GSL_POSZERO GSL_NEGZERO))) - + (C-macro (char* GSL_VERSION)) - + (int (CblasRowMajor CblasColMajor CblasNoTrans CblasTrans CblasConjTrans CblasUpper CblasLower CblasNonUnit CblasUnit CblasLeft CblasRight)) - + (in-C "static s7_pointer g_free(s7_scheme *sc, s7_pointer args) {free(s7_c_pointer(s7_car(args))); return(s7_f(sc));}") (C-function ("free" g_free "" 1)) @@ -210,9 +210,9 @@ (in-C " static s7_scheme *gsl_error_s7; static void g_gsl_error(const char *reason, const char *file, int line, int gsl_errno) - { + { s7_error(gsl_error_s7, s7_make_symbol(gsl_error_s7, \"gsl-error\"), - s7_list(gsl_error_s7, 5, + s7_list(gsl_error_s7, 5, s7_make_string(gsl_error_s7, \"GSL: ~A, ~A in ~A line ~A\"), s7_make_string(gsl_error_s7, gsl_strerror(gsl_errno)), s7_make_string(gsl_error_s7, reason), @@ -222,13 +222,13 @@ (C-init "gsl_error_s7 = sc;") (C-init "gsl_set_error_handler(g_gsl_error);") (C-init "s7_define(sc, cur_env, s7_make_symbol(sc, \"version\"), s7_make_string(sc, (char *)gsl_version));") - + (C-macro (int (GSL_SF_LEGENDRE_SCHMIDT GSL_SF_LEGENDRE_SPHARM GSL_SF_LEGENDRE_FULL GSL_SF_LEGENDRE_NONE))) - + ;; special functions ;; ((*libgsl* 'gsl_sf_bessel_J0) 1.0) -> 0.7651976865579666 ;; (let ((sfr ((*libgsl* 'gsl_sf_result.make)))) ((*libgsl* 'gsl_sf_bessel_J0_e) 1.0 sfr) ((*libgsl* 'gsl_sf_result.val) sfr)) - + (int gsl_sf_airy_Ai_e (double int gsl_sf_result*)) (double gsl_sf_airy_Ai (double int)) (int gsl_sf_airy_Bi_e (double int gsl_sf_result*)) @@ -414,7 +414,7 @@ (reader-cond ((< gsl-version 2.0) (int gsl_sf_ellint_D_e (double double double int gsl_sf_result*)) (double gsl_sf_ellint_D (double double double int))) - (#t + (#t (int gsl_sf_ellint_D_e (double double int gsl_sf_result*)) (double gsl_sf_ellint_D (double double int)))) (int gsl_sf_ellint_RC_e (double double int gsl_sf_result*)) @@ -610,7 +610,7 @@ (double gsl_sf_legendre_Plm (int int double)) (int gsl_sf_legendre_sphPlm_e (int int double gsl_sf_result*)) (double gsl_sf_legendre_sphPlm (int int double)) - + (reader-cond ((< gsl-version 2.0) (int gsl_sf_legendre_array_size (int int)) (int gsl_sf_legendre_Plm_array (int int double double*)) @@ -794,7 +794,7 @@ (double gsl_sf_eta_int (int)) (int gsl_sf_eta_e (double gsl_sf_result*)) (double gsl_sf_eta (double)) - + (in-C " static s7_pointer g_gsl_sf_result_make(s7_scheme *sc, s7_pointer args) { @@ -830,7 +830,7 @@ return(s7_car(args)); } ") - + (C-function ("gsl_sf_result.make" g_gsl_sf_result_make "" 0)) (C-function ("gsl_sf_result.free" g_gsl_sf_result_free "" 1)) (C-function ("gsl_sf_result_e10.make" g_gsl_sf_result_e10_make "" 0)) @@ -838,7 +838,7 @@ (C-function ("gsl_sf_result.err" g_gsl_sf_result_err "" 1)) (C-function ("double*" g_to_doubles "" 1)) (C-function ("wrap-double*" g_to_wrapped_doubles "" 1)) - + (double gsl_log1p (double)) (double gsl_expm1 (double)) (double gsl_hypot (double double)) @@ -855,7 +855,7 @@ (double gsl_fdiv (double double)) (double gsl_coerce_double (double)) (double gsl_ldexp (double int)) - + (in-C " static s7_pointer g_gsl_frexp(s7_scheme *sc, s7_pointer args) { @@ -866,7 +866,7 @@ } ") (C-function ("gsl_frexp" g_gsl_frexp "" 1)) - + (int gsl_fcmp (double double double)) (double gsl_pow_2 (double)) (double gsl_pow_3 (double)) @@ -877,7 +877,7 @@ (double gsl_pow_8 (double)) (double gsl_pow_9 (double)) (double gsl_pow_int (double int)) - + ;; gsl_cdf (double gsl_cdf_ugaussian_P (double)) (double gsl_cdf_ugaussian_Q (double)) @@ -965,8 +965,8 @@ (double gsl_cdf_pascal_Q (int double int)) (double gsl_cdf_hypergeometric_P (int int int int)) (double gsl_cdf_hypergeometric_Q (int int int int)) - - + + ;; gsl_dht (gsl_dht* gsl_dht_alloc (size_t)) (gsl_dht* gsl_dht_new (size_t double double)) @@ -975,7 +975,7 @@ (double gsl_dht_k_sample (gsl_dht* int)) (void gsl_dht_free (gsl_dht*)) (int gsl_dht_apply (gsl_dht* double* double*)) - + ;; gsl_filter (reader-cond ((>= gsl-version 2.5) (int (GSL_FILTER_END_PADZERO GSL_FILTER_END_PADVALUE GSL_FILTER_END_TRUNCATE @@ -1086,8 +1086,8 @@ (double gsl_stats_Qn0_from_sorted_data (double* size_t size_t double* int*)) (double gsl_stats_Qn_from_sorted_data (double* size_t size_t double* int*)))) - - (gsl_interp_type* (gsl_interp_linear gsl_interp_polynomial gsl_interp_cspline gsl_interp_cspline_periodic + + (gsl_interp_type* (gsl_interp_linear gsl_interp_polynomial gsl_interp_cspline gsl_interp_cspline_periodic gsl_interp_akima gsl_interp_akima_periodic)) (gsl_min_fminimizer_type* (gsl_min_fminimizer_goldensection gsl_min_fminimizer_brent gsl_min_fminimizer_quad_golden)) (gsl_multimin_fminimizer_type* (gsl_multimin_fminimizer_nmsimplex gsl_multimin_fminimizer_nmsimplex2 gsl_multimin_fminimizer_nmsimplex2rand)) @@ -1097,29 +1097,29 @@ (char* (gsl_version)) (gsl_wavelet_type* (gsl_wavelet_daubechies gsl_wavelet_daubechies_centered gsl_wavelet_haar gsl_wavelet_haar_centered gsl_wavelet_bspline gsl_wavelet_bspline_centered)) - + (reader-cond ((>= gsl-version 1.16) (gsl_multifit_robust_type* (gsl_multifit_robust_default gsl_multifit_robust_bisquare gsl_multifit_robust_cauchy gsl_multifit_robust_fair gsl_multifit_robust_huber gsl_multifit_robust_ols gsl_multifit_robust_welsch)))) - + (reader-cond ((>= gsl-version 2.0) (gsl_interp_type* (gsl_interp_steffen)))) - + (int (gsl_message_mask gsl_check_range)) - + ;; randist, rng (gsl_qrng_type* (gsl_qrng_niederreiter_2 gsl_qrng_sobol gsl_qrng_halton gsl_qrng_reversehalton)) - (gsl_rng_type* (gsl_rng_default gsl_rng_borosh13 gsl_rng_coveyou gsl_rng_cmrg gsl_rng_fishman18 gsl_rng_fishman20 gsl_rng_fishman2x gsl_rng_gfsr4 - gsl_rng_knuthran gsl_rng_knuthran2 gsl_rng_knuthran2002 gsl_rng_lecuyer21 gsl_rng_minstd gsl_rng_mrg gsl_rng_mt19937 - gsl_rng_mt19937_1999 gsl_rng_mt19937_1998 gsl_rng_r250 gsl_rng_ran0 gsl_rng_ran1 gsl_rng_ran2 gsl_rng_ran3 gsl_rng_rand - gsl_rng_rand48 gsl_rng_random128_bsd gsl_rng_random128_glibc2 gsl_rng_random128_libc5 gsl_rng_random256_bsd - gsl_rng_random256_glibc2 gsl_rng_random256_libc5 gsl_rng_random32_bsd gsl_rng_random32_glibc2 gsl_rng_random32_libc5 - gsl_rng_random64_bsd gsl_rng_random64_glibc2 gsl_rng_random64_libc5 gsl_rng_random8_bsd gsl_rng_random8_glibc2 - gsl_rng_random8_libc5 gsl_rng_random_bsd gsl_rng_random_glibc2 gsl_rng_random_libc5 gsl_rng_randu - gsl_rng_ranf gsl_rng_ranlux gsl_rng_ranlux389 gsl_rng_ranlxd1 gsl_rng_ranlxd2 gsl_rng_ranlxs0 gsl_rng_ranlxs1 - gsl_rng_ranlxs2 gsl_rng_ranmar gsl_rng_slatec gsl_rng_taus gsl_rng_taus2 gsl_rng_taus113 gsl_rng_transputer + (gsl_rng_type* (gsl_rng_default gsl_rng_borosh13 gsl_rng_coveyou gsl_rng_cmrg gsl_rng_fishman18 gsl_rng_fishman20 gsl_rng_fishman2x gsl_rng_gfsr4 + gsl_rng_knuthran gsl_rng_knuthran2 gsl_rng_knuthran2002 gsl_rng_lecuyer21 gsl_rng_minstd gsl_rng_mrg gsl_rng_mt19937 + gsl_rng_mt19937_1999 gsl_rng_mt19937_1998 gsl_rng_r250 gsl_rng_ran0 gsl_rng_ran1 gsl_rng_ran2 gsl_rng_ran3 gsl_rng_rand + gsl_rng_rand48 gsl_rng_random128_bsd gsl_rng_random128_glibc2 gsl_rng_random128_libc5 gsl_rng_random256_bsd + gsl_rng_random256_glibc2 gsl_rng_random256_libc5 gsl_rng_random32_bsd gsl_rng_random32_glibc2 gsl_rng_random32_libc5 + gsl_rng_random64_bsd gsl_rng_random64_glibc2 gsl_rng_random64_libc5 gsl_rng_random8_bsd gsl_rng_random8_glibc2 + gsl_rng_random8_libc5 gsl_rng_random_bsd gsl_rng_random_glibc2 gsl_rng_random_libc5 gsl_rng_randu + gsl_rng_ranf gsl_rng_ranlux gsl_rng_ranlux389 gsl_rng_ranlxd1 gsl_rng_ranlxd2 gsl_rng_ranlxs0 gsl_rng_ranlxs1 + gsl_rng_ranlxs2 gsl_rng_ranmar gsl_rng_slatec gsl_rng_taus gsl_rng_taus2 gsl_rng_taus113 gsl_rng_transputer gsl_rng_tt800 gsl_rng_uni gsl_rng_uni32 gsl_rng_vax gsl_rng_waterman14 gsl_rng_zuf gsl_rng_default_seed)) - + (gsl_qrng* gsl_qrng_alloc (gsl_qrng_type* int)) (int gsl_qrng_memcpy (gsl_qrng* gsl_qrng*)) (gsl_qrng* gsl_qrng_clone (gsl_qrng*)) @@ -1188,7 +1188,7 @@ (double gsl_ran_lognormal_pdf (double double double)) (int gsl_ran_logarithmic (gsl_rng* double)) (double gsl_ran_logarithmic_pdf (int double)) - ;; int* (void gsl_ran_multinomial (gsl_rng* size_t int double* int*)) ; unsigned int* + ;; int* (void gsl_ran_multinomial (gsl_rng* size_t int double* int*)) ; unsigned int* ;; int* (double gsl_ran_multinomial_pdf (size_t double* int*)) ; unsigned int* ;; int* (double gsl_ran_multinomial_lnpdf (size_t double* int*)) ; unsigned int* (int gsl_ran_negative_binomial (gsl_rng* double double)) @@ -1242,11 +1242,11 @@ (double gsl_rng_uniform (gsl_rng*)) (double gsl_rng_uniform_pos (gsl_rng*)) (int gsl_rng_uniform_int (gsl_rng* int)) - + ;; gsl_complex (in-C "#define S7_TO_GSL_COMPLEX(sg, g) GSL_SET_COMPLEX(&g, s7_real_part(sg), s7_imag_part(sg)) #define GSL_TO_S7_COMPLEX(sc, g) s7_make_complex(sc, GSL_REAL(g), GSL_IMAG(g)) - + static s7_pointer s7_gsl_c_c(s7_scheme *sc, s7_pointer arg1, gsl_complex (*callee)(gsl_complex a)) { gsl_complex g, g1; @@ -1344,7 +1344,7 @@ (C-function ("gsl_complex_abs" g_gsl_complex_abs "" 1)) (C-function ("gsl_complex_abs2" g_gsl_complex_abs2 "" 1)) (C-function ("gsl_complex_logabs" g_gsl_complex_logabs "" 1)) - + (C-function ("gsl_complex_conjugate" g_gsl_complex_conjugate "" 1)) (C-function ("gsl_complex_inverse" g_gsl_complex_inverse "" 1)) (C-function ("gsl_complex_negative" g_gsl_complex_negative "" 1)) @@ -1376,7 +1376,7 @@ (C-function ("gsl_complex_arccsc" g_gsl_complex_arccsc "" 1)) (C-function ("gsl_complex_arccosh" g_gsl_complex_arccosh "" 1)) (C-function ("gsl_complex_arctanh" g_gsl_complex_arctanh "" 1)) - + (C-function ("gsl_complex_sqrt_real" g_gsl_complex_sqrt_real "" 1)) (C-function ("gsl_complex_arcsin_real" g_gsl_complex_arcsin_real "" 1)) (C-function ("gsl_complex_arccos_real" g_gsl_complex_arccos_real "" 1)) @@ -1384,14 +1384,14 @@ (C-function ("gsl_complex_arccsc_real" g_gsl_complex_arccsc_real "" 1)) (C-function ("gsl_complex_arccosh_real" g_gsl_complex_arccosh_real "" 1)) (C-function ("gsl_complex_arctanh_real" g_gsl_complex_arctanh_real "" 1)) - + (C-function ("gsl_complex_add" g_gsl_complex_add "" 2)) (C-function ("gsl_complex_sub" g_gsl_complex_sub "" 2)) (C-function ("gsl_complex_mul" g_gsl_complex_mul "" 2)) (C-function ("gsl_complex_div" g_gsl_complex_div "" 2)) (C-function ("gsl_complex_log_b" g_gsl_complex_log_b "" 2)) (C-function ("gsl_complex_pow" g_gsl_complex_pow "" 2)) - + (C-function ("gsl_complex_add_real" g_gsl_complex_add_real "" 2)) (C-function ("gsl_complex_sub_real" g_gsl_complex_sub_real "" 2)) (C-function ("gsl_complex_mul_real" g_gsl_complex_mul_real "" 2)) @@ -1401,8 +1401,8 @@ (C-function ("gsl_complex_mul_imag" g_gsl_complex_mul_imag "" 2)) (C-function ("gsl_complex_div_imag" g_gsl_complex_div_imag "" 2)) (C-function ("gsl_complex_pow_real" g_gsl_complex_pow_real "" 2)) - - + + ;; cheb (gsl_cheb_series* gsl_cheb_alloc (size_t)) (void gsl_cheb_free (gsl_cheb_series*)) @@ -1417,12 +1417,12 @@ (int gsl_cheb_eval_mode_e (gsl_cheb_series* double int double* double*)) (int gsl_cheb_calc_deriv (gsl_cheb_series* gsl_cheb_series*)) (int gsl_cheb_calc_integ (gsl_cheb_series* gsl_cheb_series*)) - + ;; gsl_function is a struct with double function(double void*) and void* params (in-C " static s7_scheme *gsl_f_s7; static gsl_function gsl_f; - static double gsl_f_caller(double x, void *p) + static double gsl_f_caller(double x, void *p) { return(s7_real(s7_call(gsl_f_s7, (s7_pointer)p, s7_cons(gsl_f_s7, s7_make_real(gsl_f_s7, x), s7_nil(gsl_f_s7))))); } @@ -1435,7 +1435,7 @@ } ") (C-function ("gsl_cheb_init" g_gsl_cheb_init "" 4)) - + ;; interp (gsl_interp_accel* gsl_interp_accel_alloc (void)) (int gsl_interp_accel_reset (gsl_interp_accel*)) @@ -1456,7 +1456,7 @@ (void gsl_interp_free (gsl_interp*)) (size_t gsl_interp_bsearch (double* double size_t size_t)) (size_t gsl_interp_accel_find (gsl_interp_accel* double* size_t double)) - + ;; spline (based on interp above) (gsl_spline* gsl_spline_alloc (gsl_interp_type* size_t)) (int gsl_spline_init (gsl_spline* double* double* size_t)) @@ -1471,7 +1471,7 @@ (int gsl_spline_eval_integ_e (gsl_spline* double double gsl_interp_accel* double*)) (double gsl_spline_eval_integ (gsl_spline* double double gsl_interp_accel*)) (void gsl_spline_free (gsl_spline*)) - + ;; bspline (gsl_bspline_workspace* gsl_bspline_alloc (size_t size_t)) (void gsl_bspline_free (gsl_bspline_workspace*)) @@ -1479,7 +1479,7 @@ (size_t gsl_bspline_order (gsl_bspline_workspace*)) (size_t gsl_bspline_nbreak (gsl_bspline_workspace*)) (double gsl_bspline_breakpoint (size_t gsl_bspline_workspace*)) - (reader-cond ((>= gsl-version 1.16) + (reader-cond ((>= gsl-version 1.16) (double gsl_bspline_greville_abscissa (size_t gsl_bspline_workspace*)) (int gsl_bspline_knots_greville (gsl_vector* gsl_bspline_workspace* double*)))) (int gsl_bspline_knots (gsl_vector* gsl_bspline_workspace*)) @@ -1491,12 +1491,12 @@ (reader-cond ((>= gsl-version 2.0) (int gsl_bspline_deriv_eval (double size_t gsl_matrix* gsl_bspline_workspace*)) (int gsl_bspline_deriv_eval_nonzero (double size_t gsl_matrix* size_t* size_t* gsl_bspline_workspace*)))) - + ;; sort ;; perhaps size_t* -> int vector? - + (void gsl_sort (double* size_t size_t)) - (reader-cond ((>= gsl-version 1.16) + (reader-cond ((>= gsl-version 1.16) (void gsl_sort2 (double* size_t double* size_t size_t)) (void gsl_sort_vector2 (gsl_vector* gsl_vector*)) (int gsl_poly_dd_hermite_init (double* double* double* double* double* size_t)))) @@ -1511,7 +1511,7 @@ (int gsl_sort_vector_largest (double* size_t gsl_vector*)) (int gsl_sort_vector_smallest_index (size_t* size_t gsl_vector*)) (int gsl_sort_vector_largest_index (size_t* size_t gsl_vector*)) - + ;; poly (double gsl_poly_eval (double* int double)) (int gsl_poly_eval_derivs (double* size_t double double* size_t)) @@ -1520,7 +1520,7 @@ (int gsl_poly_dd_taylor (double* double double* double* size_t double*)) (void gsl_poly_complex_workspace_free (gsl_poly_complex_workspace*)) (gsl_poly_complex_workspace* gsl_poly_complex_workspace_alloc (size_t)) - + (in-C " static s7_pointer g_gsl_poly_complex_eval(s7_scheme *sc, s7_pointer args) { @@ -1550,14 +1550,14 @@ gsl_complex z0, z1; int result; s7_pointer res; - + res = s7_cadddr(args); - result = gsl_poly_complex_solve_quadratic(s7_number_to_real_with_caller(sc, s7_car(args), __func__), - s7_number_to_real_with_caller(sc, s7_cadr(args), __func__), + result = gsl_poly_complex_solve_quadratic(s7_number_to_real_with_caller(sc, s7_car(args), __func__), + s7_number_to_real_with_caller(sc, s7_cadr(args), __func__), s7_number_to_real_with_caller(sc, s7_caddr(args), __func__), &z0, &z1); s7_vector_set(sc, res, 0, GSL_TO_S7_COMPLEX(sc, z0)); s7_vector_set(sc, res, 1, GSL_TO_S7_COMPLEX(sc, z1)); - + return(s7_make_integer(sc, result)); } static s7_pointer g_gsl_poly_complex_solve_cubic(s7_scheme *sc, s7_pointer args) @@ -1566,18 +1566,18 @@ gsl_complex z0, z1, z2; int result; s7_pointer res; - - result = gsl_poly_complex_solve_cubic(s7_number_to_real_with_caller(sc, s7_car(args), __func__), - s7_number_to_real_with_caller(sc, s7_cadr(args), __func__), + + result = gsl_poly_complex_solve_cubic(s7_number_to_real_with_caller(sc, s7_car(args), __func__), + s7_number_to_real_with_caller(sc, s7_cadr(args), __func__), s7_number_to_real_with_caller(sc, s7_caddr(args), __func__), &z0, &z1, &z2); res = s7_cadddr(args); s7_vector_set(sc, res, 0, GSL_TO_S7_COMPLEX(sc, z0)); s7_vector_set(sc, res, 1, GSL_TO_S7_COMPLEX(sc, z1)); s7_vector_set(sc, res, 2, GSL_TO_S7_COMPLEX(sc, z2)); - + return(s7_make_integer(sc, result)); } - + static s7_pointer g_gsl_poly_complex_solve(s7_scheme *sc, s7_pointer args) { /* trailing args are by ref, but I think I'll mimic the real solver above */ @@ -1585,44 +1585,44 @@ gsl_poly_complex_workspace *w; int result, i, size; s7_pointer res; - + size = s7_integer(s7_cadr(args)); res = s7_caddr(args); - + z = (double *)calloc(size * 2, sizeof(double)); w = gsl_poly_complex_workspace_alloc(size); result = gsl_poly_complex_solve((double *)s7_c_pointer_with_type(sc, s7_car(args), double__symbol, __func__, 1), size, w, (gsl_complex_packed_ptr)z); gsl_poly_complex_workspace_free(w); - + for (i = 0; i < size - 1; i++) s7_vector_set(sc, res, i, s7_make_complex(sc, z[2 * i], z[2 * i + 1])); free(z); - + return(s7_make_integer(sc, result)); } - + static s7_pointer g_gsl_poly_solve_quadratic(s7_scheme *sc, s7_pointer args) { double x0, x1; int result; double *res; res = (double *)s7_c_pointer_with_type(sc, s7_cadddr(args), double__symbol, __func__, 4); - result = gsl_poly_solve_quadratic(s7_number_to_real_with_caller(sc, s7_car(args), __func__), - s7_number_to_real_with_caller(sc, s7_cadr(args), __func__), + result = gsl_poly_solve_quadratic(s7_number_to_real_with_caller(sc, s7_car(args), __func__), + s7_number_to_real_with_caller(sc, s7_cadr(args), __func__), s7_number_to_real_with_caller(sc, s7_caddr(args), __func__), &x0, &x1); res[0] = x0; res[1] = x1; return(s7_make_integer(sc, result)); } - + static s7_pointer g_gsl_poly_solve_cubic(s7_scheme *sc, s7_pointer args) { double x0, x1, x2; int result; double *res; res = (double *)s7_c_pointer_with_type(sc, s7_cadddr(args), double__symbol, __func__, 4); - result = gsl_poly_solve_cubic(s7_number_to_real_with_caller(sc, s7_car(args), __func__), - s7_number_to_real_with_caller(sc, s7_cadr(args), __func__), + result = gsl_poly_solve_cubic(s7_number_to_real_with_caller(sc, s7_car(args), __func__), + s7_number_to_real_with_caller(sc, s7_cadr(args), __func__), s7_number_to_real_with_caller(sc, s7_caddr(args), __func__), &x0, &x1, &x2); res[0] = x0; res[1] = x1; @@ -1630,7 +1630,7 @@ return(s7_make_integer(sc, result)); } ") - + (C-function ("gsl_poly_complex_eval" g_gsl_poly_complex_eval "" 3)) (C-function ("gsl_complex_poly_complex_eval" g_gsl_complex_poly_complex_eval "" 3)) (C-function ("gsl_poly_complex_solve_quadratic" g_gsl_poly_complex_solve_quadratic "" 4)) @@ -1638,7 +1638,7 @@ (C-function ("gsl_poly_complex_solve" g_gsl_poly_complex_solve "" 3)) (C-function ("gsl_poly_solve_quadratic" g_gsl_poly_solve_quadratic "" 4)) (C-function ("gsl_poly_solve_cubic" g_gsl_poly_solve_cubic "" 4)) - + ;; vector (in-C " static s7_pointer g_float_vector_to_gsl_vector(s7_scheme *sc, s7_pointer args) @@ -1666,7 +1666,7 @@ ") (C-function ("float-vector->gsl_vector" g_float_vector_to_gsl_vector "" 2)) (C-function ("gsl_vector->float-vector" g_gsl_vector_to_float_vector "" 2)) - + (gsl_vector* gsl_vector_alloc (size_t)) (gsl_vector* gsl_vector_calloc (size_t)) (gsl_vector* gsl_vector_alloc_from_vector (gsl_vector* size_t size_t size_t)) @@ -1702,8 +1702,8 @@ (double* gsl_vector_ptr (gsl_vector* size_t)) (double* gsl_vector_const_ptr (gsl_vector* size_t)) (void gsl_vector_minmax (gsl_vector* double* double*)) ; by ref - (void gsl_vector_minmax_index (gsl_vector* size_t* size_t*)) ; by ref - + (void gsl_vector_minmax_index (gsl_vector* size_t* size_t*)) ; by ref + ;; matrix (in-C " static s7_pointer g_float_vector_to_gsl_matrix(s7_scheme *sc, s7_pointer args) @@ -1731,7 +1731,7 @@ ") (C-function ("float-vector->gsl_matrix" g_float_vector_to_gsl_matrix "" 2)) (C-function ("gsl_matrix->float-vector" g_gsl_matrix_to_float_vector "" 2)) - + (gsl_matrix* gsl_matrix_alloc (size_t size_t)) (gsl_matrix* gsl_matrix_calloc (size_t size_t)) (gsl_matrix* gsl_matrix_alloc_from_matrix (gsl_matrix* size_t size_t size_t size_t)) @@ -1785,7 +1785,7 @@ return(s7_cons(sc, s7_make_integer(sc, (s7_int)(g->size1)), s7_make_integer(sc, (s7_int)(g->size2)))); }") (C-function ("gsl_matrix_size" g_gsl_matrix_size "" 1)) - + ;; cblas (int gsl_blas_zdotu (gsl_vector_complex* gsl_vector_complex* gsl_complex*)) (int gsl_blas_zdotc (gsl_vector_complex* gsl_vector_complex* gsl_complex*)) @@ -1894,7 +1894,7 @@ (void cblas_zhemm ((CBLAS_ORDER_t int) (CBLAS_SIDE_t int) (CBLAS_UPLO_t int) int int double* double* int double* int double* double* int)) (void cblas_zherk ((CBLAS_ORDER_t int) (CBLAS_UPLO_t int) (CBLAS_TRANSPOSE_t int) int int double double* int double double* int)) (void cblas_zher2k ((CBLAS_ORDER_t int) (CBLAS_UPLO_t int) (CBLAS_TRANSPOSE_t int) int int double* double* int double* int double double* int)) - + ;; combination (gsl_combination* gsl_combination_alloc (size_t size_t)) (gsl_combination* gsl_combination_calloc (size_t size_t)) @@ -1929,7 +1929,7 @@ } ") (C-function ("gsl_combination->int-vector" g_gsl_combination_to_int_vector "" 2)) - + ;; rl+im for complex in most of these cases (int gsl_dft_complex_forward (double* size_t size_t double*)) (int gsl_dft_complex_backward (double* size_t size_t double*)) @@ -1959,8 +1959,8 @@ (void gsl_fft_real_workspace_free (gsl_fft_real_workspace*)) (int gsl_fft_real_transform (double* size_t size_t gsl_fft_real_wavetable* gsl_fft_real_workspace*)) (int gsl_fft_real_unpack (double* double* size_t size_t)) - - + + (gsl_eigen_symm_workspace* gsl_eigen_symm_alloc (size_t)) (void gsl_eigen_symm_free (gsl_eigen_symm_workspace*)) (int gsl_eigen_symm (gsl_matrix* gsl_vector* gsl_eigen_symm_workspace*)) @@ -2029,7 +2029,7 @@ (gsl_matrix*)s7_c_pointer_with_type(sc, s7_caddr(args), gsl_matrix__symbol, __func__, 3), (int)s7_integer(s7_cadddr(args)), &ref_arg))); }") (C-function ("gsl_eigen_jacobi" g_gsl_eigen_jacobi "" 4)) - + (void gsl_error (char* char* int int)) (void gsl_stream_printf (char* char* int char*)) (char* gsl_strerror (int)) @@ -2037,14 +2037,14 @@ (gsl_error_handler_t* gsl_set_error_handler_off (void)) (gsl_stream_handler_t* gsl_set_stream_handler (gsl_stream_handler_t*)) (FILE* gsl_set_stream (FILE*)) - + (int gsl_fit_linear (double* size_t double* size_t size_t double* double* double* double* double* double*)) (int gsl_fit_wlinear (double* size_t double* size_t double* size_t size_t double* double* double* double* double* double*)) (int gsl_fit_linear_est (double double double double double double double* double*)) (int gsl_fit_mul (double* size_t double* size_t size_t double* double* double*)) (int gsl_fit_wmul (double* size_t double* size_t double* size_t size_t double* double* double*)) (int gsl_fit_mul_est (double double double double* double*)) - + (gsl_histogram* gsl_histogram_alloc (size_t)) (gsl_histogram* gsl_histogram_calloc (size_t)) (gsl_histogram* gsl_histogram_calloc_uniform (size_t double double)) @@ -2131,14 +2131,14 @@ (int gsl_histogram2d_pdf_init (gsl_histogram2d_pdf* gsl_histogram2d*)) (void gsl_histogram2d_pdf_free (gsl_histogram2d_pdf*)) (int gsl_histogram2d_pdf_sample (gsl_histogram2d_pdf* double double double* double*)) - + ;(void gsl_ieee_printf_double (double*) ) ; these are ridiculous ;(void gsl_ieee_fprintf_double (FILE* double*) ) ;(void gsl_ieee_double_to_rep (double* gsl_ieee_double_rep*) ) (void gsl_ieee_env_setup (void) ) ; looks for GSL_IEEE_MODE home var ;(int gsl_ieee_read_mode_string (char* int* int* int*) ) ; int by ref (int gsl_ieee_set_mode (int int int) ) - + (in-C " static s7_pointer g_gsl_deriv_central(s7_scheme *sc, s7_pointer args) { @@ -2168,8 +2168,8 @@ (C-function ("gsl_deriv_central" g_gsl_deriv_central "" 5)) (C-function ("gsl_deriv_backward" g_gsl_deriv_backward "" 5)) (C-function ("gsl_deriv_forward" g_gsl_deriv_forward "" 5)) - - + + (gsl_integration_workspace* gsl_integration_workspace_alloc (size_t)) (void gsl_integration_workspace_free (gsl_integration_workspace*)) (gsl_integration_qaws_table* gsl_integration_qaws_table_alloc (double double int int)) @@ -2182,7 +2182,7 @@ (reader-cond ((>= gsl-version 2.5) (gsl_integration_romberg_workspace* gsl_integration_romberg_alloc (size_t)) (void gsl_integration_romberg_free (gsl_integration_romberg_workspace*)))) - + (in-C "#define Integration(Name) \ static s7_pointer g_gsl_integration_ ## Name (s7_scheme *sc, s7_pointer args) \ { \ @@ -2214,8 +2214,8 @@ static s7_pointer g_gsl_integration_romberg(s7_scheme *sc, s7_pointer args) { gsl_function gsl_f; make_gsl_function(s7_car(args)); - gsl_integration_romberg(&gsl_f, - s7_real(s7_cadr(args)), s7_real(s7_caddr(args)), + gsl_integration_romberg(&gsl_f, + s7_real(s7_cadr(args)), s7_real(s7_caddr(args)), s7_real(s7_cadddr(args)), s7_real(s7_list_ref(sc, args, 4)), (double *)s7_c_pointer_with_type(sc, s7_list_ref(sc, args, 5), double__symbol, __func__, 6), (size_t *)s7_c_pointer_with_type(sc, s7_list_ref(sc, args, 6), double__symbol, __func__, 7), @@ -2238,7 +2238,7 @@ { size_t ref; gsl_function gsl_f; make_gsl_function(s7_car(args)); - return(s7_make_integer(sc, gsl_integration_qng(&gsl_f, + return(s7_make_integer(sc, gsl_integration_qng(&gsl_f, s7_real(s7_list_ref(sc, args, 1)), s7_real(s7_list_ref(sc, args, 2)), s7_real(s7_list_ref(sc, args, 3)), s7_real(s7_list_ref(sc, args, 4)), (double *)s7_c_pointer_with_type(sc, s7_list_ref(sc, args, 5), double__symbol, __func__, 6), @@ -2248,136 +2248,136 @@ static s7_pointer g_gsl_integration_qag(s7_scheme *sc, s7_pointer args) { gsl_function gsl_f; make_gsl_function(s7_car(args)); - return(s7_make_integer(sc, gsl_integration_qag(&gsl_f, + return(s7_make_integer(sc, gsl_integration_qag(&gsl_f, s7_real(s7_list_ref(sc, args, 1)), s7_real(s7_list_ref(sc, args, 2)), s7_real(s7_list_ref(sc, args, 3)), s7_real(s7_list_ref(sc, args, 4)), - (size_t)s7_integer(s7_list_ref(sc, args, 5)), (int)s7_integer(s7_list_ref(sc, args, 6)), + (size_t)s7_integer(s7_list_ref(sc, args, 5)), (int)s7_integer(s7_list_ref(sc, args, 6)), (gsl_integration_workspace *)s7_c_pointer_with_type(sc, s7_list_ref(sc, args, 7), gsl_integration_workspace__symbol, __func__, 7), - (double *)s7_c_pointer_with_type(sc, s7_list_ref(sc, args, 8), double__symbol, __func__, 9), + (double *)s7_c_pointer_with_type(sc, s7_list_ref(sc, args, 8), double__symbol, __func__, 9), (double *)s7_c_pointer_with_type(sc, s7_list_ref(sc, args, 9), double__symbol, __func__, 10)))); } static s7_pointer g_gsl_integration_qagi(s7_scheme *sc, s7_pointer args) { gsl_function gsl_f; make_gsl_function(s7_car(args)); - return(s7_make_integer(sc, gsl_integration_qagi(&gsl_f, + return(s7_make_integer(sc, gsl_integration_qagi(&gsl_f, s7_real(s7_list_ref(sc, args, 1)), s7_real(s7_list_ref(sc, args, 2)), (size_t)s7_integer(s7_list_ref(sc, args, 3)), (gsl_integration_workspace *)s7_c_pointer_with_type(sc, s7_list_ref(sc, args, 4), gsl_integration_workspace__symbol, __func__, 4), - (double *)s7_c_pointer_with_type(sc, s7_list_ref(sc, args, 5), double__symbol, __func__, 6), + (double *)s7_c_pointer_with_type(sc, s7_list_ref(sc, args, 5), double__symbol, __func__, 6), (double *)s7_c_pointer_with_type(sc, s7_list_ref(sc, args, 6), double__symbol, __func__, 7)))); } static s7_pointer g_gsl_integration_qagiu(s7_scheme *sc, s7_pointer args) { gsl_function gsl_f; make_gsl_function(s7_car(args)); - return(s7_make_integer(sc, gsl_integration_qagiu(&gsl_f, + return(s7_make_integer(sc, gsl_integration_qagiu(&gsl_f, s7_real(s7_list_ref(sc, args, 1)), s7_real(s7_list_ref(sc, args, 2)), s7_real(s7_list_ref(sc, args, 3)), (size_t)s7_integer(s7_list_ref(sc, args, 4)), (gsl_integration_workspace *)s7_c_pointer_with_type(sc, s7_list_ref(sc, args, 5), gsl_integration_workspace__symbol, __func__, 5), - (double *)s7_c_pointer_with_type(sc, s7_list_ref(sc, args, 6), double__symbol, __func__, 7), + (double *)s7_c_pointer_with_type(sc, s7_list_ref(sc, args, 6), double__symbol, __func__, 7), (double *)s7_c_pointer_with_type(sc, s7_list_ref(sc, args, 7), double__symbol, __func__, 8)))); } static s7_pointer g_gsl_integration_qagil(s7_scheme *sc, s7_pointer args) { gsl_function gsl_f; make_gsl_function(s7_car(args)); - return(s7_make_integer(sc, gsl_integration_qagil(&gsl_f, + return(s7_make_integer(sc, gsl_integration_qagil(&gsl_f, s7_real(s7_list_ref(sc, args, 1)), s7_real(s7_list_ref(sc, args, 2)), s7_real(s7_list_ref(sc, args, 3)), (size_t)s7_integer(s7_list_ref(sc, args, 4)), (gsl_integration_workspace *)s7_c_pointer_with_type(sc, s7_list_ref(sc, args, 5), gsl_integration_workspace__symbol, __func__, 5), - (double *)s7_c_pointer_with_type(sc, s7_list_ref(sc, args, 6), double__symbol, __func__, 7), + (double *)s7_c_pointer_with_type(sc, s7_list_ref(sc, args, 6), double__symbol, __func__, 7), (double *)s7_c_pointer_with_type(sc, s7_list_ref(sc, args, 7), double__symbol, __func__, 8)))); - } + } static s7_pointer g_gsl_integration_qags(s7_scheme *sc, s7_pointer args) { gsl_function gsl_f; make_gsl_function(s7_car(args)); - return(s7_make_integer(sc, gsl_integration_qags(&gsl_f, - s7_real(s7_list_ref(sc, args, 1)), s7_real(s7_list_ref(sc, args, 2)), + return(s7_make_integer(sc, gsl_integration_qags(&gsl_f, + s7_real(s7_list_ref(sc, args, 1)), s7_real(s7_list_ref(sc, args, 2)), s7_real(s7_list_ref(sc, args, 3)), s7_real(s7_list_ref(sc, args, 4)), (size_t)s7_integer(s7_list_ref(sc, args, 5)), (gsl_integration_workspace *)s7_c_pointer_with_type(sc, s7_list_ref(sc, args, 6), gsl_integration_workspace__symbol, __func__, 6), - (double *)s7_c_pointer_with_type(sc, s7_list_ref(sc, args, 7), double__symbol, __func__, 8), + (double *)s7_c_pointer_with_type(sc, s7_list_ref(sc, args, 7), double__symbol, __func__, 8), (double *)s7_c_pointer_with_type(sc, s7_list_ref(sc, args, 8), double__symbol, __func__, 9)))); } static s7_pointer g_gsl_integration_qagp(s7_scheme *sc, s7_pointer args) { gsl_function gsl_f; make_gsl_function(s7_car(args)); - return(s7_make_integer(sc, gsl_integration_qagp(&gsl_f, + return(s7_make_integer(sc, gsl_integration_qagp(&gsl_f, (double *)s7_c_pointer_with_type(sc, s7_list_ref(sc, args, 1), double__symbol, __func__, 2), (size_t)s7_integer(s7_list_ref(sc, args, 2)), - s7_real(s7_list_ref(sc, args, 3)), s7_real(s7_list_ref(sc, args, 4)), + s7_real(s7_list_ref(sc, args, 3)), s7_real(s7_list_ref(sc, args, 4)), (size_t)s7_integer(s7_list_ref(sc, args, 5)), (gsl_integration_workspace *)s7_c_pointer_with_type(sc, s7_list_ref(sc, args, 6), gsl_integration_workspace__symbol, __func__, 6), - (double *)s7_c_pointer_with_type(sc, s7_list_ref(sc, args, 7), double__symbol, __func__, 8), + (double *)s7_c_pointer_with_type(sc, s7_list_ref(sc, args, 7), double__symbol, __func__, 8), (double *)s7_c_pointer_with_type(sc, s7_list_ref(sc, args, 8), double__symbol, __func__, 9)))); } static s7_pointer g_gsl_integration_qawc(s7_scheme *sc, s7_pointer args) { gsl_function gsl_f; make_gsl_function(s7_car(args)); - return(s7_make_integer(sc, gsl_integration_qawc(&gsl_f, - s7_real(s7_list_ref(sc, args, 1)), s7_real(s7_list_ref(sc, args, 2)), - s7_real(s7_list_ref(sc, args, 3)), s7_real(s7_list_ref(sc, args, 4)), - s7_real(s7_list_ref(sc, args, 5)), + return(s7_make_integer(sc, gsl_integration_qawc(&gsl_f, + s7_real(s7_list_ref(sc, args, 1)), s7_real(s7_list_ref(sc, args, 2)), + s7_real(s7_list_ref(sc, args, 3)), s7_real(s7_list_ref(sc, args, 4)), + s7_real(s7_list_ref(sc, args, 5)), (size_t)s7_integer(s7_list_ref(sc, args, 6)), (gsl_integration_workspace *)s7_c_pointer_with_type(sc, s7_list_ref(sc, args, 7), gsl_integration_workspace__symbol, __func__, 7), - (double *)s7_c_pointer_with_type(sc, s7_list_ref(sc, args, 8), double__symbol, __func__, 9), + (double *)s7_c_pointer_with_type(sc, s7_list_ref(sc, args, 8), double__symbol, __func__, 9), (double *)s7_c_pointer_with_type(sc, s7_list_ref(sc, args, 9), double__symbol, __func__, 10)))); } static s7_pointer g_gsl_integration_qaws(s7_scheme *sc, s7_pointer args) { gsl_function gsl_f; make_gsl_function(s7_car(args)); - return(s7_make_integer(sc, gsl_integration_qaws(&gsl_f, - s7_real(s7_list_ref(sc, args, 1)), s7_real(s7_list_ref(sc, args, 2)), + return(s7_make_integer(sc, gsl_integration_qaws(&gsl_f, + s7_real(s7_list_ref(sc, args, 1)), s7_real(s7_list_ref(sc, args, 2)), (gsl_integration_qaws_table *)s7_c_pointer_with_type(sc, s7_list_ref(sc, args, 3), gsl_integration_qaws_table__symbol, __func__, 3), - s7_real(s7_list_ref(sc, args, 4)), s7_real(s7_list_ref(sc, args, 5)), + s7_real(s7_list_ref(sc, args, 4)), s7_real(s7_list_ref(sc, args, 5)), (size_t)s7_integer(s7_list_ref(sc, args, 6)), (gsl_integration_workspace *)s7_c_pointer_with_type(sc, s7_list_ref(sc, args, 7), gsl_integration_workspace__symbol, __func__, 7), - (double *)s7_c_pointer_with_type(sc, s7_list_ref(sc, args, 8), double__symbol, __func__, 9), + (double *)s7_c_pointer_with_type(sc, s7_list_ref(sc, args, 8), double__symbol, __func__, 9), (double *)s7_c_pointer_with_type(sc, s7_list_ref(sc, args, 9), double__symbol, __func__, 10)))); } static s7_pointer g_gsl_integration_qawo(s7_scheme *sc, s7_pointer args) { gsl_function gsl_f; make_gsl_function(s7_car(args)); - return(s7_make_integer(sc, gsl_integration_qawo(&gsl_f, - s7_real(s7_list_ref(sc, args, 1)), s7_real(s7_list_ref(sc, args, 2)), - s7_real(s7_list_ref(sc, args, 3)), + return(s7_make_integer(sc, gsl_integration_qawo(&gsl_f, + s7_real(s7_list_ref(sc, args, 1)), s7_real(s7_list_ref(sc, args, 2)), + s7_real(s7_list_ref(sc, args, 3)), (size_t)s7_integer(s7_list_ref(sc, args, 4)), (gsl_integration_workspace *)s7_c_pointer_with_type(sc, s7_list_ref(sc, args, 5), gsl_integration_workspace__symbol, __func__, 5), (gsl_integration_qawo_table *)s7_c_pointer_with_type(sc, s7_list_ref(sc, args, 6), gsl_integration_qawo_table__symbol, __func__, 6), - (double *)s7_c_pointer_with_type(sc, s7_list_ref(sc, args, 7), double__symbol, __func__, 8), + (double *)s7_c_pointer_with_type(sc, s7_list_ref(sc, args, 7), double__symbol, __func__, 8), (double *)s7_c_pointer_with_type(sc, s7_list_ref(sc, args, 8), double__symbol, __func__, 9)))); } static s7_pointer g_gsl_integration_qawf(s7_scheme *sc, s7_pointer args) { gsl_function gsl_f; make_gsl_function(s7_car(args)); - return(s7_make_integer(sc, gsl_integration_qawf(&gsl_f, - s7_real(s7_list_ref(sc, args, 1)), s7_real(s7_list_ref(sc, args, 2)), + return(s7_make_integer(sc, gsl_integration_qawf(&gsl_f, + s7_real(s7_list_ref(sc, args, 1)), s7_real(s7_list_ref(sc, args, 2)), (size_t)s7_integer(s7_list_ref(sc, args, 3)), (gsl_integration_workspace *)s7_c_pointer_with_type(sc, s7_list_ref(sc, args, 4), gsl_integration_workspace__symbol, __func__, 4), (gsl_integration_workspace *)s7_c_pointer_with_type(sc, s7_list_ref(sc, args, 5), gsl_integration_workspace__symbol, __func__, 5), (gsl_integration_qawo_table *)s7_c_pointer_with_type(sc, s7_list_ref(sc, args, 6), gsl_integration_qawo_table__symbol, __func__, 6), - (double *)s7_c_pointer_with_type(sc, s7_list_ref(sc, args, 7), double__symbol, __func__, 8), + (double *)s7_c_pointer_with_type(sc, s7_list_ref(sc, args, 7), double__symbol, __func__, 8), (double *)s7_c_pointer_with_type(sc, s7_list_ref(sc, args, 8), double__symbol, __func__, 9)))); } static s7_pointer g_gsl_integration_glfixed(s7_scheme *sc, s7_pointer args) { gsl_function gsl_f; make_gsl_function(s7_car(args)); - return(s7_make_real(sc, gsl_integration_glfixed(&gsl_f, - s7_real(s7_list_ref(sc, args, 1)), s7_real(s7_list_ref(sc, args, 2)), + return(s7_make_real(sc, gsl_integration_glfixed(&gsl_f, + s7_real(s7_list_ref(sc, args, 1)), s7_real(s7_list_ref(sc, args, 2)), (const gsl_integration_glfixed_table *)s7_c_pointer_with_type(sc, s7_list_ref(sc, args, 3), gsl_integration_glfixed_table__symbol, __func__, 3)))); } static s7_pointer g_gsl_integration_qk(s7_scheme *sc, s7_pointer args) { gsl_function gsl_f; make_gsl_function(s7_list_ref(sc, args, 6)); gsl_integration_qk((int)s7_integer(s7_car(args)), - (double *)s7_c_pointer_with_type(sc, s7_list_ref(sc, args, 1), double__symbol, __func__, 2), + (double *)s7_c_pointer_with_type(sc, s7_list_ref(sc, args, 1), double__symbol, __func__, 2), (double *)s7_c_pointer_with_type(sc, s7_list_ref(sc, args, 2), double__symbol, __func__, 3), - (double *)s7_c_pointer_with_type(sc, s7_list_ref(sc, args, 3), double__symbol, __func__, 4), + (double *)s7_c_pointer_with_type(sc, s7_list_ref(sc, args, 3), double__symbol, __func__, 4), (double *)s7_c_pointer_with_type(sc, s7_list_ref(sc, args, 4), double__symbol, __func__, 5), (double *)s7_c_pointer_with_type(sc, s7_list_ref(sc, args, 5), double__symbol, __func__, 6), - &gsl_f, - s7_real(s7_list_ref(sc, args, 7)), s7_real(s7_list_ref(sc, args, 8)), - (double *)s7_c_pointer_with_type(sc, s7_list_ref(sc, args, 9), double__symbol, __func__, 10), + &gsl_f, + s7_real(s7_list_ref(sc, args, 7)), s7_real(s7_list_ref(sc, args, 8)), + (double *)s7_c_pointer_with_type(sc, s7_list_ref(sc, args, 9), double__symbol, __func__, 10), (double *)s7_c_pointer_with_type(sc, s7_list_ref(sc, args, 10), double__symbol, __func__, 11), - (double *)s7_c_pointer_with_type(sc, s7_list_ref(sc, args, 11), double__symbol, __func__, 12), + (double *)s7_c_pointer_with_type(sc, s7_list_ref(sc, args, 11), double__symbol, __func__, 12), (double *)s7_c_pointer_with_type(sc, s7_list_ref(sc, args, 12), double__symbol, __func__, 13)); return(s7_car(args)); }") @@ -2395,21 +2395,21 @@ (C-function ("gsl_integration_qawf" g_gsl_integration_qawf "" 9)) (C-function ("gsl_integration_qk" g_gsl_integration_qk "" 13)) (C-function ("gsl_integration_glfixed" g_gsl_integration_glfixed "" 4)) - + (gsl_integration_glfixed_table* gsl_integration_glfixed_table_alloc (size_t)) (void gsl_integration_glfixed_table_free (gsl_integration_glfixed_table*)) - (reader-cond ((>= gsl-version 1.15) + (reader-cond ((>= gsl-version 1.15) (int gsl_integration_glfixed_point (double double size_t double* double* gsl_integration_glfixed_table*)) (gsl_integration_cquad_workspace* gsl_integration_cquad_workspace_alloc (size_t)) (void gsl_integration_cquad_workspace_free (gsl_integration_cquad_workspace*)))) - + (int gsl_linalg_matmult (gsl_matrix* gsl_matrix* gsl_matrix*)) (int gsl_linalg_matmult_mod (gsl_matrix* (gsl_linalg_matrix_mod_t int) gsl_matrix* (gsl_linalg_matrix_mod_t int) gsl_matrix*)) (int gsl_linalg_exponential_ss (gsl_matrix* gsl_matrix* int)) (double gsl_linalg_householder_transform (gsl_vector*)) (int gsl_linalg_householder_hv (double gsl_vector* gsl_vector*)) (int gsl_linalg_householder_hm1 (double gsl_matrix*)) - + (in-C " static s7_pointer g_gsl_linalg_complex_householder_transform(s7_scheme *sc, s7_pointer args) { @@ -2443,7 +2443,7 @@ (C-function ("gsl_linalg_complex_householder_hv" g_gsl_linalg_complex_householder_hv "" 3)) (C-function ("gsl_linalg_complex_LU_det" g_gsl_linalg_complex_LU_det "" 2)) (C-function ("gsl_linalg_complex_LU_sgndet" g_gsl_linalg_complex_LU_sgndet "" 2)) - + (int gsl_linalg_hessenberg_decomp (gsl_matrix* gsl_vector*)) (int gsl_linalg_hessenberg_unpack (gsl_matrix* gsl_vector* gsl_matrix*)) (int gsl_linalg_hessenberg_unpack_accum (gsl_matrix* gsl_vector* gsl_matrix*)) @@ -2508,7 +2508,7 @@ int s = 0; return(s7_make_integer(sc, (s7_int)gsl_linalg_QRPT_decomp( (gsl_matrix *)s7_c_pointer_with_type(sc, s7_car(args), gsl_matrix__symbol, __func__, 1), - (gsl_vector *)s7_c_pointer_with_type(sc, s7_cadr(args), gsl_vector__symbol, __func__, 2), + (gsl_vector *)s7_c_pointer_with_type(sc, s7_cadr(args), gsl_vector__symbol, __func__, 2), (gsl_permutation *)s7_c_pointer_with_type(sc, s7_caddr(args), gsl_permutation__symbol, __func__, 3), &s, (gsl_vector *)s7_c_pointer_with_type(sc, s7_cadddr(args), gsl_vector__symbol, __func__, 4)))); }") @@ -2518,10 +2518,10 @@ { int s = 0; return(s7_make_integer(sc, (s7_int)gsl_linalg_QRPT_decomp2( - (gsl_matrix *)s7_c_pointer_with_type(sc, s7_car(args), gsl_matrix__symbol, __func__, 1), + (gsl_matrix *)s7_c_pointer_with_type(sc, s7_car(args), gsl_matrix__symbol, __func__, 1), (gsl_matrix *)s7_c_pointer_with_type(sc, s7_cadr(args), gsl_matrix__symbol, __func__, 2), (gsl_matrix *)s7_c_pointer_with_type(sc, s7_caddr(args), gsl_matrix__symbol, __func__, 3), - (gsl_vector *)s7_c_pointer_with_type(sc, s7_cadddr(args), gsl_vector__symbol, __func__, 4), + (gsl_vector *)s7_c_pointer_with_type(sc, s7_cadddr(args), gsl_vector__symbol, __func__, 4), (gsl_permutation *)s7_c_pointer_with_type(sc, s7_list_ref(sc, args, 5), gsl_permutation__symbol, __func__, 5), &s, (gsl_vector *)s7_c_pointer_with_type(sc, s7_list_ref(sc, args, 6), gsl_vector__symbol, __func__, 6)))); @@ -2551,8 +2551,8 @@ int s = 0; return(s7_make_integer(sc, (s7_int)gsl_linalg_PTLQ_decomp( (gsl_matrix *)s7_c_pointer_with_type(sc, s7_car(args), gsl_matrix__symbol, __func__, 1), - (gsl_vector *)s7_c_pointer_with_type(sc, s7_cadr(args), gsl_vector__symbol, __func__, 2), - (gsl_permutation *)s7_c_pointer_with_type(sc, s7_caddr(args), gsl_permutation__symbol, __func__, 3), + (gsl_vector *)s7_c_pointer_with_type(sc, s7_cadr(args), gsl_vector__symbol, __func__, 2), + (gsl_permutation *)s7_c_pointer_with_type(sc, s7_caddr(args), gsl_permutation__symbol, __func__, 3), &s, (gsl_vector *)s7_c_pointer_with_type(sc, s7_cadddr(args), gsl_vector__symbol, __func__, 4)))); }") @@ -2565,8 +2565,8 @@ (gsl_matrix *)s7_c_pointer_with_type(sc, s7_car(args), gsl_matrix__symbol, __func__, 1), (gsl_matrix *)s7_c_pointer_with_type(sc, s7_cadr(args), gsl_matrix__symbol, __func__, 2), (gsl_matrix *)s7_c_pointer_with_type(sc, s7_caddr(args), gsl_matrix__symbol, __func__, 3), - (gsl_vector *)s7_c_pointer_with_type(sc, s7_cadddr(args), gsl_vector__symbol, __func__, 4), - (gsl_permutation *)s7_c_pointer_with_type(sc, s7_list_ref(sc, args, 5), gsl_permutation__symbol, __func__, 5), + (gsl_vector *)s7_c_pointer_with_type(sc, s7_cadddr(args), gsl_vector__symbol, __func__, 4), + (gsl_permutation *)s7_c_pointer_with_type(sc, s7_list_ref(sc, args, 5), gsl_permutation__symbol, __func__, 5), &s, (gsl_vector *)s7_c_pointer_with_type(sc, s7_list_ref(sc, args, 6), gsl_vector__symbol, __func__, 6)))); }") @@ -2617,7 +2617,7 @@ (int gsl_linalg_ldlt_band_svx (gsl_matrix* gsl_vector*)) (int gsl_linalg_ldlt_band_unpack (gsl_matrix* gsl_matrix* gsl_vector*)) (int gsl_linalg_ldlt_band_rcond (gsl_matrix* double* gsl_vector*)))) - + (gsl_matrix_complex* gsl_matrix_complex_alloc (size_t size_t)) (gsl_matrix_complex* gsl_matrix_complex_calloc (size_t size_t)) (gsl_matrix_complex* gsl_matrix_complex_alloc_from_matrix (gsl_matrix_complex* size_t size_t size_t size_t)) @@ -2648,7 +2648,7 @@ (int gsl_matrix_complex_sub (gsl_matrix_complex* gsl_matrix_complex*)) (int gsl_matrix_complex_mul_elements (gsl_matrix_complex* gsl_matrix_complex*)) (int gsl_matrix_complex_div_elements (gsl_matrix_complex* gsl_matrix_complex*)) - + (in-C " static s7_pointer g_gsl_matrix_complex_set_all(s7_scheme *sc, s7_pointer args) { @@ -2661,7 +2661,7 @@ { gsl_complex g; s7_pointer cg; - cg = s7_cadddr(args); + cg = s7_cadddr(args); S7_TO_GSL_COMPLEX(cg, g); gsl_matrix_complex_set((gsl_matrix_complex *)s7_c_pointer_with_type(sc, s7_car(args), gsl_matrix_complex__symbol, __func__, 1), s7_integer(s7_cadr(args)), s7_integer(s7_caddr(args)), g); return(cg); @@ -2704,16 +2704,16 @@ (C-function ("gsl_matrix_complex_scale" g_gsl_matrix_complex_scale "" 2)) (C-function ("gsl_matrix_complex_add_constant" g_gsl_matrix_complex_add_constant "" 2)) (C-function ("gsl_matrix_complex_add_diagonal" g_gsl_matrix_complex_add_diagonal "" 2)) - + (int gsl_matrix_complex_get_row (gsl_vector_complex* gsl_matrix_complex* size_t)) (int gsl_matrix_complex_get_col (gsl_vector_complex* gsl_matrix_complex* size_t)) (int gsl_matrix_complex_set_row (gsl_matrix_complex* size_t gsl_vector_complex*)) (int gsl_matrix_complex_set_col (gsl_matrix_complex* size_t gsl_vector_complex*)) (gsl_complex* gsl_matrix_complex_ptr (gsl_matrix_complex* size_t size_t)) (gsl_complex* gsl_matrix_complex_const_ptr (gsl_matrix_complex* size_t size_t)) - + (void gsl_message (char* char* int int)) - + (gsl_min_fminimizer* gsl_min_fminimizer_alloc (gsl_min_fminimizer_type*) ) (void gsl_min_fminimizer_free (gsl_min_fminimizer*)) (int gsl_min_fminimizer_set (gsl_min_fminimizer* gsl_function* double double double)) @@ -2729,13 +2729,13 @@ (double gsl_min_fminimizer_minimum (gsl_min_fminimizer*)) (int gsl_min_test_interval (double double double double)) (int gsl_min_find_bracket (gsl_function* double* double* double* double* double* double* size_t)) - + ;; gsl_monte* is not doable -- they chose to pass a bare double* array to the (parameter) gsl_monte_function, ;; and there's nothing I can do with that. To wrap and unwrap it on every call would make it unusable. ;; I could keep wrappers around of all so-far-used sizes, but not until someone actually needs them. ;; the fdf cases [removed in gsl 2.0?] are similar, I think, and the ode functions. GSL also assumes direct access to their ;; structs (as in matrix size1/2) -- not very nice for our style of use. - + (gsl_multifit_linear_workspace* gsl_multifit_linear_alloc (size_t size_t)) (void gsl_multifit_linear_free (gsl_multifit_linear_workspace*)) (int gsl_multifit_linear (gsl_matrix* gsl_vector* gsl_vector* gsl_matrix* double* gsl_multifit_linear_workspace*)) @@ -2748,7 +2748,7 @@ (reader-cond ((>= gsl-version 2.3) (size_t gsl_multifit_linear_rank (double gsl_multifit_linear_workspace*)))) (int gsl_multifit_linear_residuals (gsl_matrix* gsl_vector* gsl_vector* gsl_vector*)) - (reader-cond ((>= gsl-version 1.16) + (reader-cond ((>= gsl-version 1.16) (gsl_multifit_robust_workspace* gsl_multifit_robust_alloc (gsl_multifit_robust_type* size_t size_t)) (void gsl_multifit_robust_free (gsl_multifit_robust_workspace*)) (int gsl_multifit_robust_tune (double gsl_multifit_robust_workspace*)) @@ -2767,12 +2767,12 @@ (gsl_vector* gsl_multifit_fsolver_position (gsl_multifit_fsolver*)) (int gsl_multifit_test_delta (gsl_vector* gsl_vector* double double)) (int gsl_multifit_test_gradient (gsl_vector* double)) - - (reader-cond + + (reader-cond ((< gsl-version 2.0) (int gsl_multifit_linear_svd (gsl_matrix* gsl_vector* double size_t* gsl_vector* gsl_matrix* double* gsl_multifit_linear_workspace*)) (int gsl_multifit_linear_usvd (gsl_matrix* gsl_vector* double size_t* gsl_vector* gsl_matrix* double* gsl_multifit_linear_workspace*))) - + ((= gsl-version 2.0) (int gsl_multifit_linear_svd (gsl_matrix* gsl_multifit_linear_workspace*)) (int gsl_multifit_linear_bsvd (gsl_matrix* gsl_multifit_linear_workspace*)) @@ -2780,7 +2780,7 @@ (int gsl_multifit_linear_applyW (gsl_matrix* gsl_vector* gsl_vector* gsl_matrix* gsl_vector* gsl_multifit_linear_workspace*)) (int gsl_multifit_linear_stdform1 (gsl_vector* gsl_matrix* gsl_vector* gsl_matrix* gsl_vector* gsl_multifit_linear_workspace*)) (int gsl_multifit_linear_wstdform1 (gsl_vector* gsl_matrix* gsl_vector* gsl_vector* gsl_matrix* gsl_vector* gsl_multifit_linear_workspace*)) - + (int gsl_multifit_linear_stdform2 (gsl_matrix* gsl_matrix* gsl_vector* gsl_matrix* gsl_vector* gsl_matrix* gsl_multifit_linear_workspace*)) (int gsl_multifit_linear_wstdform2 (gsl_matrix* gsl_matrix* gsl_vector* gsl_vector* gsl_matrix* gsl_vector* gsl_matrix* gsl_multifit_linear_workspace*)) (int gsl_multifit_linear_genform1 (gsl_vector* gsl_vector* gsl_vector* gsl_multifit_linear_workspace*)) @@ -2796,8 +2796,8 @@ (int gsl_multifit_robust_weights (gsl_vector* gsl_vector* gsl_multifit_robust_workspace*)) (int gsl_multifit_robust_residuals (gsl_matrix* gsl_vector* gsl_vector* gsl_vector* gsl_multifit_robust_workspace*)) (int gsl_multifit_covar_QRPT (gsl_matrix* gsl_permutation* double gsl_matrix*))) - - (#t + + (#t (int gsl_multifit_linear_svd (gsl_matrix* gsl_multifit_linear_workspace*)) (int gsl_multifit_linear_bsvd (gsl_matrix* gsl_multifit_linear_workspace*)) (int gsl_multifit_linear_solve (double gsl_matrix* gsl_vector* gsl_vector* double* double* gsl_multifit_linear_workspace*)) @@ -2805,11 +2805,11 @@ (int gsl_multifit_linear_stdform1 (gsl_vector* gsl_matrix* gsl_vector* gsl_matrix* gsl_vector* gsl_multifit_linear_workspace*)) (int gsl_multifit_linear_wstdform1 (gsl_vector* gsl_matrix* gsl_vector* gsl_vector* gsl_matrix* gsl_vector* gsl_multifit_linear_workspace*)) (int gsl_multifit_linear_stdform2 (gsl_matrix* gsl_vector* gsl_matrix* gsl_vector* gsl_matrix* gsl_vector* gsl_matrix* gsl_multifit_linear_workspace*)) - (int gsl_multifit_linear_wstdform2 (gsl_matrix* gsl_vector* gsl_matrix* gsl_vector* gsl_vector* gsl_matrix* gsl_vector* gsl_matrix* + (int gsl_multifit_linear_wstdform2 (gsl_matrix* gsl_vector* gsl_matrix* gsl_vector* gsl_vector* gsl_matrix* gsl_vector* gsl_matrix* gsl_multifit_linear_workspace*)) (int gsl_multifit_linear_genform1 (gsl_vector* gsl_vector* gsl_vector* gsl_multifit_linear_workspace*)) (int gsl_multifit_linear_genform2 (gsl_matrix* gsl_vector* gsl_matrix* gsl_vector* gsl_vector* gsl_matrix* gsl_vector* gsl_multifit_linear_workspace*)) - (int gsl_multifit_linear_wgenform2 (gsl_matrix* gsl_vector* gsl_matrix* gsl_vector* gsl_vector* gsl_vector* gsl_matrix* gsl_vector* + (int gsl_multifit_linear_wgenform2 (gsl_matrix* gsl_vector* gsl_matrix* gsl_vector* gsl_vector* gsl_vector* gsl_matrix* gsl_vector* gsl_multifit_linear_workspace*)) (int gsl_multifit_linear_lreg (double double gsl_vector*)) (int gsl_multifit_linear_lcurve (gsl_vector* gsl_vector* gsl_vector* gsl_vector* gsl_multifit_linear_workspace*)) @@ -2821,7 +2821,7 @@ (int gsl_multifit_robust_weights (gsl_vector* gsl_vector* gsl_multifit_robust_workspace*)) (int gsl_multifit_robust_residuals (gsl_matrix* gsl_vector* gsl_vector* gsl_vector* gsl_multifit_robust_workspace*)) (int gsl_multifit_covar_QRPT (gsl_matrix* gsl_permutation* double gsl_matrix*)) - + (gsl_multilarge_linear_workspace* gsl_multilarge_linear_alloc (gsl_multilarge_linear_type* size_t)) (void gsl_multilarge_linear_free (gsl_multilarge_linear_workspace*)) (char* gsl_multilarge_linear_name (gsl_multilarge_linear_workspace*)) @@ -2837,7 +2837,7 @@ (int gsl_multilarge_linear_stdform2 (gsl_matrix* gsl_vector* gsl_matrix* gsl_vector* gsl_matrix* gsl_vector* gsl_multilarge_linear_workspace*)) (int gsl_multilarge_linear_genform1 (gsl_vector* gsl_vector* gsl_vector* gsl_multilarge_linear_workspace*)) (int gsl_multilarge_linear_genform2 (gsl_matrix* gsl_vector* gsl_vector* gsl_vector* gsl_multilarge_linear_workspace*)))) - + (gsl_multimin_fminimizer* gsl_multimin_fminimizer_alloc (gsl_multimin_fminimizer_type* size_t)) (void gsl_multimin_fminimizer_free (gsl_multimin_fminimizer*)) (char* gsl_multimin_fminimizer_name (gsl_multimin_fminimizer*)) @@ -2847,15 +2847,15 @@ (double gsl_multimin_fminimizer_size (gsl_multimin_fminimizer*)) (int gsl_multimin_test_gradient (gsl_vector* double)) (int gsl_multimin_test_size (double double)) - + ;; multimin_function is double f(gsl_vector* void*) -- so we can handle it (but not the fdf brand) (in-C " static s7_scheme *gsl_mmf_s7; static gsl_multimin_function gsl_mmf; - static double gsl_mmf_caller(const gsl_vector *x, void *p) + static double gsl_mmf_caller(const gsl_vector *x, void *p) { - return(s7_real(s7_call(gsl_mmf_s7, (s7_pointer)p, - s7_cons(gsl_mmf_s7, + return(s7_real(s7_call(gsl_mmf_s7, (s7_pointer)p, + s7_cons(gsl_mmf_s7, s7_make_c_pointer_with_type(gsl_mmf_s7, (void *)x, s7_make_symbol(gsl_mmf_s7, \"gsl_vector*\"), s7_f(gsl_mmf_s7)), s7_nil(gsl_mmf_s7))))); } @@ -2864,7 +2864,7 @@ { make_gsl_mm_function(s7_cadr(args), ((gsl_vector *)s7_c_pointer_with_type(sc, s7_caddr(args), gsl_vector__symbol, __func__, 3))->size); return(s7_make_integer(sc, gsl_multimin_fminimizer_set((gsl_multimin_fminimizer *)s7_c_pointer_with_type(sc, s7_car(args), gsl_multimin_fminimizer__symbol, __func__, 1), - &gsl_mmf, (gsl_vector *)s7_c_pointer_with_type(sc, s7_caddr(args), gsl_vector__symbol, __func__, 3), + &gsl_mmf, (gsl_vector *)s7_c_pointer_with_type(sc, s7_caddr(args), gsl_vector__symbol, __func__, 3), (gsl_vector *)s7_c_pointer_with_type(sc, s7_cadddr(args), gsl_vector__symbol, __func__, 4)))); } static s7_pointer g_gsl_multimin_diff(s7_scheme *sc, s7_pointer args) @@ -2878,15 +2878,15 @@ (C-function ("gsl_multimin_fminimizer_set" g_gsl_multimin_fminimizer_set "" 4)) (C-function ("gsl_multimin_diff" g_gsl_multimin_diff "" 3)) (C-function ("gsl_multimin_fminimizer_fval" g_gsl_multimin_fminimizer_fval "" 1)) - - + + ;; int f(const gsl_vector* void* gsl_vector*) so the function is doable (in-C " static s7_scheme *gsl_rf_s7; static gsl_multiroot_function gsl_rf; - static int gsl_rf_caller(const gsl_vector *x, void *p, gsl_vector *y) + static int gsl_rf_caller(const gsl_vector *x, void *p, gsl_vector *y) { - return(s7_integer(s7_call(gsl_rf_s7, (s7_pointer)p, + return(s7_integer(s7_call(gsl_rf_s7, (s7_pointer)p, s7_cons(gsl_rf_s7, s7_make_c_pointer_with_type(gsl_rf_s7, (void *)x, s7_make_symbol(gsl_rf_s7, \"gsl_vector*\"), s7_f(gsl_rf_s7)), s7_cons(gsl_rf_s7, s7_make_c_pointer_with_type(gsl_rf_s7, (void *)y, s7_make_symbol(gsl_rf_s7, \"gsl_vector*\"), s7_f(gsl_rf_s7)), s7_nil(gsl_rf_s7)))))); @@ -2894,22 +2894,22 @@ #define make_gsl_rf_function(Args, Size) do {gsl_rf.f = gsl_rf_caller; gsl_rf.n = Size; gsl_rf.params = (void *)Args; gsl_rf_s7 = sc;} while (0) static s7_pointer g_gsl_multiroot_fsolver_set(s7_scheme *sc, s7_pointer args) { - make_gsl_rf_function(s7_cadr(args), + make_gsl_rf_function(s7_cadr(args), ((gsl_vector *)s7_c_pointer_with_type(sc, s7_caddr(args), gsl_vector__symbol, __func__, 1))->size); return(s7_make_integer(sc, gsl_multiroot_fsolver_set( (gsl_multiroot_fsolver *)s7_c_pointer_with_type(sc, s7_car(args), gsl_multiroot_fsolver__symbol, __func__, 2), - &gsl_rf, + &gsl_rf, (const gsl_vector *)s7_c_pointer_with_type(sc, s7_caddr(args), gsl_vector__symbol, __func__, 3)))); } static s7_pointer g_gsl_multiroot_fdjacobian(s7_scheme *sc, s7_pointer args) { - make_gsl_rf_function(s7_car(args), + make_gsl_rf_function(s7_car(args), ((gsl_vector *)s7_c_pointer_with_type(sc, s7_cadr(args), gsl_vector__symbol, __func__, 2))->size); return(s7_make_integer(sc, gsl_multiroot_fdjacobian( - &gsl_rf, - (gsl_vector *)s7_c_pointer_with_type(sc, s7_cadr(args), gsl_vector__symbol, __func__, 2), + &gsl_rf, + (gsl_vector *)s7_c_pointer_with_type(sc, s7_cadr(args), gsl_vector__symbol, __func__, 2), (gsl_vector *)s7_c_pointer_with_type(sc, s7_caddr(args), gsl_vector__symbol, __func__, 3), - s7_real(s7_cadddr(args)), + s7_real(s7_cadddr(args)), (gsl_matrix *)s7_list_ref(sc, args, 5)))); }") (C-function ("gsl_multiroot_fsolver_set" g_gsl_multiroot_fsolver_set "" 3)) @@ -2923,7 +2923,7 @@ (gsl_vector* gsl_multiroot_fsolver_f (gsl_multiroot_fsolver*)) (int gsl_multiroot_test_delta (gsl_vector* gsl_vector* double double)) (int gsl_multiroot_test_residual (gsl_vector* double)) - + (gsl_multiset* gsl_multiset_alloc (size_t size_t)) (gsl_multiset* gsl_multiset_calloc (size_t size_t)) (void gsl_multiset_init_first (gsl_multiset*)) @@ -2941,7 +2941,7 @@ (int gsl_multiset_next (gsl_multiset*)) (int gsl_multiset_prev (gsl_multiset*)) (size_t gsl_multiset_get (gsl_multiset* size_t)) - + ;; the ode functions all pass bare double* arrays to the called function. (gsl_permutation* gsl_permutation_alloc (size_t)) (gsl_permutation* gsl_permutation_calloc (size_t)) @@ -2975,7 +2975,7 @@ (int gsl_permute_vector_complex_inverse (gsl_permutation* gsl_vector_complex*)) (int gsl_permute_vector (gsl_permutation* gsl_vector*)) (int gsl_permute_vector_inverse (gsl_permutation* gsl_vector*)) - + (gsl_root_fsolver* gsl_root_fsolver_alloc (gsl_root_fsolver_type*)) (void gsl_root_fsolver_free (gsl_root_fsolver*)) (int gsl_root_fsolver_set (gsl_root_fsolver* gsl_function* double double)) @@ -2987,7 +2987,7 @@ (int gsl_root_test_interval (double double double double)) (int gsl_root_test_residual (double double)) (int gsl_root_test_delta (double double double double)) - + (gsl_sum_levin_u_workspace* gsl_sum_levin_u_alloc (size_t)) (void gsl_sum_levin_u_free (gsl_sum_levin_u_workspace*)) (int gsl_sum_levin_u_accel (double* size_t gsl_sum_levin_u_workspace* double* double*)) @@ -2998,7 +2998,7 @@ (int gsl_sum_levin_utrunc_accel (double* size_t gsl_sum_levin_utrunc_workspace* double* double*)) (int gsl_sum_levin_utrunc_minmax (double* size_t size_t size_t gsl_sum_levin_utrunc_workspace* double* double*)) (int gsl_sum_levin_utrunc_step (double size_t gsl_sum_levin_utrunc_workspace* double*)) - + (gsl_wavelet* gsl_wavelet_alloc (gsl_wavelet_type* size_t)) (void gsl_wavelet_free (gsl_wavelet*)) (char* gsl_wavelet_name (gsl_wavelet*)) @@ -3019,7 +3019,7 @@ (int gsl_wavelet2d_nstransform_matrix (gsl_wavelet* gsl_matrix* (gsl_wavelet_direction int) gsl_wavelet_workspace*)) (int gsl_wavelet2d_nstransform_matrix_forward (gsl_wavelet* gsl_matrix* gsl_wavelet_workspace*)) (int gsl_wavelet2d_nstransform_matrix_inverse (gsl_wavelet* gsl_matrix* gsl_wavelet_workspace*)) - + (reader-cond ((>= gsl-version 2.0) ;; rstat (gsl_rstat_quantile_workspace* gsl_rstat_quantile_alloc (double)) @@ -3040,26 +3040,26 @@ (double gsl_rstat_skew (gsl_rstat_workspace*)) (double gsl_rstat_kurtosis (gsl_rstat_workspace*)) (int gsl_rstat_reset (gsl_rstat_workspace*)) - + ;; spblas (int gsl_spblas_dgemv ((CBLAS_TRANSPOSE_t int) double gsl_spmatrix* gsl_vector* double gsl_vector*)) (int gsl_spblas_dgemm (double gsl_spmatrix* gsl_spmatrix* gsl_spmatrix*)) ;(size_t gsl_spblas_scatter (gsl_spmatrix* size_t double size_t* double* int gsl_spmatrix* size_t)) - + ;; splinalg (gsl_splinalg_itersolve_type* gsl_splinalg_itersolve_gmres) - + (gsl_splinalg_itersolve* gsl_splinalg_itersolve_alloc (gsl_splinalg_itersolve_type* size_t size_t)) (void gsl_splinalg_itersolve_free (gsl_splinalg_itersolve*)) (char* gsl_splinalg_itersolve_name (gsl_splinalg_itersolve*)) (int gsl_splinalg_itersolve_iterate (gsl_spmatrix* gsl_vector* double gsl_vector* gsl_splinalg_itersolve*)) (double gsl_splinalg_itersolve_normr (gsl_splinalg_itersolve*)) - + ;; spmatrix (C-macro (int (GSL_SPMATRIX_TRIPLET GSL_SPMATRIX_CCS))) ;; #define GSL_SPMATRIX_ISTRIPLET (m) ((m)->sptype == GSL_SPMATRIX_TRIPLET) ;; #define GSL_SPMATRIX_ISCCS (m) ((m)->sptype == GSL_SPMATRIX_CCS) - + (gsl_spmatrix* gsl_spmatrix_alloc (size_t size_t)) (gsl_spmatrix* gsl_spmatrix_alloc_nzmax (size_t size_t size_t size_t)) (void gsl_spmatrix_free (gsl_spmatrix*)) @@ -3079,10 +3079,10 @@ (int gsl_spmatrix_sp2d (gsl_matrix* gsl_spmatrix*)) (int gsl_spmatrix_equal (gsl_spmatrix* gsl_spmatrix*)) (int gsl_spmatrix_transpose_memcpy (gsl_spmatrix* gsl_spmatrix*)) - + ;; interp2d (gsl_interp2d_type* (gsl_interp2d_bilinear gsl_interp2d_bicubic)) - + (gsl_interp2d* gsl_interp2d_alloc (gsl_interp2d_type* size_t size_t)) (char* gsl_interp2d_name (gsl_interp2d*)) (size_t gsl_interp2d_min_size (gsl_interp2d*)) @@ -3108,7 +3108,7 @@ (int gsl_interp2d_eval_deriv_yy_e (gsl_interp2d* double* double* double* double double gsl_interp_accel* gsl_interp_accel* double*)) (double gsl_interp2d_eval_deriv_xy (gsl_interp2d* double* double* double* double double gsl_interp_accel* gsl_interp_accel*)) (int gsl_interp2d_eval_deriv_xy_e (gsl_interp2d* double* double* double* double double gsl_interp_accel* gsl_interp_accel* double*)) - + ;; spline2n (gsl_spline2d* gsl_spline2d_alloc (gsl_interp2d_type* size_t size_t)) (int gsl_spline2d_init (gsl_spline2d* double* double* double* size_t size_t)) @@ -3178,7 +3178,7 @@ ;; (int gsl_linalg_cholesky_decomp2(gsl_matrix* gsl_vector*)) ;; (int gsl_linalg_cholesky_svx2 (gsl_matrix* gsl_vector* gsl_vector*)) ;; (int gsl_linalg_cholesky_solve2 (gsl_matrix* gsl_vector* gsl_vector* gsl_vector*)) - + ) "" (list "gsl/gsl_blas.h" "gsl/gsl_blas_types.h" @@ -3282,7 +3282,7 @@ "gsl/gsl_sf_pow_int.h" "gsl/gsl_sf_psi.h" "gsl/gsl_sf_result.h" - (reader-cond ((>= gsl-version 2.0) + (reader-cond ((>= gsl-version 2.0) "gsl/gsl_spblas.h" "gsl/gsl_splinalg.h" "gsl/gsl_spline2d.h" @@ -3310,7 +3310,7 @@ "gsl/gsl_wavelet.h" "gsl/gsl_wavelet2d.h" ) - + "-I/usr/local/include -g3 -DGSL_DISABLE_DEPRECATED" "-L/usr/local/lib -lgsl -lgslcblas" "libgsl_s7") @@ -19,7 +19,7 @@ (unless (defined? '*libm*) (define *libm* - (with-let (unlet) + (with-let (sublet (unlet)) (set! *libraries* (cons (cons "libm.scm" (curlet)) *libraries*)) (set! *cload-library-name* "*libm*") diff --git a/libutf8proc.scm b/libutf8proc.scm index f4b7217..8fa1ed2 100644 --- a/libutf8proc.scm +++ b/libutf8proc.scm @@ -2,6 +2,8 @@ ;;; ;;; tie the utf8proc library into the *libutf8proc* environment +(set! (*s7* 'print-length) 123123) + (require cload.scm) (provide 'libutf8proc.scm) @@ -19,7 +21,7 @@ (if (not (defined? '*libutf8proc*)) (define *libutf8proc* - (with-let (unlet) + (with-let (sublet (unlet)) (set! *libraries* (cons (cons "libutf8proc.scm" (curlet)) *libraries*)) @@ -65,6 +67,8 @@ (char* utf8proc_errmsg (int)) (int utf8proc_tolower ((utf8proc_int32_t int))) (int utf8proc_toupper ((utf8proc_int32_t int))) + (int utf8proc_islower (utf8proc_int32_t)) + (int utf8proc_isupper (utf8proc_int32_t)) (int utf8proc_charwidth ((utf8proc_int32_t int))) (int utf8proc_category ((utf8proc_int32_t int))) (char* utf8proc_category_string ((utf8proc_int32_t int))) @@ -79,14 +83,14 @@ (in-C "static s7_pointer g_utf8proc_iterate(s7_scheme *sc, s7_pointer args) { utf8proc_int32_t code_ref = 0; - int len, res; + s7_int len, res; char *str; str = (char *)s7_string(s7_car(args)); - len = s7_string_length(s7_car(args)); + len = s7_integer(s7_cadr(args)); res = utf8proc_iterate(str, len, &code_ref); - return(s7_list(sc, 2, s7_make_integer(sc, code_ref), s7_make_integer(sc, res))); + return(s7_cons(sc, s7_make_integer(sc, res), s7_make_integer(sc, code_ref))); }") - (C-function ("utf8proc_iterate" g_utf8proc_iterate "" 1)) + (C-function ("utf8proc_iterate" g_utf8proc_iterate "" 2)) (in-C "static s7_pointer g_utf8proc_encode_char(s7_scheme *sc, s7_pointer args) { @@ -109,7 +113,7 @@ (utf8proc_option_t)s7_integer(options)); return(s7_make_integer(sc, res)); }") - (C-function ("utf8proc_reencode" g_utf8proc_reencode "" 1)) + (C-function ("utf8proc_reencode" g_utf8proc_reencode "" 3)) (in-C "static s7_pointer g_utf8proc_get_property(s7_scheme *sc, s7_pointer args) { const utf8proc_property_t *info; @@ -158,25 +162,34 @@ }") (C-function ("utf8proc_decompose_char" g_utf8proc_decompose_char "" 3)) - (in-C "static s7_pointer g_utf8proc_map(s7_scheme *sc, s7_pointer args) + (in-C "static s7_pointer g_utf8proc_map(s7_scheme *sc, s7_pointer args) /* returns (cons string-or-#f size-of-string-or-error-integer) */ { s7_pointer opt, str, p; - ssize_t res; - utf8proc_uint8_t *dst; + utf8proc_ssize_t res; + s7_int len; + utf8proc_uint8_t *dst, *new_str; str = s7_car(args); + len = s7_string_length(str); opt = s7_cadr(args); - res = utf8proc_map((utf8proc_uint8_t *)s7_string(str), s7_string_length(str), &dst, (utf8proc_option_t)s7_integer(opt)); - if (res < 0) return(s7_make_integer(sc, res)); + new_str = (utf8proc_uint8_t *)malloc(len + 1); + memcpy((void *)new_str, (const void *)s7_string(str), len); /* online example uses len+1? */ + res = utf8proc_map(new_str, len, &dst, (utf8proc_option_t)s7_integer(opt)); + if (res < 0) + { + free(new_str); + return(s7_cons(sc, s7_f(sc), s7_make_integer(sc, res))); /* utf8proc library frees dst in this case */ + } p = s7_make_string_with_length(sc, dst, res); + free(new_str); free(dst); - return(p); + return(s7_cons(sc, p, s7_make_integer(sc, res))); }") (C-function ("utf8proc_map" g_utf8proc_map "" 2)) (in-C "static s7_pointer g_utf8proc_decompose(s7_scheme *sc, s7_pointer args) { s7_pointer opt, str; - int len; + s7_int len; ssize_t res; utf8proc_int32_t *dst; str = s7_car(args); @@ -5526,7 +5526,7 @@ (if (null? (cdr new-plus)) `(- ,(car new-plus) ,@new-minus) ; (- (+ x z) x y) -> (- z y) `(- (+ ,@new-plus) ,@new-minus)))))))) ; (- (+ x z w) x y) -> (- (+ w z) y) - + (if (len=3? new-form) (let ((arg1 (cadr new-form)) (arg2 (caddr new-form))) @@ -9467,7 +9467,7 @@ (unless (or (char-numeric? (string-ref str k)) (char=? (string-ref str k) #\,)) ;(format *stderr* "~C ~C~%" (string-ref str k) c) - (return (or (char=? (string-ref str k) #\') ; ~12,'-T + (return (or (char=? (string-ref str k) #\') ; ~12,'-T (char-ci=? (string-ref str k) #\t))))))))) ;; the possibilities are endless, so I'll stick to the simplest (if (not (vector-ref format-control-char (char->integer c))) ; (format #f "~H" 1) @@ -10387,7 +10387,7 @@ (if (pair? (cdr p)) ; not (inlet 'a 1 'b) (set! p (cdr p)) (lint-format "no value for last entry ~S in ~S" caller (car p) form))))))) - + (hash-special 'inlet sp-inlet) ) @@ -12576,14 +12576,14 @@ (eq? desired-type #t) (pair? desired-type))) (error 'wrong-type-arg "~S signature ~S is invalid" func sig)) - + ((not (or (eq? desired-type #t) (any-compatible? vtype desired-type))) (lint-format "~A is ~A, but ~A in ~A wants ~A" caller vname (prettify-checker-unq vtype) func (truncated-list->string call) (prettify-checker desired-type))) - + ((and (memq vtype '(float-vector? int-vector?)) (memq func '(vector-set! vector-ref))) (lint-format "~A is ~A, so perhaps use ~A, not ~A" caller @@ -12592,13 +12592,13 @@ (if (eq? func 'vector-set!) 'float-vector-set! 'float-vector-ref) (if (eq? func 'vector-set!) 'int-vector-set! 'int-vector-ref)) func)) - + ((and (eq? vtype 'float-vector?) (eq? func 'equal?) (or (eq? (cadr call) vname) (not (symbol? (cadr call))))) ; don't repeat the suggestion when we hit the second vector (lint-format "perhaps use equivalent? in ~A" caller (truncated-list->string call))) - + ((and (eq? vtype 'vector?) (memq func '(float-vector-set! float-vector-ref int-vector-set! int-vector-ref byte-vector-set! byte-vector-ref))) (lint-format "~A is ~A, so use ~A, not ~A" caller @@ -12913,7 +12913,7 @@ (unless vtype (set! vtype (or (eq? caller top-level:) ; might be a global var where init value is largely irrelevant (->lint-type (var-initial-value local-var))))) - + (let ((lit? (and (code-constant? (var-initial-value local-var)) (not (quoted-null? (var-initial-value local-var)))))) ; something fishy is going on... diff --git a/mockery.scm b/mockery.scm index 7b77773..9f7cfb5 100644 --- a/mockery.scm +++ b/mockery.scm @@ -1004,6 +1004,7 @@ 'write (with-mock-wrapper* #_write) 'display (with-mock-wrapper* #_display) 'fill! (with-mock-wrapper* #_fill!) + 'class-name '*mock-c-pointer* ))) (define* (mock-c-pointer (int 0) type info weak1 weak2) @@ -1034,6 +1035,7 @@ 'format (with-mock-wrapper* #_format) 'write (with-mock-wrapper* #_write) 'display (with-mock-wrapper* #_display) + 'class-name '*mock-random-state* ))) (define* (mock-random-state seed (carry 1675393560)) @@ -1065,6 +1067,7 @@ 'format (with-mock-wrapper* #_format) 'write (with-mock-wrapper* #_write) 'display (with-mock-wrapper* #_display) + 'class-name '*mock-iterator* ))) (define (make-mock-iterator . args) @@ -606,7 +606,7 @@ typedef struct { const char *doc; opt_funcs_t *opt_data; /* vunion-functions (see below) */ s7_pointer generic_ff, setter, signature, pars; - s7_pointer (*chooser)(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool ops); + s7_pointer (*chooser)(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr); /* arg_defaults|names call_args only T_C_FUNCTION_STAR -- call args for GC protection */ union { s7_pointer *arg_defaults; @@ -2723,10 +2723,7 @@ static void init_types(void) #define opt1_func_listed(p) has_high_type_bit(T_Pair(p), T_OPT1_FUNC_LISTED) #define set_opt1_func_listed(p) set_high_type_bit(T_Pair(p), T_OPT1_FUNC_LISTED) -#define T_FULL_HAS_GX (1LL << (48 + 10)) -#define T_HAS_GX (1 << 10) -#define has_gx(p) has_high_type_bit(T_Pair(p), T_HAS_GX) -#define set_has_gx(p) set_high_type_bit(T_Pair(p), T_HAS_GX) +/* (1LL << (48 + 10)) was HAS_GX, is now free */ #define T_FULL_UNKNOPT (1LL << (48 + 11)) #define T_UNKNOPT (1 << 11) @@ -3665,42 +3662,13 @@ const char *display(s7_pointer obj) return(res); } #else -#define display(Obj) string_value(s7_object_to_string(sc, Obj, false)) +#define display(Obj) string_value(s7_object_to_string(cur_sc, Obj, false)) #endif -#define display_80(Obj) string_value(object_to_truncated_string(sc, Obj, 80)) +#define display_80(Obj) string_value(object_to_truncated_string(cur_sc, Obj, 80)) #if S7_DEBUGGING -#if WITH_ALLOC_COUNTERS -static int allocs[100000]; -static const char *alloc_funcs[100000]; -static void report_allocs(int lim) -{ - int mx = -1, mxline = -1; - const char *mxfunc; - fprintf(stderr, "\n"); - for (int j = 0; j < lim; j++) - { - for (int i = 0; i < 100000; i++) - if (allocs[i] > mx) - { - mx = allocs[i]; - mxline = i; - mxfunc = alloc_funcs[i]; - } - if (mx <= 0) break; - fprintf(stderr, "%s[%d]: %d\n", mxfunc, mxline, mx); - allocs[mxline] = 0; - mx = -1; - } -} -#endif - static void set_type_1(s7_pointer p, uint64_t f, const char *func, int32_t line) { -#if WITH_ALLOC_COUNTERS - alloc_funcs[line] = func; - allocs[line]++; -#endif p->alloc_line = line; p->alloc_func = func; p->alloc_type = f; @@ -4263,7 +4231,7 @@ enum {OP_UNOPT, OP_GC_PROTECT, /* must be an even number of ops here, op_gc_prot OP_APPLY_SS, OP_APPLY_SA, OP_APPLY_SL, OP_MACRO_D, OP_MACRO_STAR_D, OP_WITH_IO, OP_WITH_IO_1, OP_WITH_OUTPUT_TO_STRING, OP_WITH_IO_C, OP_CALL_WITH_OUTPUT_STRING, - OP_S, OP_S_G, OP_S_A, OP_S_AA, OP_A_A, OP_A_AA, OP_P_S, OP_P_S_1, OP_MAP_FOR_EACH_FA, OP_MAP_FOR_EACH_FAA, + OP_S, OP_S_G, OP_S_A, OP_S_AA, OP_A_A, OP_A_AA, OP_A_SC, OP_P_S, OP_P_S_1, OP_MAP_FOR_EACH_FA, OP_MAP_FOR_EACH_FAA, OP_F, OP_F_A, OP_F_AA, OP_F_NP, OP_F_NP_1, OP_IMPLICIT_GOTO, OP_IMPLICIT_GOTO_A, OP_IMPLICIT_CONTINUATION_A, OP_IMPLICIT_ITERATE, @@ -4370,7 +4338,7 @@ enum {OP_UNOPT, OP_GC_PROTECT, /* must be an even number of ops here, op_gc_prot OP_CLOSURE_AP_1, OP_CLOSURE_PA_1, OP_CLOSURE_PP_1, OP_CLOSURE_P_1, OP_SAFE_CLOSURE_P_1, OP_SAFE_CLOSURE_P_A_1, OP_SAFE_CLOSURE_AP_1, OP_SAFE_CLOSURE_PA_1, OP_SAFE_CLOSURE_PP_1, - OP_ANY_CLOSURE_3P_1, OP_ANY_CLOSURE_3P_2, OP_ANY_CLOSURE_3P_3, OP_ANY_CLOSURE_NP_1, + OP_ANY_CLOSURE_3P_1, OP_ANY_CLOSURE_3P_2, OP_ANY_CLOSURE_3P_3, OP_ANY_CLOSURE_NP_1, OP_ANY_CLOSURE_4P_1, OP_ANY_CLOSURE_4P_2, OP_ANY_CLOSURE_4P_3, OP_ANY_CLOSURE_4P_4, OP_ANY_CLOSURE_NP_2, OP_TC_AND_A_OR_A_LA, OP_TC_OR_A_AND_A_LA, OP_TC_AND_A_OR_A_LAA, OP_TC_OR_A_AND_A_LAA, OP_TC_AND_A_OR_A_L3A, OP_TC_OR_A_AND_A_L3A, @@ -4480,7 +4448,7 @@ static const char* op_names[NUM_OPS] = "apply_ss", "apply_sa", "apply_sl", "macro_d", "macro*_d", "with_input_from_string", "with_input_from_string_1", "with_output_to_string", "with_input_from_string_c", "call_with_output_string", - "s", "s_g", "s_a", "s_aa", "a_a", "a_aa", "p_s", "p_s_1", "map_for_each_fa", "map_for_each_faa", + "s", "s_g", "s_a", "s_aa", "a_a", "a_aa", "a_sc", "p_s", "p_s_1", "map_for_each_fa", "map_for_each_faa", "f", "f_a", "f_aa", "f_np", "f_np_1", "implicit_goto", "implicit_goto_a", "implicit_continuation_a","implicit_iterate", @@ -4750,7 +4718,7 @@ void s7_show_history(s7_scheme *sc) } #if S7_DEBUGGING -#define UNUSED_BITS 0xfc00000000c0 /* high 6 bits of optimizer code + high 2 bits of type */ +#define UNUSED_BITS 0x400fc00000000c0 /* high 6 bits of optimizer code + high 2 bits of type + bit 58 (was gx) */ static char *describe_type_bits(s7_scheme *sc, s7_pointer obj) { @@ -4929,8 +4897,7 @@ static char *describe_type_bits(s7_scheme *sc, s7_pointer obj) ((full_typ & T_FULL_CASE_KEY) != 0) ? ((is_symbol(obj)) ? " case-key" : ((is_pair(obj)) ? " opt1-func-listed" : " ?33?")) : "", - /* bit 34+24 */ - ((full_typ & T_FULL_HAS_GX) != 0) ? ((is_pair(obj)) ? " has-gx" : " ?34?") : "", + /* bit 34+24 free */ /* bit 35+24 */ ((full_typ & T_FULL_UNKNOPT) != 0) ? ((is_pair(obj)) ? " unknopt" : " ?35?") : "", /* bit 36+24 */ @@ -5004,7 +4971,6 @@ static bool has_odd_bits(s7_pointer obj) if (((full_typ & T_FULL_CASE_KEY) != 0) && (!is_symbol(obj)) && (!is_pair(obj))) return(true); if (((full_typ & T_FULL_UNKNOPT) != 0) && (!is_pair(obj))) return(true); if (((full_typ & T_FULL_SAFETY_CHECKED) != 0) && (!is_pair(obj))) return(true); - if (((full_typ & T_FULL_HAS_GX) != 0) && (!is_pair(obj))) return(true); if (((full_typ & T_DONT_EVAL_ARGS) != 0) && (!is_any_macro(obj)) && (!is_syntax(obj))) return(true); if (((full_typ & T_CHECKED) != 0) && (!is_slot(obj)) && (!is_pair(obj)) && (!is_symbol(obj))) return(true); if (((full_typ & T_SHARED) != 0) && (!t_sequence_p[type(obj)]) && (!t_structure_p[type(obj)]) && (!is_any_closure(obj))) return(true); @@ -5604,9 +5570,9 @@ static void set_opt1_hash_1(s7_pointer p, uint64_t x) static void show_opt2_bits(s7_pointer p, const char *func, int32_t line, uint64_t role) { char *bits = show_debugger_bits(p); - fprintf(stderr, "%s%s[%d]%s: opt2: %p->%p wants %s, debugger bits are %" PRIx64 "%s but expects %" ld64 " %s", + fprintf(stderr, "%s%s[%d]%s: %s opt2: %p->%p wants %s, debugger bits are %" PRIx64 "%s but expects %" ld64 " %s", bold_text, func, line, unbold_text, - p, p->object.cons.o2.opt2, opt2_role_name(role), p->debugger_bits, bits, (s7_int)role, opt2_role_name(role)); + display(p), p, p->object.cons.o2.opt2, opt2_role_name(role), p->debugger_bits, bits, (s7_int)role, opt2_role_name(role)); free(bits); } @@ -6265,11 +6231,24 @@ static noreturn void syntax_error_with_caller2_nr(s7_scheme *sc, const char *err error_nr(sc, sc->syntax_error_symbol, set_elist_4(sc, wrap_string(sc, errmsg, len), caller, name, obj)); } +static s7_pointer make_symbol(s7_scheme *sc, const char *name, s7_int len); /* calls new_symbol */ +#define make_symbol_with_strlen(Sc, Name) make_symbol(Sc, Name, safe_strlen(Name)) + +static s7_pointer missing_method_class_name(s7_scheme *sc, s7_pointer obj) +{ + s7_pointer class_name = find_method(sc, obj, sc->class_name_symbol); + if (is_symbol(class_name)) return(class_name); + return(sc->is_openlet_symbol); +} + static noreturn void missing_method_error_nr(s7_scheme *sc, s7_pointer method, s7_pointer obj) { error_nr(sc, sc->missing_method_symbol, - set_elist_3(sc, wrap_string(sc, "missing ~S method in ~A", 23), method, - (is_c_object(obj)) ? c_object_scheme_name(sc, obj) : obj)); + set_elist_4(sc, wrap_string(sc, "missing ~S method in ~A ~A", 26), method, + (is_c_object(obj)) ? c_object_scheme_name(sc, obj) : + (((is_let(obj)) && (is_openlet(obj))) ? missing_method_class_name(sc, obj) : + s7_make_string_wrapper(sc, type_name(sc, obj, NO_ARTICLE))), + obj)); } static noreturn void immutable_object_error_nr(s7_scheme *sc, s7_pointer info) {error_nr(sc, sc->immutable_error_symbol, info);} @@ -7759,9 +7738,6 @@ static int64_t gc(s7_scheme *sc) #define GC_RESIZE_HEAP_BY_4_FRACTION 0.67 /* .5+.1: test -3?, dup +86, tmap +45, tsort -3, thash +305. .85+.7: dup -5 */ -static s7_pointer make_symbol(s7_scheme *sc, const char *name, s7_int len); /* calls new_symbol */ -#define make_symbol_with_strlen(Sc, Name) make_symbol(Sc, Name, safe_strlen(Name)) - #if S7_DEBUGGING #define resize_heap_to(Sc, Size) resize_heap_to_1(Sc, Size, __func__, __LINE__) static void resize_heap_to_1(s7_scheme *sc, int64_t size, const char *func, int line) @@ -8363,8 +8339,9 @@ static void unstack_1(s7_scheme *sc, opcode_t op, const char *func, int32_t line { fprintf(stderr, "%s%s[%d]: popped %s? (expected %s)%s\n", bold_text, func, line, op_names[(opcode_t)T_Op(stack_end_op(sc))], op_names[op], unbold_text); /* "popped apply" means we called something that went to eval+apply when we thought it was a safe function */ - fprintf(stderr, " code: %s, args: %s\n", display(sc->code), display(sc->args)); - fprintf(stderr, " cur_code: %s, estr: %s\n", display(current_code(sc)), display(s7_name_to_value(sc, "estr"))); + fprintf(stderr, " code: %s\n args: %s\n", display(sc->code), display(sc->args)); + fprintf(stderr, " cur_code: %s\n estr: %s\n", display(current_code(sc)), display(s7_name_to_value(sc, "estr"))); + s7_show_stack(sc); if (sc->stop_at_error) abort(); } } @@ -8449,14 +8426,14 @@ static void resize_stack(s7_scheme *sc) s7_pointer s7_gc_protect_via_stack(s7_scheme *sc, s7_pointer x) { check_stack_size(sc); /* this can be called externally, so we need to be careful about this */ - push_stack_no_let_no_code(sc, OP_GC_PROTECT, x); + push_stack_no_code(sc, OP_GC_PROTECT, x); return(x); } s7_pointer s7_gc_protect_2_via_stack(s7_scheme *sc, s7_pointer x, s7_pointer y) { check_stack_size(sc); - push_stack_no_let(sc, OP_GC_PROTECT, x, y); + push_stack(sc, OP_GC_PROTECT, x, y); return(x); } @@ -8488,9 +8465,10 @@ s7_pointer s7_gc_unprotect_via_stack(s7_scheme *sc, s7_pointer x) #define set_stack_protected3_with(Sc, Val, Op) stack_protected3(Sc) = Val #endif -#define gc_protect_via_stack(Sc, Obj) push_stack_no_let_no_code(Sc, OP_GC_PROTECT, Obj) -#define gc_protect_2_via_stack(Sc, X, Y) do {push_stack_no_let_no_code(Sc, OP_GC_PROTECT, X); stack_protected2(Sc) = Y;} while (0) /* often X and Y are fx_calls, so push X, then set Y */ -/* #define gc_protect_3_via_stack(Sc, X, Y, Z) do {push_stack_no_let_no_code(Sc, OP_GC_PROTECT, X); stack_protected2(Sc) = Y; stack_protected3(sc) = Z;} while (0) */ +#define gc_protect_via_stack(Sc, Obj) push_stack_no_code(Sc, OP_GC_PROTECT, Obj) +#define gc_protect_via_stack_no_let(Sc, Obj) push_stack_no_let_no_code(Sc, OP_GC_PROTECT, Obj) +#define gc_protect_2_via_stack(Sc, X, Y) do {gc_protect_via_stack(Sc, X); set_stack_protected2(Sc, Y);} while (0) /* often X and Y are fx_calls, so push X, then set Y */ +#define gc_protect_2_via_stack_no_let(Sc, X, Y) do {push_stack_no_let_no_code(Sc, OP_GC_PROTECT, X); set_stack_protected2(Sc, Y);} while (0) /* -------------------------------- symbols -------------------------------- */ @@ -9369,12 +9347,6 @@ static void slot_set_value_with_hook_1(s7_scheme *sc, s7_pointer slot, s7_pointe (value != slot_value(slot))) s7_call(sc, sc->rootlet_redefinition_hook, set_plist_2(sc, symbol, value)); slot_set_value(slot, value); - - if ((S7_DEBUGGING) && (is_pair(value)) && (car(value) == slot_symbol(slot)) && (symbol == make_symbol(sc, "x", 1))) - { - fprintf(stderr, "x set to (x...), estr: %s\n", display(s7_name_to_value(sc, "estr"))); - if (sc->stop_at_error) abort(); - } } static void remove_function_from_heap(s7_scheme *sc, s7_pointer value); /* calls remove_let_from_heap */ @@ -9419,9 +9391,6 @@ static void remove_function_from_heap(s7_scheme *sc, s7_pointer value) s7_pointer s7_make_slot(s7_scheme *sc, s7_pointer let, s7_pointer symbol, s7_pointer value) { - /* if ((S7_DEBUGGING) && (!is_let(let))) {fprintf(stderr, "s7_make_slot let: %s\n", display(let)); abort();} */ - /* () as let if shadow_rootlet used but unset!?! */ - if ((!is_let(let)) || (let == sc->rootlet)) { @@ -9950,7 +9919,7 @@ static s7_pointer g_sublet_curlet(s7_scheme *sc, s7_pointer args) return(new_e); } -static s7_pointer sublet_chooser(s7_scheme *sc, s7_pointer f, int32_t num_args, s7_pointer expr, bool ops) +static s7_pointer sublet_chooser(s7_scheme *sc, s7_pointer f, int32_t num_args, s7_pointer expr) { if (num_args == 3) { @@ -10037,7 +10006,6 @@ static s7_pointer internal_inlet(s7_scheme *sc, s7_int num_args, ...) { s7_pointer symbol = va_arg(ap, s7_pointer); s7_pointer value = va_arg(ap, s7_pointer); - if ((S7_DEBUGGING) && (is_keyword(symbol))) fprintf(stderr, "internal_inlet key: %s??\n", display(symbol)); if (!sp) { add_slot_unchecked(sc, new_e, symbol, value, id); @@ -10057,9 +10025,8 @@ static bool is_proper_quote(s7_scheme *sc, s7_pointer p) (is_null(cddr(p)))); } -static s7_pointer inlet_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool ops) +static s7_pointer inlet_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr) { - if (!ops) return(f); if ((args > 0) && ((args % 2) == 0)) { @@ -10287,7 +10254,7 @@ static inline s7_pointer g_simple_let_ref(s7_scheme *sc, s7_pointer args) if (!is_let(lt)) wrong_type_error_nr(sc, sc->let_ref_symbol, 1, lt, a_let_string); if (lt == sc->rootlet) - return((is_slot(global_slot(sym))) ? global_value(sym) : sc->undefined); + return((is_slot(global_slot(sym))) ? global_value(sym) : sc->undefined); if (let_id(lt) == symbol_id(sym)) return(local_value(sym)); for (s7_pointer y = let_slots(lt); tis_slot(y); y = next_slot(y)) @@ -10296,9 +10263,8 @@ static inline s7_pointer g_simple_let_ref(s7_scheme *sc, s7_pointer args) return(let_ref_p_pp(sc, let_outlet(lt), sym)); } -static s7_pointer let_ref_chooser(s7_scheme *sc, s7_pointer f, int32_t unused_args, s7_pointer expr, bool ops) +static s7_pointer let_ref_chooser(s7_scheme *sc, s7_pointer f, int32_t unused_args, s7_pointer expr) { - if (!ops) /* || (!is_global(sc->let_ref_symbol))) */ return(f); if (optimize_op(expr) == HOP_SAFE_C_opSq_C) { s7_pointer arg1 = cadr(expr), arg2 = caddr(expr); @@ -10362,7 +10328,7 @@ static s7_pointer let_set_1(s7_scheme *sc, s7_pointer let, s7_pointer symbol, s7 if (is_syntax(slot_value(slot))) wrong_type_error_nr(sc, sc->let_set_symbol, 2, symbol, wrap_string(sc, "a non-syntactic symbol", 22)); if (is_immutable(slot)) - immutable_object_error_nr(sc, set_elist_4(sc, wrap_string(sc, "~S is immutable in (let-set! (rootlet) '~S ~S)", 46), + immutable_object_error_nr(sc, set_elist_4(sc, wrap_string(sc, "~S is immutable in (let-set! (rootlet) '~S ~S)", 46), symbol, symbol, value)); /* also (set! (with-let...)...) */ symbol_increment_ctr(symbol); slot_set_value(slot, (slot_has_setter(slot)) ? call_setter(sc, slot, value) : value); @@ -10393,7 +10359,7 @@ static s7_pointer let_set_1(s7_scheme *sc, s7_pointer let, s7_pointer symbol, s7 return(call_let_set_fallback(sc, let, symbol, value)); } -static s7_pointer let_set(s7_scheme *sc, s7_pointer let, s7_pointer symbol, s7_pointer value) +static s7_pointer let_set_2(s7_scheme *sc, s7_pointer let, s7_pointer symbol, s7_pointer value) { if (!is_let(let)) wrong_type_error_nr(sc, sc->let_set_symbol, 1, let, a_let_string); @@ -10407,7 +10373,7 @@ static s7_pointer let_set(s7_scheme *sc, s7_pointer let, s7_pointer symbol, s7_p return(let_set_1(sc, let, symbol, value)); } -s7_pointer s7_let_set(s7_scheme *sc, s7_pointer let, s7_pointer symbol, s7_pointer value) {return(let_set(sc, let, symbol, value));} +s7_pointer s7_let_set(s7_scheme *sc, s7_pointer let, s7_pointer symbol, s7_pointer value) {return(let_set_2(sc, let, symbol, value));} static s7_pointer g_let_set(s7_scheme *sc, s7_pointer args) { @@ -10419,7 +10385,7 @@ static s7_pointer g_let_set(s7_scheme *sc, s7_pointer args) error_nr(sc, sc->wrong_number_of_args_symbol, set_elist_3(sc, wrap_string(sc, "~S: not enough arguments: ~S", 28), sc->let_set_symbol, sc->code)); - return(let_set(sc, car(args), cadr(args), caddr(args))); + return(let_set_2(sc, car(args), cadr(args), caddr(args))); } static s7_pointer let_set_p_ppp_2(s7_scheme *sc, s7_pointer p1, s7_pointer p2, s7_pointer p3) @@ -10454,9 +10420,8 @@ static s7_pointer g_simple_let_set(s7_scheme *sc, s7_pointer args) return(slot_value(y)); } -static s7_pointer let_set_chooser(s7_scheme *sc, s7_pointer f, int32_t unused_args, s7_pointer expr, bool ops) +static s7_pointer let_set_chooser(s7_scheme *sc, s7_pointer f, int32_t unused_args, s7_pointer expr) { - if (!ops) /* || (!is_global(sc->let_set_symbol))) */ return(f); if (optimize_op(expr) == HOP_SAFE_C_opSq_CS) { s7_pointer arg1 = cadr(expr), arg2 = caddr(expr), arg3 = cadddr(expr); @@ -10997,7 +10962,8 @@ static s7_pointer cur_op_to_caller(s7_scheme *sc, opcode_t op) case OP_BACRO: return(sc->bacro_symbol); case OP_BACRO_STAR: return(sc->bacro_star_symbol); } - return(sc->define_macro_symbol); + if (S7_DEBUGGING) fprintf(stderr, "%s[%d]: %s?\n", __func__, __LINE__, op_names[op]); + return(NULL); } static s7_pointer make_macro(s7_scheme *sc, opcode_t op, bool named) @@ -11364,9 +11330,8 @@ static s7_pointer g_is_defined_in_rootlet(s7_scheme *sc, s7_pointer args) /* aim return(make_boolean(sc, (is_keyword(sym)) || (is_slot(global_slot(sym))))); } -static s7_pointer is_defined_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool ops) +static s7_pointer is_defined_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr) { - if (!ops) return(f); if ((args == 2) && (is_normal_symbol(cadr(expr)))) /* i.e. not a keyword */ { s7_pointer e = caddr(expr); @@ -14848,7 +14813,7 @@ static void init_ctables(void) exponent_table[(uint8_t)'l'] = true; exponent_table[(uint8_t)'L'] = true; #endif for (int32_t i = 0; i < 32; i++) slashify_table[i] = true; - for (int32_t i = 127; i < 160; i++) slashify_table[i] = true; + /* for (int32_t i = 127; i < 160; i++) slashify_table[i] = true; */ /* 6-Apr-24 for utf-8, but this has no effect on s7test?? */ slashify_table[(uint8_t)'\\'] = true; slashify_table[(uint8_t)'"'] = true; slashify_table[(uint8_t)'\n'] = false; @@ -17073,7 +17038,7 @@ static s7_pointer g_log(s7_scheme *sc, s7_pointer args) return(make_complex_not_0i(sc, log(-s7_real(x)), M_PI)); } -static s7_pointer log_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool ops) +static s7_pointer log_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr) { #if (!WITH_GMP) if (args == 2) @@ -19931,11 +19896,10 @@ static s7_pointer chooser_check_arg_types(s7_scheme *sc, s7_pointer arg1, s7_poi static s7_pointer g_random_i(s7_scheme *sc, s7_pointer args); -static s7_pointer add_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool ops) +static s7_pointer add_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr) { /* (+ s f) (+ (* s s) s) (+ s s) (+ s (* s s)) */ if (args != 2) return((args == 3) ? sc->add_3 : f); - if (ops) { s7_pointer arg1 = cadr(expr), arg2 = caddr(expr); if (arg2 == int_one) /* (+ ... 1) */ @@ -20571,17 +20535,16 @@ static s7_pointer g_sub_xi(s7_scheme *sc, s7_pointer x, s7_int y) return(x); } -static s7_pointer subtract_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool ops) +static s7_pointer subtract_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr) { + s7_pointer arg1, arg2; if (args == 1) return(sc->subtract_1); if (args != 2) return((args == 3) ? sc->subtract_3 : f); - if (ops) - { - s7_pointer arg1 = cadr(expr), arg2 = caddr(expr); - if (arg2 == int_one) return(sc->subtract_x1); - if (is_t_real(arg1)) return(sc->subtract_f2); - if (is_t_real(arg2)) return(sc->subtract_2f); - } + arg1 = cadr(expr); + arg2 = caddr(expr); + if (arg2 == int_one) return(sc->subtract_x1); + if (is_t_real(arg1)) return(sc->subtract_f2); + if (is_t_real(arg2)) return(sc->subtract_2f); return(sc->subtract_2); } @@ -21189,14 +21152,12 @@ static s7_double multiply_d_ddd(s7_double x1, s7_double x2, s7_double x3) {retur static s7_double multiply_d_dddd(s7_double x1, s7_double x2, s7_double x3, s7_double x4) {return(x1 * x2 * x3 * x4);} static s7_pointer mul_p_dd(s7_scheme *sc, s7_double x1, s7_double x2) {return(make_real(sc, x1 * x2));} -static s7_pointer multiply_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool ops) +static s7_pointer multiply_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr) { if (args != 2) return(f); - if (ops) - return(chooser_check_arg_types(sc, cadr(expr), caddr(expr), sc->multiply_2, - sc->mul_2_ff, sc->mul_2_ii, sc->mul_2_if, sc->mul_2_fi, - sc->mul_2_xi, sc->mul_2_ix, sc->mul_2_fx, sc->mul_2_xf)); - return(sc->multiply_2); + return(chooser_check_arg_types(sc, cadr(expr), caddr(expr), sc->multiply_2, + sc->mul_2_ff, sc->mul_2_ii, sc->mul_2_if, sc->mul_2_fi, + sc->mul_2_xi, sc->mul_2_ix, sc->mul_2_fx, sc->mul_2_xf)); } @@ -21963,11 +21924,11 @@ static s7_double divide_d_7dd(s7_scheme *sc, s7_double x1, s7_double x2) static s7_pointer divide_p_ii(s7_scheme *sc, s7_int x, s7_int y) {return(make_ratio_with_div_check(sc, sc->divide_symbol, x, y));} static s7_pointer divide_p_i(s7_scheme *sc, s7_int x) {return(make_ratio_with_div_check(sc, sc->divide_symbol, 1, x));} -static s7_pointer divide_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool ops) +static s7_pointer divide_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr) { if (args == 1) return(sc->invert_1); - if ((ops) && (args == 2)) + if (args == 2) { s7_pointer arg1 = cadr(expr); if ((is_t_real(arg1)) && (real(arg1) == 1.0)) @@ -22875,7 +22836,7 @@ static s7_pointer g_max(s7_scheme *sc, s7_pointer args) static s7_pointer g_max_2(s7_scheme *sc, s7_pointer args) {return(max_p_pp(sc, car(args), cadr(args)));} static s7_pointer g_max_3(s7_scheme *sc, s7_pointer args) {return(max_p_pp(sc, max_p_pp(sc, car(args), cadr(args)), caddr(args)));} -static s7_pointer max_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer unused_expr, bool unused_ops) +static s7_pointer max_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer unused_expr) { return((args == 2) ? sc->max_2 : ((args == 3) ? sc->max_3 : f)); } @@ -23071,7 +23032,7 @@ static s7_pointer g_min(s7_scheme *sc, s7_pointer args) static s7_pointer g_min_2(s7_scheme *sc, s7_pointer args) {return(min_p_pp(sc, car(args), cadr(args)));} static s7_pointer g_min_3(s7_scheme *sc, s7_pointer args) {return(min_p_pp(sc, min_p_pp(sc, car(args), cadr(args)), caddr(args)));} -static s7_pointer min_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer unused_expr, bool unused_ops) +static s7_pointer min_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer unused_expr) { return((args == 2) ? sc->min_2 : ((args == 3) ? sc->min_3 : f)); } @@ -23411,12 +23372,12 @@ static inline s7_pointer num_eq_xx(s7_scheme *sc, s7_pointer x, s7_pointer y) static s7_pointer g_num_eq_xi(s7_scheme *sc, s7_pointer args) {return(num_eq_xx(sc, car(args), cadr(args)));} static s7_pointer g_num_eq_ix(s7_scheme *sc, s7_pointer args) {return(num_eq_xx(sc, cadr(args), car(args)));} -static s7_pointer num_eq_chooser(s7_scheme *sc, s7_pointer ur_f, int32_t args, s7_pointer expr, bool ops) +static s7_pointer num_eq_chooser(s7_scheme *sc, s7_pointer ur_f, int32_t args, s7_pointer expr) { if (args != 2) return(ur_f); - if ((ops) && (is_t_integer(caddr(expr)))) + if (is_t_integer(caddr(expr))) return(sc->num_eq_xi); - return(((ops) && (is_t_integer(cadr(expr)))) ? sc->num_eq_ix : sc->num_eq_2); + return((is_t_integer(cadr(expr))) ? sc->num_eq_ix : sc->num_eq_2); } @@ -23696,24 +23657,20 @@ static bool lt_b_pi(s7_scheme *sc, s7_pointer p1, s7_int p2) static s7_pointer g_less_2(s7_scheme *sc, s7_pointer args) {return(lt_p_pp(sc, car(args), cadr(args)));} static s7_pointer lt_p_pi(s7_scheme *sc, s7_pointer p1, s7_int p2) {return(make_boolean(sc, lt_b_pi(sc, p1, p2)));} -static s7_pointer less_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool ops) +static s7_pointer less_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr) { + s7_pointer arg2; if (args != 2) return(f); - if (ops) + arg2 = caddr(expr); + if (is_t_integer(arg2)) { - s7_pointer arg2 = caddr(expr); - if (is_t_integer(arg2)) - { - if (integer(arg2) == 0) - return(sc->less_x0); - - if ((integer(arg2) < S7_INT32_MAX) && - (integer(arg2) > S7_INT32_MIN)) - return(sc->less_xi); - } - if (is_t_real(arg2)) - return(sc->less_xf); + if (integer(arg2) == 0) + return(sc->less_x0); + if ((integer(arg2) < S7_INT32_MAX) && (integer(arg2) > S7_INT32_MIN)) + return(sc->less_xi); } + if (is_t_real(arg2)) + return(sc->less_xf); return(sc->less_2); } @@ -23975,18 +23932,14 @@ static s7_pointer g_leq_ixx(s7_scheme *sc, s7_pointer args) return(g_less_or_equal(sc, args)); } -static s7_pointer leq_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool ops) +static s7_pointer leq_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr) { + s7_pointer arg2; if (args == 2) { - if (ops) - { - s7_pointer arg2 = caddr(expr); - if ((is_t_integer(arg2)) && - (integer(arg2) < S7_INT32_MAX) && - (integer(arg2) > S7_INT32_MIN)) - return(sc->leq_xi); - } + arg2 = caddr(expr); + if ((is_t_integer(arg2)) && (integer(arg2) < S7_INT32_MAX) && (integer(arg2) > S7_INT32_MIN)) + return(sc->leq_xi); return(sc->leq_2); } if ((args == 3) && (is_t_integer(cadr(expr)))) @@ -24293,21 +24246,15 @@ static s7_pointer g_greater_2(s7_scheme *sc, s7_pointer args) return(sc->T); } -static s7_pointer greater_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool ops) +static s7_pointer greater_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr) { + s7_pointer arg2; if (args != 2) return(f); - if (ops) - { - s7_pointer arg2 = caddr(expr); - if ((is_t_integer(arg2)) && - (integer(arg2) < S7_INT32_MAX) && - (integer(arg2) > S7_INT32_MIN)) - return(sc->greater_xi); - if ((is_t_real(arg2)) && - (real(arg2) < S7_INT32_MAX) && - (real(arg2) > S7_INT32_MIN)) - return(sc->greater_xf); - } + arg2 = caddr(expr); + if ((is_t_integer(arg2)) && (integer(arg2) < S7_INT32_MAX) && (integer(arg2) > S7_INT32_MIN)) + return(sc->greater_xi); + if ((is_t_real(arg2)) && (real(arg2) < S7_INT32_MAX) && (real(arg2) > S7_INT32_MIN)) + return(sc->greater_xf); return(sc->greater_2); } @@ -24544,21 +24491,15 @@ static bool geq_b_pi(s7_scheme *sc, s7_pointer p1, s7_int p2) static s7_pointer geq_p_pi(s7_scheme *sc, s7_pointer p1, s7_int p2) {return(make_boolean(sc, geq_b_pi(sc, p1, p2)));} -static s7_pointer geq_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool ops) +static s7_pointer geq_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr) { + s7_pointer arg2; if (args != 2) return(f); - if (ops) - { - s7_pointer arg2 = caddr(expr); - if ((is_t_integer(arg2)) && - (integer(arg2) < S7_INT32_MAX) && - (integer(arg2) > S7_INT32_MIN)) - return(sc->geq_xi); - if ((is_t_real(arg2)) && - (real(arg2) < S7_INT32_MAX) && - (real(arg2) > S7_INT32_MIN)) - return(sc->geq_xf); - } + arg2 = caddr(expr); + if ((is_t_integer(arg2)) && (integer(arg2) < S7_INT32_MAX) && (integer(arg2) > S7_INT32_MIN)) + return(sc->geq_xi); + if ((is_t_real(arg2)) && (real(arg2) < S7_INT32_MAX) && (real(arg2) > S7_INT32_MIN)) + return(sc->geq_xf); return(sc->geq_2); } @@ -26008,9 +25949,9 @@ static s7_pointer random_p_p(s7_scheme *sc, s7_pointer num) return(g_random(sc, set_plist_1(sc, num))); } -static s7_pointer random_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool ops) +static s7_pointer random_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr) { - if ((ops) && (args == 1)) + if (args == 1) { s7_pointer arg1 = cadr(expr); if (is_t_integer(arg1)) @@ -26492,10 +26433,9 @@ static s7_pointer g_char_greater_2(s7_scheme *sc, s7_pointer args) static bool returns_char(s7_scheme *sc, s7_pointer arg) {return(argument_type(sc, arg) == sc->is_char_symbol);} -static s7_pointer char_equal_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool ops) +static s7_pointer char_equal_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr) { if (args != 2) return(f); - if (ops) { s7_pointer arg1 = cadr(expr), arg2 = caddr(expr); if ((returns_char(sc, arg1)) && (returns_char(sc, arg2))) @@ -26504,12 +26444,12 @@ static s7_pointer char_equal_chooser(s7_scheme *sc, s7_pointer f, int32_t args, return(sc->char_equal_2); } -static s7_pointer char_less_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer unused_expr, bool unused_ops) +static s7_pointer char_less_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer unused_expr) { return((args == 2) ? sc->char_less_2 : f); } -static s7_pointer char_greater_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer unused_expr, bool unused_ops) +static s7_pointer char_greater_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer unused_expr) { return((args == 2) ? sc->char_greater_2 : f); } @@ -26729,9 +26669,8 @@ static s7_pointer g_char_position_csi(s7_scheme *sc, s7_pointer args) return((p) ? make_integer(sc, p - porig) : sc->F); } -static s7_pointer char_position_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool ops) +static s7_pointer char_position_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr) { - if (!ops) return(f); if ((is_character(cadr(expr))) && ((args == 2) || (args == 3))) return(sc->char_position_csi); return(f); @@ -27406,7 +27345,7 @@ static s7_pointer g_string_append_2(s7_scheme *sc, s7_pointer args) {return(stri static void check_for_substring_temp(s7_scheme *sc, s7_pointer expr); -static s7_pointer string_append_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool unused_ops) +static s7_pointer string_append_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr) { check_for_substring_temp(sc, expr); return((args == 2) ? sc->string_append_2 : f); @@ -27523,7 +27462,7 @@ static void check_for_substring_temp(s7_scheme *sc, s7_pointer expr) }} } -static s7_pointer string_substring_chooser(s7_scheme *sc, s7_pointer f, int32_t unused_args, s7_pointer expr, bool unused_ops) +static s7_pointer string_substring_chooser(s7_scheme *sc, s7_pointer f, int32_t unused_args, s7_pointer expr) { /* used by several string functions */ check_for_substring_temp(sc, expr); @@ -27580,7 +27519,7 @@ static s7_pointer g_string_copy(s7_scheme *sc, s7_pointer args) return(dest); } -static s7_pointer string_copy_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool unused_ops) +static s7_pointer string_copy_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr) { if (args == 1) check_for_substring_temp(sc, expr); return(f); @@ -27839,19 +27778,19 @@ static bool string_eq_b_7pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2) return(scheme_strings_are_equal(p1, p2)); } -static s7_pointer string_equal_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool unused_ops) +static s7_pointer string_equal_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr) { check_for_substring_temp(sc, expr); return((args == 2) ? ((is_string(caddr(expr))) ? sc->string_equal_2c : sc->string_equal_2) : f); } -static s7_pointer string_less_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool unused_ops) +static s7_pointer string_less_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr) { check_for_substring_temp(sc, expr); return((args == 2) ? sc->string_less_2 : f); } -static s7_pointer string_greater_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool unused_ops) +static s7_pointer string_greater_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr) { check_for_substring_temp(sc, expr); return((args == 2) ? sc->string_greater_2 : f); @@ -28064,8 +28003,6 @@ static s7_pointer g_string_1(s7_scheme *sc, s7_pointer args, s7_pointer sym) int32_t i, len; s7_pointer x, newstr; char *str; - /* if (is_null(args)) return(nil_string); */ - if ((S7_DEBUGGING) && (is_null(args))) fprintf(stderr, "g_string_1 got null?\n"); /* get length for new string and check arg types */ for (len = 0, x = args; is_not_null(x); len++, x = cdr(x)) @@ -28118,7 +28055,7 @@ static s7_pointer g_string_c1(s7_scheme *sc, s7_pointer args) return(str); } -static s7_pointer string_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool unused_ops) +static s7_pointer string_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr) { return(((args == 1) && (!is_pair(cadr(expr)))) ? sc->string_c1 : f); } @@ -29787,9 +29724,10 @@ static s7_pointer g_open_output_file(s7_scheme *sc, s7_pointer args) /* -------------------------------- open-input-string -------------------------------- */ - /* a version of string ports using a pointer to the current location and a pointer to the end - * (rather than an integer for both, indexing from the base string) was not faster. - */ + +/* a version of string ports using a pointer to the current location and a pointer to the end + * (rather than an integer for both, indexing from the base string) was not faster. + */ static const port_functions_t input_string_functions = {string_read_char, input_write_char, input_write_string, string_read_semicolon, terminated_string_read_white_space, @@ -29819,9 +29757,9 @@ static s7_pointer open_input_string(s7_scheme *sc, const char *input_string, s7_ #if S7_DEBUGGING if ((len > 0) && (input_string[len] != '\0')) { - fprintf(stderr, "%s[%d]: read_white_space string is not terminated: len: %" ld64 ", at end: %c%c, str: %s", - __func__, __LINE__, len, input_string[len - 1], input_string[len], input_string); - abort(); + fprintf(stderr, "%s%s[%d]: input_string is not terminated: len: %" ld64 ", at end: %c%c, str: %s%s\n", + bold_text, __func__, __LINE__, len, input_string[len - 1], input_string[len], input_string, unbold_text); + if (sc->stop_at_error) abort(); } #endif port_port(x)->pf = &input_string_functions; @@ -29990,6 +29928,7 @@ static s7_pointer g_get_output_string_uncopied(s7_scheme *sc, s7_pointer args) return(method_or_bust_p(sc, p, sc->get_output_string_symbol, wrap_string(sc, "an output string port", 21))); } check_get_output_string_port(sc, p); + port_data(p)[port_position(p)] = '\0'; /* wrap_string can't do this, and (for example) open_input_string wants terminated strings */ return(wrap_string(sc, (const char *)port_data(p), port_position(p))); } @@ -30209,7 +30148,7 @@ static s7_pointer g_read_char_1(s7_scheme *sc, s7_pointer args) return(chars[port_read_character(port)(sc, port)]); } -static s7_pointer read_char_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer unused_expr, bool unused_ops) +static s7_pointer read_char_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer unused_expr) { return((args == 1) ? sc->read_char_1 : f); } @@ -33609,10 +33548,6 @@ static void simple_list_readable_display(s7_scheme *sc, s7_pointer lst, s7_int t } } -#if S7_DEBUGGING -static char *base = NULL, *min_char = NULL; -#endif - static void pair_to_port(s7_scheme *sc, s7_pointer lst, s7_pointer port, use_write_t use_write, shared_info_t *ci) { s7_pointer x; @@ -33620,22 +33555,6 @@ static void pair_to_port(s7_scheme *sc, s7_pointer lst, s7_pointer port, use_wri bool immutable = false; s7_int true_len = list_length_with_immutable_check(sc, lst, &immutable); -#if S7_DEBUGGING - char xx; - if (!base) base = &xx; - else - if (&xx > base) base = &xx; - else - if ((!min_char) || (&xx < min_char)) - { - min_char = &xx; - if ((base - min_char) > 1000000) - { - fprintf(stderr, "pair_to_port infinite recursion?\n"); - abort(); - }} -#endif - if (true_len < 0) /* a dotted list -- handle cars, then final cdr */ len = (-true_len + 1); else len = (true_len == 0) ? circular_list_entries(lst) : true_len; /* circular list (nil is handled by unique_to_port) */ @@ -33879,7 +33798,7 @@ static void pair_to_port(s7_scheme *sc, s7_pointer lst, s7_pointer port, use_wri else for (x = lst, i = 0; (is_pair(x)) && (i < len1); i++, x = cdr(x)) { - object_to_port(sc, car(x), port, NOT_P_DISPLAY(use_write), ci); + object_to_port(sc, car(x), port, NOT_P_DISPLAY(use_write), ci); /* lst free here if unprotected */ port_write_character(port)(sc, ' ', port); } if (is_pair(x)) @@ -34306,7 +34225,6 @@ static void internal_slot_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port static void let_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t use_write, shared_info_t *ci) { /* if outer env points to (say) method list, the object needs to specialize object->string itself */ - if (has_active_methods(sc, obj)) { s7_pointer print_func = find_method(sc, obj, sc->object_to_string_symbol); @@ -34710,7 +34628,7 @@ static void write_closure_readably(s7_scheme *sc, s7_pointer obj, s7_pointer por return; } if ((!ci) && (is_pair(arglist))) - { /* (format #f "~W" (make-hook (cons 'ho (list (values (list (let ((<1> (hash-table))) (set! (<1> 'a) <1>) <1>))))))) -- yow! */ + { /* (format #f "~W" (make-hook (let ((cp (list 1))) (set-cdr! cp cp) (list 'quote cp)))) */ shared_info_t *new_ci = make_shared_info(sc); clear_shared_info(new_ci); if (collect_shared_info(sc, new_ci, arglist, false)) @@ -35810,7 +35728,7 @@ static s7_pointer g_display_2(s7_scheme *sc, s7_pointer args) {return(display_p_ static s7_pointer g_display_f(s7_scheme *unused_sc, s7_pointer args) {return(car(args));} -static s7_pointer display_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool unused_ops) +static s7_pointer display_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr) { if (args == 2) /* not check_for_substring_temp(sc, expr) here -- display returns arg so can be immutable if substring_uncopied */ return((caddr(expr) == sc->F) ? sc->display_f : sc->display_2); @@ -36257,7 +36175,7 @@ static s7_pointer format_to_port_1(s7_scheme *sc, s7_pointer port, const char *s if (is_not_null(args)) error_nr(sc, sc->format_error_symbol, set_elist_2(sc, wrap_string(sc, "format control string is null, but there are arguments: ~S", 58), args)); - return((with_result) ? nil_string : sc->F); + return(nil_string); }} else str_len = len; @@ -36768,7 +36686,7 @@ static s7_pointer format_to_port_1(s7_scheme *sc, s7_pointer port, const char *s fdat->port = NULL; return(result); } - return(sc->F); + return(nil_string); } static bool is_columnizing(const char *str) /* look for ~t ~,<int>T ~<int>,<int>t */ @@ -36812,19 +36730,18 @@ spacing (and spacing character) and precision. ~{ starts an embedded format dir ~F: (format #f \"~F\" 100.1) -> \"100.100000\" (%f in C)\n\ ~G: (format #f \"~G\" 100.1) -> \"100.1\" (%g in C)\n\ \n\ -If the 'out' it is not an output port, the resultant string is returned. If it \ +If the 'out' argument is not an output port (i.e. #f, #t, or ()), the resultant string is returned. If it \ is #t, the string is also sent to the current-output-port." #define Q_format s7_make_circular_signature(sc, 2, 3, \ - s7_make_signature(sc, 2, sc->is_string_symbol, sc->not_symbol), \ - s7_make_signature(sc, 3, sc->is_output_port_symbol, sc->is_boolean_symbol, sc->is_null_symbol), sc->T) + sc->is_string_symbol, s7_make_signature(sc, 3, sc->is_output_port_symbol, sc->is_boolean_symbol, sc->is_null_symbol), sc->T) s7_pointer pt = car(args), str; if (is_null(pt)) { pt = current_output_port(sc); /* () -> (current-output-port) */ if (pt == sc->F) /* otherwise () -> #f so we get a returned string, which is confusing */ - return(pt); /* but this means some error checks are skipped? */ + return(nil_string); /* was #f 18-Mar-24 */ } sc->format_column = 0; if (!((is_boolean(pt)) || /* #f or #t */ @@ -36865,7 +36782,7 @@ static s7_pointer g_format_just_control_string(s7_scheme *sc, s7_pointer args) { pt = current_output_port(sc); if (pt == sc->F) - return(sc->F); + return(nil_string); } if (pt == sc->T) { @@ -36878,10 +36795,10 @@ static s7_pointer g_format_just_control_string(s7_scheme *sc, s7_pointer args) return(method_or_bust(sc, pt, sc->format_symbol, args, a_format_port_string, 1)); if (string_length(str) == 0) - return((is_output_port(pt)) ? sc->F : nil_string); + return(nil_string); port_write_string(pt)(sc, string_value(str), string_length(str), pt); - return(sc->F); + return(nil_string); } static s7_pointer g_format_as_objstr(s7_scheme *sc, s7_pointer args) @@ -36900,7 +36817,7 @@ static s7_pointer g_format_no_column(s7_scheme *sc, s7_pointer args) { pt = current_output_port(sc); if (pt == sc->F) - return(sc->F); + return(nil_string); } if (!((is_boolean(pt)) || ((is_output_port(pt)) && /* (current-output-port) or call-with-open-file arg, etc */ @@ -36916,7 +36833,7 @@ static s7_pointer g_format_no_column(s7_scheme *sc, s7_pointer args) string_length(str), str)); } -static s7_pointer format_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool ops) +static s7_pointer format_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr) { if (args > 1) { @@ -36924,7 +36841,7 @@ static s7_pointer format_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_p s7_pointer str_arg = caddr(expr); if (is_string(str_arg)) { - if ((ops) && ((args == 2) || (args == 3))) + if ((args == 2) || (args == 3)) { s7_int len; char *orig = string_value(str_arg); @@ -37525,7 +37442,7 @@ static s7_pointer g_tree_set_memq_syms(s7_scheme *sc, s7_pointer args) return(tree_set_memq_syms_direct(sc, car(args), cadr(args))); /* need other form for pp */ } -static s7_pointer tree_set_memq_chooser(s7_scheme *sc, s7_pointer f, int32_t unused_args, s7_pointer expr, bool unused_ops) +static s7_pointer tree_set_memq_chooser(s7_scheme *sc, s7_pointer f, int32_t unused_args, s7_pointer expr) { if ((is_proper_quote(sc, cadr(expr))) && /* not (tree-set-memq (quote) ...) */ (is_pair(cadadr(expr)))) /* (tree-set-memq '(...)...) */ @@ -37853,7 +37770,7 @@ static bool op_implicit_pair_ref_aa(s7_scheme *sc) return(true); } -static s7_pointer list_ref_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool unused_ops) +static s7_pointer list_ref_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr) { if (args == 2) { @@ -38022,7 +37939,7 @@ static s7_pointer g_list_set_i(s7_scheme *sc, s7_pointer args) return(val); } -static s7_pointer list_set_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool unused_ops) +static s7_pointer list_set_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr) { if ((args == 3) && (s7_is_integer(caddr(expr))) && @@ -38983,9 +38900,8 @@ static bool op_assoc_if(s7_scheme *sc) return(false); } -static s7_pointer assoc_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool ops) +static s7_pointer assoc_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr) { - if (!ops) return(f); if ((args == 3) && (is_normal_symbol(cadddr(expr)))) { if (cadddr(expr) == sc->is_eq_symbol) return(global_value(sc->assq_symbol)); @@ -39093,7 +39009,7 @@ static s7_pointer g_memq_any(s7_scheme *sc, s7_pointer args) return(sc->F); } -static s7_pointer memq_chooser(s7_scheme *sc, s7_pointer f, int32_t unused_args, s7_pointer expr, bool unused_ops) +static s7_pointer memq_chooser(s7_scheme *sc, s7_pointer f, int32_t unused_args, s7_pointer expr) { s7_pointer lst = caddr(expr); if ((is_proper_quote(sc, lst)) && @@ -39357,12 +39273,11 @@ static s7_pointer member_p_pp(s7_scheme *sc, s7_pointer obj, s7_pointer x) return(member(sc, obj, x)); } -static s7_pointer member_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool ops) +static s7_pointer member_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr) { - if (!ops) return(f); if ((args == 3) && (is_normal_symbol(cadddr(expr)))) { - if (cadddr(expr) == sc->is_eq_symbol) return(memq_chooser(sc, global_value(sc->memq_symbol), 2, expr, ops)); + if (cadddr(expr) == sc->is_eq_symbol) return(memq_chooser(sc, global_value(sc->memq_symbol), 2, expr)); if (cadddr(expr) == sc->is_eqv_symbol) return(global_value(sc->memv_symbol)); } return(f); @@ -39425,7 +39340,7 @@ static s7_pointer g_list_4(s7_scheme *sc, s7_pointer args) return(list_4(sc, car(args), cadr(args), car(p), cadr(p))); } -static s7_pointer list_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer unused_expr, bool unused_ops) +static s7_pointer list_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer unused_expr) { if (args == 0) return(sc->list_0); if (args == 1) return(sc->list_1); @@ -40549,7 +40464,7 @@ static s7_pointer g_vector_3(s7_scheme *sc, s7_pointer args) return(vec); } -static s7_pointer vector_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer unused_expr, bool unused_ops) +static s7_pointer vector_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer unused_expr) { if (args == 2) return(sc->vector_2); return((args == 3) ? sc->vector_3 : f); @@ -41121,7 +41036,7 @@ static s7_pointer g_vector_ref_3(s7_scheme *sc, s7_pointer args) return(g_vector_ref(sc, args)); } -static s7_pointer vector_ref_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer unused_expr, bool unused_ops) +static s7_pointer vector_ref_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer unused_expr) { if (args == 2) return(sc->vector_ref_2); @@ -41347,7 +41262,7 @@ static s7_pointer g_vector_set_4(s7_scheme *sc, s7_pointer args) return(val); } -static s7_pointer vector_set_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer unused_expr, bool unused_ops) +static s7_pointer vector_set_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer unused_expr) { if (args == 3) return(sc->vector_set_3); return((args == 4) ? sc->vector_set_4 : f); @@ -41455,13 +41370,13 @@ static s7_pointer g_make_vector_1(s7_scheme *sc, s7_pointer args, s7_pointer cal { if (typf == global_value(sc->is_float_symbol)) { - if (!is_real(fill)) wrong_type_error_nr(sc, caller, 3, fill, sc->type_names[T_REAL]); + if (!is_real(fill)) wrong_type_error_nr(sc, caller, 2, fill, sc->type_names[T_REAL]); result_type = T_FLOAT_VECTOR; } else if (typf == global_value(sc->is_integer_symbol)) { - if (!s7_is_integer(fill)) wrong_type_error_nr(sc, caller, 3, fill, sc->type_names[T_INTEGER]); + if (!s7_is_integer(fill)) wrong_type_error_nr(sc, caller, 2, fill, sc->type_names[T_INTEGER]); result_type = (WITH_GMP) ? T_VECTOR : T_INT_VECTOR; } else @@ -41480,7 +41395,7 @@ static s7_pointer g_make_vector_1(s7_scheme *sc, s7_pointer args, s7_pointer cal (s7_apply_function(sc, typf, set_plist_1(sc, fill)) == sc->F)) { const char *tstr = make_type_name(sc, (is_c_function(typf)) ? c_function_name(typf) : symbol_name(find_closure(sc, typf, closure_let(typf))), INDEFINITE_ARTICLE); - wrong_type_error_nr(sc, sc->make_vector_symbol, 3, fill, wrap_string(sc, tstr, safe_strlen(tstr))); + wrong_type_error_nr(sc, sc->make_vector_symbol, 2, fill, wrap_string(sc, tstr, safe_strlen(tstr))); } vec = make_vector_1(sc, len, NOT_FILLED, result_type); @@ -42283,7 +42198,7 @@ static s7_double float_vector_ref_d_7piii(s7_scheme *sc, s7_pointer v, s7_int i1 return(float_vector(v, i3 + (i2 * vector_offset(v, 1)) + (i1 * vector_offset(v, 0)))); } -static s7_pointer float_vector_ref_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer unused_expr, bool unused_ops) +static s7_pointer float_vector_ref_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer unused_expr) { return((args == 2) ? sc->fv_ref_2 : ((args == 3) ? sc->fv_ref_3 : f)); } @@ -42359,7 +42274,7 @@ static bool find_matching_ref(s7_scheme *sc, const s7_pointer getter, s7_pointer return(false); } -static s7_pointer float_vector_set_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool unused_ops) +static s7_pointer float_vector_set_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr) { if (args == 3) return((find_matching_ref(sc, sc->float_vector_ref_symbol, expr)) ? sc->fv_set_unchecked : sc->fv_set_3); @@ -42488,7 +42403,7 @@ static s7_pointer g_iv_ref_3(s7_scheme *sc, s7_pointer args) return(make_integer(sc, int_vector(iv, ind1))); } -static s7_pointer int_vector_ref_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer unused_expr, bool unused_ops) +static s7_pointer int_vector_ref_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer unused_expr) { return((args == 2) ? sc->iv_ref_2 : ((args == 3) ? sc->iv_ref_3 : f)); } @@ -42588,7 +42503,7 @@ static s7_pointer g_iv_set_3(s7_scheme *sc, s7_pointer args) return(value); } -static s7_pointer int_vector_set_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer unused_expr, bool unused_ops) +static s7_pointer int_vector_set_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer unused_expr) { return((args == 3) ? sc->iv_set_3 : f); } @@ -42664,7 +42579,7 @@ static s7_pointer g_bv_ref_3(s7_scheme *sc, s7_pointer args) return(small_int(byte_vector(iv, ind1))); } -static s7_pointer byte_vector_ref_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer unused_expr, bool unused_ops) +static s7_pointer byte_vector_ref_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer unused_expr) { return((args == 2) ? sc->bv_ref_2 : ((args == 3) ? sc->bv_ref_3 : f)); } @@ -42738,7 +42653,7 @@ static s7_pointer g_bv_set_3(s7_scheme *sc, s7_pointer args) return(value); } -static s7_pointer byte_vector_set_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer unused_expr, bool unused_ops) +static s7_pointer byte_vector_set_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer unused_expr) { return((args == 3) ? sc->bv_set_3 : f); } @@ -45172,7 +45087,7 @@ static bool op_implicit_hash_table_ref_aa(s7_scheme *sc) return(true); } -static s7_pointer hash_table_ref_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool unused_ops) +static s7_pointer hash_table_ref_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr) { if (args == 2) { @@ -45420,7 +45335,7 @@ static s7_pointer hash_table_set_p_ppp(s7_scheme *sc, s7_pointer p1, s7_pointer return(s7_hash_table_set(sc, p1, p2, p3)); } -static s7_pointer hash_table_set_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool unused_ops) +static s7_pointer hash_table_set_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr) { if ((args == 3) && (optimize_op(expr) == HOP_SAFE_C_SSA)) { @@ -45523,7 +45438,7 @@ That is, (weak-hash-table 'a 1 'b 2) returns a new weak-hash-table with the two return(table); } -static s7_pointer hash_table_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer unused_expr, bool unused_ops) +static s7_pointer hash_table_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer unused_expr) { return((args == 2) ? sc->hash_table_2 : f); } @@ -45703,7 +45618,7 @@ static s7_pointer hash_table_reverse(s7_scheme *sc, s7_pointer old_hash) /* -------------------------------- functions -------------------------------- */ bool s7_is_function(s7_pointer p) {return(is_c_function(p));} -static s7_pointer fallback_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool ops) {return(f);} +static s7_pointer fallback_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr) {return(f);} static void s7_function_set_class(s7_scheme *sc, s7_pointer f, s7_pointer base_f) { @@ -46522,7 +46437,7 @@ static int32_t is_ok_thunk(s7_scheme *sc, s7_pointer arg) /* used only in dynami return(0); } -static s7_pointer dynamic_wind_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool unused_ops) +static s7_pointer dynamic_wind_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr) { if ((args == 3) && (is_ok_thunk(sc, caddr(expr)))) @@ -47639,7 +47554,7 @@ s7_pointer s7_hook_functions(s7_scheme *sc, s7_pointer hook) s7_pointer s7_hook_set_functions(s7_scheme *sc, s7_pointer hook, s7_pointer functions) { if (is_list(functions)) - let_set(sc, closure_let(hook), sc->body_symbol, functions); + let_set_2(sc, closure_let(hook), sc->body_symbol, functions); return(functions); } @@ -50662,7 +50577,7 @@ s7_pointer s7_append(s7_scheme *sc, s7_pointer a, s7_pointer b) static s7_pointer g_append_2(s7_scheme *sc, s7_pointer args) {return(s7_append(sc, car(args), cadr(args)));} -static s7_pointer append_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer unused_expr, bool unused_ops) +static s7_pointer append_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer unused_expr) { if (args == 2) return(sc->append_2); return(f); @@ -52464,7 +52379,7 @@ static bool catch_barrier_function(s7_scheme *sc, s7_int catch_loc, s7_pointer t static bool catch_error_hook_function(s7_scheme *sc, s7_int catch_loc, s7_pointer type, s7_pointer info, bool *reset_hook) { if (SHOW_EVAL_OPS) fprintf(stderr, "catcher: %s\n", __func__); - let_set(sc, closure_let(sc->error_hook), sc->body_symbol, stack_code(sc->stack, catch_loc)); + let_set_2(sc, closure_let(sc->error_hook), sc->body_symbol, stack_code(sc->stack, catch_loc)); /* apparently there was an error during *error-hook* evaluation, but Rick wants the hook re-established anyway */ (*reset_hook) = true; /* avoid infinite loop -- don't try to (re-)evaluate (buggy) *error-hook*! */ @@ -52497,8 +52412,8 @@ static bool catch_let_temporarily_function(s7_scheme *sc, s7_int catch_loc, s7_p { s7_pointer error_hook_funcs = s7_hook_functions(sc, sc->error_hook); - let_set(sc, closure_let(sc->error_hook), sc->body_symbol, sc->nil); - let_set(sc, closure_let(sc->let_temp_hook), sc->body_symbol, error_hook_funcs); + let_set_2(sc, closure_let(sc->error_hook), sc->body_symbol, sc->nil); + let_set_2(sc, closure_let(sc->let_temp_hook), sc->body_symbol, error_hook_funcs); sc->code = sc->let_temp_hook; sc->args = list_2(sc, type, info); @@ -52506,8 +52421,8 @@ static bool catch_let_temporarily_function(s7_scheme *sc, s7_int catch_loc, s7_p set_curlet(sc, make_let(sc, closure_let(sc->code))); eval(sc, OP_APPLY_LAMBDA); - let_set(sc, closure_let(sc->error_hook), sc->body_symbol, error_hook_funcs); - let_set(sc, closure_let(sc->let_temp_hook), sc->body_symbol, sc->nil); + let_set_2(sc, closure_let(sc->error_hook), sc->body_symbol, error_hook_funcs); + let_set_2(sc, closure_let(sc->let_temp_hook), sc->body_symbol, sc->nil); sc->args = stack_args(sc->stack, catch_loc); sc->code = stack_code(sc->stack, catch_loc); @@ -52762,8 +52677,8 @@ static noreturn void error_nr(s7_scheme *sc, s7_pointer type, s7_pointer info) { s7_pointer error_hook_funcs = s7_hook_functions(sc, sc->error_hook); /* (set! (hook-functions *error-hook*) (list (lambda (h) (format *stderr* "got error ~A~%" (h 'data))))) */ - let_set(sc, closure_let(sc->error_hook), sc->body_symbol, sc->nil); - let_set(sc, closure_let(sc->let_temp_hook), sc->body_symbol, error_hook_funcs); + let_set_2(sc, closure_let(sc->error_hook), sc->body_symbol, sc->nil); + let_set_2(sc, closure_let(sc->let_temp_hook), sc->body_symbol, error_hook_funcs); /* if the *error-hook* functions trigger an error, we had better not have hook_functions(*error-hook*) still set! */ /* here we have no catcher (anywhere!), we're headed back to the top-level(?), so error_hook_quit can call reset_stack? */ @@ -53175,8 +53090,8 @@ static noreturn void improper_arglist_error_nr(s7_scheme *sc) static void op_error_hook_quit(s7_scheme *sc) { - let_set(sc, closure_let(sc->error_hook), sc->body_symbol, sc->code); /* restore old value */ - let_set(sc, closure_let(sc->let_temp_hook), sc->body_symbol, sc->nil); + let_set_2(sc, closure_let(sc->error_hook), sc->body_symbol, sc->code); /* restore old value */ + let_set_2(sc, closure_let(sc->let_temp_hook), sc->body_symbol, sc->nil); /* now mimic the end of the normal error handler. Since this error hook evaluation can happen * in an arbitrary s7_call nesting, we can't just return from the current evaluation -- * we have to jump to the original (top-level) call. Otherwise '#<unspecified> or whatever @@ -53927,10 +53842,6 @@ static s7_pointer g_exit(s7_scheme *sc, s7_pointer args) /* calling s7_eval_c_string in an atexit function seems to be problematic -- it works, but args can be changed? */ s7_pointer obj; -#if WITH_ALLOC_COUNTERS - report_allocs(25); -#endif - /* r7rs.pdf says exit checks the stack for dynamic-winds and runs the "after" functions, if any -- * this strikes me as ridiculous -- surely they don't expect me to find all the stacks (other s7's running etc) * and search them for dynamic-winds? The exit must happen in either the init or body sections -- how can we @@ -55644,7 +55555,7 @@ static s7_pointer fx_href_s_vref(s7_scheme *sc, s7_pointer arg) return(hash_table_ref_p_pp(sc, lookup(sc, cadr(arg)), vector_ref_p_pp(sc, lookup(sc, car(opt3_pair(arg))), lookup(sc, opt2_sym(opt3_pair(arg)))))); } -static s7_pointer fx_lref_s_vref(s7_scheme *sc, s7_pointer arg) +static s7_pointer fx_lref_s_vref(s7_scheme *sc, s7_pointer arg) /* tbig */ { return(let_ref(sc, lookup(sc, cadr(arg)), vector_ref_p_pp(sc, lookup(sc, car(opt3_pair(arg))), lookup(sc, opt2_sym(opt3_pair(arg)))))); } @@ -56285,12 +56196,14 @@ static s7_pointer fx_not_a(s7_scheme *sc, s7_pointer arg) {return((fx_call( static s7_pointer fx_c_saa(s7_scheme *sc, s7_pointer arg) { + s7_pointer res; gc_protect_via_stack(sc, fx_call(sc, opt3_pair(arg))); /* opt3_pair=cddr */ set_car(sc->t3_3, fx_call(sc, cdr(opt3_pair(arg)))); set_car(sc->t3_1, lookup(sc, cadr(arg))); set_car(sc->t3_2, stack_protected1(sc)); + res = fn_proc(arg)(sc, sc->t3_1); unstack_gc_protect(sc); - return(fn_proc(arg)(sc, sc->t3_1)); + return(res); } #define fx_c_ssa_any(Name, Lookup1, Lookup2) \ @@ -56369,12 +56282,14 @@ static s7_pointer fx_c_cac(s7_scheme *sc, s7_pointer arg) static s7_pointer fx_c_aa(s7_scheme *sc, s7_pointer arg) { + s7_pointer res; /* check_stack_size(sc); */ gc_protect_2_via_stack(sc, fx_call(sc, cdr(arg)), fx_call(sc, opt3_pair(arg))); /* opt3_pair = cddr(arg) */ set_car(sc->t2_1, T_Ext(stack_protected1(sc))); set_car(sc->t2_2, stack_protected2(sc)); + res = fn_proc(arg)(sc, sc->t2_1); unstack_gc_protect(sc); - return(fn_proc(arg)(sc, sc->t2_1)); + return(res); } static s7_pointer fx_c_ca(s7_scheme *sc, s7_pointer arg) @@ -56437,14 +56352,6 @@ fx_c_sa_any(fx_c_sa, s_lookup) fx_c_sa_any(fx_c_ta, t_lookup) fx_c_sa_any(fx_c_ua, u_lookup) -static s7_pointer fx_c_za(s7_scheme *sc, s7_pointer arg) /* "z"=unsafe_s */ -{ - s7_pointer val = lookup_checked(sc, cadr(arg)); /* this can call an autoload function that steps on sc->t2_1 */ - set_car(sc->t2_2, fx_call(sc, opt3_pair(arg))); - set_car(sc->t2_1, val); - return(fn_proc(arg)(sc, sc->t2_1)); -} - #define fx_c_sa_direct_any(Name, Lookup) \ static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ { \ @@ -56537,13 +56444,15 @@ static s7_pointer fx_c_3g(s7_scheme *sc, s7_pointer arg) static s7_pointer fx_c_aaa(s7_scheme *sc, s7_pointer arg) { + s7_pointer res; /* check_stack_size(sc); */ gc_protect_2_via_stack(sc, fx_call(sc, cdr(arg)), fx_call(sc, opt3_pair(arg))); set_car(sc->t3_3, fx_call(sc, cdr(opt3_pair(arg)))); set_car(sc->t3_2, stack_protected2(sc)); set_car(sc->t3_1, stack_protected1(sc)); + res = fn_proc(arg)(sc, sc->t3_1); unstack_gc_protect(sc); - return(fn_proc(arg)(sc, sc->t3_1)); + return(res); } static s7_pointer fx_c_gac(s7_scheme *sc, s7_pointer arg) @@ -56577,13 +56486,16 @@ static s7_pointer fx_c_opaq(s7_scheme *sc, s7_pointer arg) static s7_pointer fx_c_opaaq(s7_scheme *sc, s7_pointer arg) { - s7_pointer p = cadr(arg); + s7_pointer p = cadr(arg), res; /* check_stack_size(sc); */ gc_protect_via_stack(sc, fx_call(sc, cdr(p))); set_car(sc->t2_2, fx_call(sc, cddr(p))); set_car(sc->t2_1, stack_protected1(sc)); + res = fn_proc(p)(sc, sc->t2_1); + set_stack_protected2(sc, res); /* might be a big list etc (see s7test.scm fx_c_opaaq test) */ + res = fn_proc(arg)(sc, with_list_t1(res)); unstack_gc_protect(sc); - return(fn_proc(arg)(sc, with_list_t1(fn_proc(p)(sc, sc->t2_1)))); + return(res); } static s7_pointer fx_c_opsaq(s7_scheme *sc, s7_pointer arg) @@ -56596,25 +56508,27 @@ static s7_pointer fx_c_opsaq(s7_scheme *sc, s7_pointer arg) static s7_pointer fx_c_opaaaq(s7_scheme *sc, s7_pointer code) { - s7_pointer arg = cadr(code); + s7_pointer arg = cadr(code), res; gc_protect_2_via_stack(sc, fx_call(sc, cdr(arg)), fx_call(sc, opt3_pair(arg))); /* cddr(arg) */ set_car(sc->t3_3, fx_call(sc, cdr(opt3_pair(arg)))); set_car(sc->t3_1, stack_protected1(sc)); set_car(sc->t3_2, stack_protected2(sc)); + res = fn_proc(code)(sc, with_list_t1(fn_proc(arg)(sc, sc->t3_1))); unstack_gc_protect(sc); - return(fn_proc(code)(sc, with_list_t1(fn_proc(arg)(sc, sc->t3_1)))); + return(res); } static s7_pointer fx_c_s_opaaq(s7_scheme *sc, s7_pointer code) { - s7_pointer arg = caddr(code); + s7_pointer arg = caddr(code), res; gc_protect_via_stack(sc, fx_call(sc, cdr(arg))); set_car(sc->t2_2, fx_call(sc, cddr(arg))); set_car(sc->t2_1, stack_protected1(sc)); set_car(sc->t2_2, fn_proc(arg)(sc, sc->t2_1)); set_car(sc->t2_1, lookup(sc, cadr(code))); + res = fn_proc(code)(sc, sc->t2_1); unstack_gc_protect(sc); - return(fn_proc(code)(sc, sc->t2_1)); + return(res); } static s7_pointer fx_c_4a(s7_scheme *sc, s7_pointer code) @@ -56628,8 +56542,8 @@ static s7_pointer fx_c_4a(s7_scheme *sc, s7_pointer code) set_car(sc->t3_2, stack_protected3(sc)); set_car(sc->t3_1, stack_protected2(sc)); set_car(sc->t4_1, stack_protected1(sc)); - unstack_gc_protect(sc); res = fn_proc(code)(sc, sc->t4_1); + unstack_gc_protect(sc); set_car(sc->t4_1, sc->F); return(res); } @@ -57206,17 +57120,6 @@ static bool is_fxable(s7_scheme *sc, s7_pointer p) return(is_proper_quote(sc, p)); } -static bool is_gxable(s7_pointer p) -{ - opcode_t op; - if (!is_optimized(p)) return(false); - op = optimize_op(p); - return((is_symbol(car(p))) && (symbol_ctr(car(p)) == 1) && - (op < FIRST_UNHOPPABLE_OP) && - (op > OP_GC_PROTECT) && - (fx_function[op | 1])); -} - static int32_t fx_count(s7_scheme *sc, s7_pointer x) { int32_t count = 0; @@ -57903,8 +57806,6 @@ static s7_function fx_choose(s7_scheme *sc, s7_pointer holder, s7_pointer cur_en if (fn_proc(arg) == g_multiply_2) return(fx_multiply_aa); if (fn_proc(arg) == g_number_to_string) return(fx_number_to_string_aa); if (fn_proc(arg) == g_cons) return(fx_cons_aa); - /* we can get here from gx_annotate which does not call fx_tree, where A=fx_unsafe_s */ - if (fx_proc(cdr(arg)) == fx_unsafe_s) return(fx_c_za); return(fx_c_aa); case HOP_SAFE_C_opAAq: @@ -59192,7 +59093,7 @@ static bool i_idp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer s7_i_i_t func = s7_i_i_function(s_func); s7_i_7i_t func7 = NULL; s7_i_7p_t ipf; - s7_pointer p; + s7_pointer p, arg1 = cadr(car_x); int32_t start = sc->pc; opc->v[3].o1 = sc->opts[start]; if (!func) @@ -59202,21 +59103,21 @@ static bool i_idp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer if (func) opc->v[2].i_i_f = func; else opc->v[2].i_7i_f = func7; - if (is_t_integer(cadr(car_x))) + if (is_t_integer(arg1)) { if (opc->v[2].i_i_f == subtract_i_i) { - opc->v[1].i = -integer(cadr(car_x)); + opc->v[1].i = -integer(arg1); opc->v[0].fi = opt_i_c; } else { - opc->v[1].i = integer(cadr(car_x)); + opc->v[1].i = integer(arg1); opc->v[0].fi = (func) ? opt_i_i_c : opt_i_7i_c; } return_true(sc, car_x); } - p = opt_integer_symbol(sc, cadr(car_x)); + p = opt_integer_symbol(sc, arg1); if (p) { opc->v[1].p = p; @@ -59231,19 +59132,19 @@ static bool i_idp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer } sc->pc = start; } - if (!is_t_ratio(cadr(car_x))) + if (!is_t_ratio(arg1)) { s7_i_7d_t idf = s7_i_7d_function(s_func); if (idf) { opc->v[2].i_7d_f = idf; - if (is_small_real(cadr(car_x))) + if (is_small_real(arg1)) { - opc->v[1].x = s7_number_to_real(sc, cadr(car_x)); + opc->v[1].x = s7_number_to_real(sc, arg1); opc->v[0].fi = opt_i_d_c; return_true(sc, car_x); } - p = opt_float_symbol(sc, cadr(car_x)); + p = opt_float_symbol(sc, arg1); if (p) { opc->v[1].p = p; @@ -60114,13 +60015,14 @@ static bool i_syntax_ok(s7_scheme *sc, s7_pointer car_x, int32_t len) if ((car(car_x) == sc->set_symbol) && (len == 3)) { + s7_pointer arg1 = cadr(car_x); opt_info *opc = alloc_opt_info(sc); - if (is_symbol(cadr(car_x))) /* (set! i 3) */ + if (is_symbol(arg1)) /* (set! i 3) */ { s7_pointer settee; - if (is_immutable(cadr(car_x))) + if (is_immutable(arg1)) return_false(sc, car_x); - settee = s7_slot(sc, cadr(car_x)); + settee = s7_slot(sc, arg1); if ((is_slot(settee)) && (is_t_integer(slot_value(settee))) && (!is_immutable_slot(settee)) && @@ -60143,14 +60045,14 @@ static bool i_syntax_ok(s7_scheme *sc, s7_pointer car_x, int32_t len) return_true(sc, car_x); }}} else - if ((is_pair(cadr(car_x))) && /* if is_pair(settee) get setter */ - (is_symbol(caadr(car_x))) && - (is_pair(cdadr(car_x)))) + if ((is_pair(arg1)) && /* if is_pair(settee) get setter */ + (is_symbol(car(arg1))) && + (is_pair(cdr(arg1)))) { - if (is_null(cddadr(car_x))) - return(opt_int_vector_set(sc, -1, opc, caadr(car_x), cdadr(car_x), NULL, cddr(car_x))); - if (is_null(cdddr(cadr(car_x)))) - return(opt_int_vector_set(sc, -1, opc, caadr(car_x), cdadr(car_x), cddadr(car_x), cddr(car_x))); + if (is_null(cddr(arg1))) + return(opt_int_vector_set(sc, -1, opc, car(arg1), cdr(arg1), NULL, cddr(car_x))); + if (is_null(cdddr(arg1))) + return(opt_int_vector_set(sc, -1, opc, car(arg1), cdr(arg1), cddr(arg1), cddr(car_x))); }} return_false(sc, car_x); } @@ -60296,21 +60198,21 @@ static bool d_d_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer c if (!func) func7 = s7_d_7d_function(s_func); if ((func) || (func7)) { - s7_pointer p; + s7_pointer p, arg1 = cadr(car_x); if (func) opc->v[3].d_d_f = func; else opc->v[3].d_7d_f = func7; - if (is_small_real(cadr(car_x))) + if (is_small_real(arg1)) { - if ((!is_t_real(cadr(car_x))) && /* (random 1) != (random 1.0) */ + if ((!is_t_real(arg1)) && /* (random 1) != (random 1.0) */ ((car(car_x) == sc->random_symbol) || (car(car_x) == sc->sin_symbol) || (car(car_x) == sc->cos_symbol))) return_false(sc, car_x); - opc->v[1].x = s7_number_to_real(sc, cadr(car_x)); + opc->v[1].x = s7_number_to_real(sc, arg1); opc->v[0].fd = (func) ? opt_d_d_c : opt_d_7d_c; return_true(sc, car_x); } - p = opt_float_symbol(sc, cadr(car_x)); + p = opt_float_symbol(sc, arg1); if ((p) && (!has_methods(slot_value(p)))) { @@ -60743,19 +60645,20 @@ static bool d_id_ok_1(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointe p = opt_integer_symbol(sc, cadr(car_x)); if (p) { + s7_pointer arg2 = caddr(car_x); opc->v[1].p = p; - if (is_t_real(caddr(car_x))) + if (is_t_real(arg2)) { opc->v[0].fd = opt_d_id_sc; - opc->v[2].x = real(caddr(car_x)); + opc->v[2].x = real(arg2); return_true(sc, car_x); } - if ((cadr(car_x) == caddr(car_x)) && (flt_func == multiply_d_id)) + if ((cadr(car_x) == arg2) && (flt_func == multiply_d_id)) { opc->v[0].fd = opt_d_i2_mul; return_true(sc, car_x); } - p = opt_float_symbol(sc, caddr(car_x)); + p = opt_float_symbol(sc, arg2); if (p) { opc->v[0].fd = opt_d_id_ss; @@ -62345,13 +62248,14 @@ static bool d_syntax_ok(s7_scheme *sc, s7_pointer car_x, int32_t len) if ((len == 3) && (car(car_x) == sc->set_symbol)) { + s7_pointer arg1 = cadr(car_x); opt_info *opc = alloc_opt_info(sc); - if (is_symbol(cadr(car_x))) + if (is_symbol(arg1)) { s7_pointer settee; - if (is_immutable(cadr(car_x))) + if (is_immutable(arg1)) return_false(sc, car_x); - settee = s7_slot(sc, cadr(car_x)); + settee = s7_slot(sc, arg1); if ((is_slot(settee)) && (is_t_real(slot_value(settee))) && (!is_immutable_slot(settee)) && @@ -62378,14 +62282,14 @@ static bool d_syntax_ok(s7_scheme *sc, s7_pointer car_x, int32_t len) return_true(sc, car_x); }}} else /* if is_pair(settee) get setter */ - if ((is_pair(cadr(car_x))) && - (is_symbol(caadr(car_x))) && - (is_pair(cdadr(car_x)))) + if ((is_pair(arg1)) && + (is_symbol(car(arg1))) && + (is_pair(cdr(arg1)))) { - if (is_null(cddadr(car_x))) - return(opt_float_vector_set(sc, opc, caadr(car_x), cdadr(car_x), NULL, NULL, cddr(car_x))); - if (is_null(cdddr(cadr(car_x)))) - return(opt_float_vector_set(sc, opc, caadr(car_x), cdadr(car_x), cddadr(car_x), NULL, cddr(car_x))); + if (is_null(cddr(arg1))) + return(opt_float_vector_set(sc, opc, car(arg1), cdr(arg1), NULL, NULL, cddr(car_x))); + if (is_null(cdddr(arg1))) + return(opt_float_vector_set(sc, opc, car(arg1), cdr(arg1), cddr(arg1), NULL, cddr(car_x))); }} return_false(sc, car_x); } @@ -62678,7 +62582,8 @@ static s7_pointer opt_arg_type(s7_scheme *sc, s7_pointer argp) } sc->pc = start; } - if (((car(arg) == sc->vector_ref_symbol) || (car(arg) == sc->hash_table_ref_symbol)) && + + if (((car(arg) == sc->vector_ref_symbol) || (car(arg) == sc->hash_table_ref_symbol)) && (is_pair(cdr(arg))) && (is_normal_symbol(cadr(arg)))) /* (vector-ref) -> is_pair check */ { s7_pointer v_slot = s7_slot(sc, cadr(arg)); /* (vector-ref not-a-var ...) -> is_slot check, not #<undefined> */ @@ -62687,14 +62592,10 @@ static s7_pointer opt_arg_type(s7_scheme *sc, s7_pointer argp) s7_pointer v = slot_value(v_slot); if (car(arg) == sc->vector_ref_symbol) { - if (is_int_vector(v)) - return(sc->is_integer_symbol); - if (is_float_vector(v)) - return(sc->is_float_symbol); - if (is_byte_vector(v)) - return(sc->is_byte_symbol); - if (is_typed_t_vector(v)) - return(typed_vector_typer_symbol(sc, v)); /* includes closure name ?? */ + if (is_int_vector(v)) return(sc->is_integer_symbol); + if (is_float_vector(v)) return(sc->is_float_symbol); + if (is_byte_vector(v)) return(sc->is_byte_symbol); + if (is_typed_t_vector(v)) return(typed_vector_typer_symbol(sc, v)); /* includes closure name ?? */ } else if ((is_hash_table(v)) && (is_typed_hash_table(v)) && (is_c_function(hash_table_value_typer(v)))) @@ -63325,7 +63226,7 @@ static bool opt_cell_not_pair(s7_scheme *sc, s7_pointer car_x) #define is_opt_safe(P) ((optimize_op(P) >= OP_SAFE_C_S) && (!is_unknown_op(optimize_op(P)))) #define cf_call(Sc, Car_x, S_func, Num) \ - (((is_optimized(Car_x)) && (is_opt_safe(Car_x))) ? fn_proc(Car_x) : c_function_call(c_function_chooser(S_func)(Sc, S_func, Num, Car_x, false))) + (((is_optimized(Car_x)) && (is_opt_safe(Car_x))) ? fn_proc(Car_x) : c_function_call(c_function_chooser(S_func)(Sc, S_func, Num, Car_x))) /* was ops=false 19-Mar-24 */ static s7_pointer opt_p_f(opt_info *o) {return(o->v[1].p_f(o->sc));} static s7_pointer opt_p_call(opt_info *o) {return(o->v[1].call(o->sc, o->sc->nil));} @@ -63401,11 +63302,12 @@ static bool p_p_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer c { s7_p_p_t ppf; int32_t start = sc->pc; - if (is_t_integer(cadr(car_x))) + s7_pointer arg1 = cadr(car_x); + if (is_t_integer(arg1)) { s7_i_i_t iif = s7_i_i_function(s_func); s7_i_7i_t i7if; - opc->v[1].i = integer(cadr(car_x)); + opc->v[1].i = integer(arg1); if (iif) { opc->v[2].i_i_f = iif; @@ -63419,11 +63321,11 @@ static bool p_p_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer c opc->v[0].fp = opt_p_7i_c; return_true(sc, car_x); }} - if (is_t_real(cadr(car_x))) + if (is_t_real(arg1)) { s7_d_d_t ddf = s7_d_d_function(s_func); s7_d_7d_t d7df; - opc->v[1].x = real(cadr(car_x)); + opc->v[1].x = real(arg1); if (ddf) { opc->v[2].d_d_f = ddf; @@ -63447,25 +63349,25 @@ static bool p_p_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer c (fn_proc(car_x) == g_symbol_to_string_uncopied)) opc->v[2].p_p_f = symbol_to_string_uncopied_p; - if (is_symbol(cadr(car_x))) + if (is_symbol(arg1)) { - opc->v[1].p = opt_simple_symbol(sc, cadr(car_x)); + opc->v[1].p = opt_simple_symbol(sc, arg1); if (!opc->v[1].p) return_false(sc, car_x); opc->v[0].fp = (ppf == abs_p_p) ? opt_p_p_s_abs : ((ppf == cdr_p_p) ? opt_p_p_s_cdr : ((ppf == iterate_p_p) ? ((is_iterator(slot_value(opc->v[1].p))) ? opt_p_p_s_iterate_unchecked : opt_p_p_s_iterate) : opt_p_p_s)); return_true(sc, car_x); } - if (!is_pair(cadr(car_x))) + if (!is_pair(arg1)) { if (opc->v[2].p_p_f == s7_length) { - opc->v[1].p = s7_length(sc, cadr(car_x)); + opc->v[1].p = s7_length(sc, arg1); opc->v[0].fp = opt_p_c; } else { - opc->v[1].p = cadr(car_x); + opc->v[1].p = arg1; opc->v[0].fp = opt_p_p_c; } return_true(sc, car_x); @@ -63500,9 +63402,9 @@ static bool p_p_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer c if ((is_safe_procedure(s_func)) && (c_function_is_aritable(s_func, 1))) { opc->v[2].call = cf_call(sc, car_x, s_func, 1); - if (is_symbol(cadr(car_x))) + if (is_symbol(arg1)) { - s7_pointer slot = opt_simple_symbol(sc, cadr(car_x)); + s7_pointer slot = opt_simple_symbol(sc, arg1); if (slot) { opc->v[1].p = slot; @@ -63512,9 +63414,9 @@ static bool p_p_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer c else { opt_info *o1; - if (!is_pair(cadr(car_x))) + if (!is_pair(arg1)) { - opc->v[1].p = cadr(car_x); + opc->v[1].p = arg1; opc->v[0].fp = opt_p_call_c; return_true(sc, car_x); } @@ -63861,6 +63763,7 @@ static bool p_pi_fc_combinable(s7_scheme *sc, opt_info *opc) /* -------- p_pp -------- */ static s7_pointer opt_p_pp_ss(opt_info *o) {return(o->v[3].p_pp_f(o->sc, slot_value(o->v[1].p), slot_value(o->v[2].p)));} static s7_pointer opt_p_pp_sc(opt_info *o) {return(o->v[3].p_pp_f(o->sc, slot_value(o->v[1].p), o->v[2].p));} +static s7_pointer opt_p_pp_slot_ref(opt_info *o) {return(slot_value(o->v[2].p));} static s7_pointer opt_p_pp_cs(opt_info *o) {return(o->v[3].p_pp_f(o->sc, o->v[2].p, slot_value(o->v[1].p)));} static s7_pointer opt_p_pp_sf(opt_info *o) {return(o->v[3].p_pp_f(o->sc, slot_value(o->v[1].p), o->v[5].fp(o->v[4].o1)));} static s7_pointer opt_p_pp_fs(opt_info *o) {return(o->v[3].p_pp_f(o->sc, o->v[5].fp(o->v[4].o1), slot_value(o->v[1].p)));} @@ -63880,7 +63783,7 @@ static s7_pointer opt_p_pp_fs_cons(opt_info *o) {return(cons(o->sc, o->v[5].fp(o static s7_pointer opt_p_pp_fs_add(opt_info *o) {return(add_p_pp(o->sc, o->v[5].fp(o->v[4].o1), slot_value(o->v[1].p)));} static s7_pointer opt_p_pp_fs_sub(opt_info *o) {return(subtract_p_pp(o->sc, o->v[5].fp(o->v[4].o1), slot_value(o->v[1].p)));} -static s7_pointer opt_p_pp_ss_lref(opt_info *o) +static s7_pointer opt_p_pp_ss_lref(opt_info *o) { s7_pointer sym = slot_value(o->v[2].p); if (is_symbol(sym)) @@ -63888,7 +63791,7 @@ static s7_pointer opt_p_pp_ss_lref(opt_info *o) return(let_ref(o->sc, slot_value(o->v[1].p), sym)); } -static s7_pointer opt_p_pp_sf_lref(opt_info *o) +static s7_pointer opt_p_pp_sf_lref(opt_info *o) { s7_pointer sym = o->v[5].fp(o->v[4].o1); if (is_symbol(sym)) @@ -63900,7 +63803,7 @@ static s7_pointer opt_p_pp_ff(opt_info *o) { s7_scheme *sc = o->sc; s7_pointer result; - gc_protect_2_via_stack(sc, o->v[11].fp(o->v[10].o1), o->v[9].fp(o->v[8].o1)); /* we do need to protect both */ + gc_protect_2_via_stack_no_let(sc, o->v[11].fp(o->v[10].o1), o->v[9].fp(o->v[8].o1)); /* we do need to protect both */ result = o->v[3].p_pp_f(sc, stack_protected1(sc), stack_protected2(sc)); unstack_gc_protect(sc); return(result); @@ -63920,11 +63823,11 @@ static s7_pointer opt_p_pp_ff_add_mul_mul_1(opt_info *o, bool add_case) /* (+|- f4 = o2->v[5].fp(o2->v[4].o1); if (is_t_real(f4)) return(make_real(sc, (add_case) ? ((real(s1) * r2) + (real(s3) * real(f4))) : ((real(s1) * r2) - (real(s3) * real(f4))))); - gc_protect_via_stack(sc, f2); + gc_protect_via_stack_no_let(sc, f2); } else { - gc_protect_via_stack(sc, f2); + gc_protect_via_stack_no_let(sc, f2); f4 = o2->v[5].fp(o2->v[4].o1); } set_stack_protected2(sc, f4); @@ -63946,18 +63849,30 @@ static void check_opc_vector_wraps(opt_info *opc) if (opc->v[11].fp == opt_p_pi_ss_fvref_direct) opc->v[11].fp = opt_p_pi_ss_fvref_direct_wrapped; } +static void use_slot_ref(s7_scheme *sc, opt_info *opc, s7_pointer let, s7_pointer symbol) +{ + s7_pointer slot = symbol_to_local_slot(sc, symbol, let); + if (is_slot(slot)) + { + opc->v[2].p = slot; + opc->v[0].fp = opt_p_pp_slot_ref; + } +} + static bool p_pp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x, int32_t pstart) { - s7_pointer slot; + s7_pointer slot, arg1, arg2; s7_p_pp_t func = s7_p_pp_function(s_func); if (!func) return_false(sc, car_x); opc->v[3].p_pp_f = func; - if (is_symbol(cadr(car_x))) + arg1 = cadr(car_x); + arg2 = caddr(car_x); + if (is_symbol(arg1)) { s7_pointer obj; - slot = opt_simple_symbol(sc, cadr(car_x)); + slot = opt_simple_symbol(sc, arg1); if (!slot) { sc->pc = pstart; @@ -63974,49 +63889,56 @@ static bool p_pp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer if ((func == hash_table_ref_p_pp) && (is_hash_table(obj))) opc->v[3].p_pp_f = s7_hash_table_ref; - if (is_symbol(caddr(car_x))) + if (is_symbol(arg2)) { - opc->v[2].p = opt_simple_symbol(sc, caddr(car_x)); + opc->v[2].p = opt_simple_symbol(sc, arg2); if (opc->v[2].p) { - opc->v[0].fp = (func == set_car_p_pp) ? opt_set_car_pp_ss : + opc->v[0].fp = (func == set_car_p_pp) ? opt_set_car_pp_ss : (((is_hash_table(obj)) && (func == hash_table_ref_p_pp)) ? opt_p_pp_ss_href : (((is_let(obj)) && (func == let_ref)) ? opt_p_pp_ss_lref : opt_p_pp_ss)); + + /* if ss = s+k use slot_ref */ + if ((opc->v[0].fp == opt_p_pp_ss_lref) && (is_keyword(arg2))) + use_slot_ref(sc, opc, obj, keyword_symbol(arg2)); + return_true(sc, car_x); } sc->pc = pstart; return_false(sc, car_x); } - if ((!is_pair(caddr(car_x))) || - (is_proper_quote(sc, caddr(car_x)))) + if ((!is_pair(arg2)) || + (is_proper_quote(sc, arg2))) { - opc->v[2].p = (!is_pair(caddr(car_x))) ? caddr(car_x) : cadaddr(car_x); + opc->v[2].p = (!is_pair(arg2)) ? arg2 : cadr(arg2); opc->v[0].fp = opt_p_pp_sc; + if ((is_pair(arg2)) && (is_symbol(opc->v[2].p)) && (is_let(obj)) && (opc->v[3].p_pp_f == let_ref)) + use_slot_ref(sc, opc, obj, cadr(arg2)); /* car_x: (let-ref L 'a), can't be keyword here (handled above) */ return_true(sc, car_x); } if (cell_optimize(sc, cddr(car_x))) { opc->v[0].fp = (func == add_p_pp) ? opt_p_pp_sf_add : ((func == subtract_p_pp) ? opt_p_pp_sf_sub : ((func == multiply_p_pp) ? opt_p_pp_sf_mul : ((func == set_car_p_pp) ? opt_p_pp_sf_set_car : ((func == set_cdr_p_pp) ? opt_p_pp_sf_set_cdr : - (((is_hash_table(obj)) && (opc->v[3].p_pp_f == s7_hash_table_ref)) ? opt_p_pp_sf_href : + (((is_hash_table(obj)) && (opc->v[3].p_pp_f == s7_hash_table_ref)) ? opt_p_pp_sf_href : (((is_let(obj)) && (opc->v[3].p_pp_f == let_ref)) ? opt_p_pp_sf_lref : opt_p_pp_sf)))))); opc->v[4].o1 = sc->opts[pstart]; opc->v[5].fp = sc->opts[pstart]->v[0].fp; if (opc->v[5].fp == opt_p_pi_ss_ivref_direct) opc->v[5].fp = opt_p_pi_ss_ivref_direct_wrapped; return_true(sc, car_x); }} - else + else /* cadr not a symbol */ { opt_info *o1 = sc->opts[sc->pc]; - if ((!is_pair(cadr(car_x))) || - (is_proper_quote(sc, cadr(car_x)))) + if ((!is_pair(arg1)) || + (is_proper_quote(sc, arg1))) { - opc->v[1].p = (!is_pair(cadr(car_x))) ? cadr(car_x) : cadadr(car_x); - if ((!is_symbol(caddr(car_x))) && - ((!is_pair(caddr(car_x))) || - (is_proper_quote(sc, caddr(car_x))))) + opc->v[1].p = (!is_pair(arg1)) ? arg1 : cadr(arg1); + if ((!is_symbol(arg2)) && + ((!is_pair(arg2)) || + (is_proper_quote(sc, arg2)))) { - opc->v[2].p = (!is_pair(caddr(car_x))) ? caddr(car_x) : cadaddr(car_x); + opc->v[2].p = (!is_pair(arg2)) ? arg2 : cadr(arg2); if ((opc->v[3].p_pp_f == make_list_p_pp) && (is_t_integer(opc->v[1].p)) && (integer(opc->v[1].p) >= 0) && (integer(opc->v[1].p) < sc->max_list_length)) { @@ -64026,10 +63948,10 @@ static bool p_pp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer else opc->v[0].fp = opt_p_pp_cc; return_true(sc, car_x); } - if (is_symbol(caddr(car_x))) + if (is_symbol(arg2)) { opc->v[2].p = opc->v[1].p; - opc->v[1].p = opt_simple_symbol(sc, caddr(car_x)); + opc->v[1].p = opt_simple_symbol(sc, arg2); if (opc->v[1].p) { opc->v[0].fp = opt_p_pp_cs; @@ -64053,9 +63975,9 @@ static bool p_pp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer }} if (cell_optimize(sc, cdr(car_x))) { - if (is_symbol(caddr(car_x))) + if (is_symbol(arg2)) { - opc->v[1].p = opt_simple_symbol(sc, caddr(car_x)); + opc->v[1].p = opt_simple_symbol(sc, arg2); if (opc->v[1].p) { opc->v[0].fp = (func == add_p_pp) ? opt_p_pp_fs_add : ((func == subtract_p_pp) ? opt_p_pp_fs_sub : @@ -64067,15 +63989,15 @@ static bool p_pp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer sc->pc = pstart; return_false(sc, car_x); } - if ((!is_pair(caddr(car_x))) || - (is_proper_quote(sc, caddr(car_x)))) + if ((!is_pair(arg2)) || + (is_proper_quote(sc, arg2))) { - if (is_t_integer(caddr(car_x))) + if (is_t_integer(arg2)) { s7_p_pi_t ifunc = s7_p_pi_function(s_func); if (ifunc) { - opc->v[2].i = integer(caddr(car_x)); + opc->v[2].i = integer(arg2); opc->v[3].p_pi_f = ifunc; if (!p_pi_fc_combinable(sc, opc)) { @@ -64085,7 +64007,7 @@ static bool p_pp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer } return_true(sc, car_x); }} - opc->v[2].p = (!is_pair(caddr(car_x))) ? caddr(car_x) : cadaddr(car_x); + opc->v[2].p = (!is_pair(arg2)) ? arg2 : cadr(arg2); opc->v[0].fp = opt_p_pp_fc; opc->v[4].o1 = o1; opc->v[5].fp = o1->v[0].fp; @@ -64116,7 +64038,7 @@ static s7_pointer opt_p_call_ff(opt_info *o) { s7_pointer po2; s7_scheme *sc = o->sc; - gc_protect_via_stack(sc, o->v[11].fp(o->v[10].o1)); + gc_protect_via_stack_no_let(sc, o->v[11].fp(o->v[10].o1)); po2 = o->v[9].fp(o->v[8].o1); po2 = o->v[3].call(sc, set_plist_2(sc, stack_protected1(sc), po2)); unstack_gc_protect(sc); @@ -64135,6 +64057,13 @@ static s7_pointer opt_p_call_sf(opt_info *o) return(o->v[3].call(o->sc, set_plist_2(o->sc, slot_value(o->v[1].p), po1))); } +static s7_pointer opt_p_call_fc(opt_info *o) +{ + s7_pointer po1 = o->v[11].fp(o->v[10].o1); + return(o->v[3].call(o->sc, set_plist_2(o->sc, po1, o->v[2].p))); +} + +static s7_pointer opt_p_call_cc(opt_info *o) {return(o->v[3].call(o->sc, set_plist_2(o->sc, o->v[1].p, o->v[2].p)));} static s7_pointer opt_p_call_sc(opt_info *o) {return(o->v[3].call(o->sc, set_plist_2(o->sc, slot_value(o->v[1].p), o->v[2].p)));} static s7_pointer opt_p_call_ss(opt_info *o) {return(o->v[3].call(o->sc, set_plist_2(o->sc, slot_value(o->v[1].p), slot_value(o->v[2].p))));} @@ -64142,19 +64071,25 @@ static bool p_call_pp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_poi { if ((is_safe_procedure(s_func)) && (c_function_is_aritable(s_func, 2))) { - /* if optimized, we want to use the current fn_proc (to take advantage of fixups like substring_temp), - * but those same fixups are incorrect for this context if op_safe_c_c related. - */ + s7_pointer arg1 = cadr(car_x); + s7_pointer arg2 = caddr(car_x); opc->v[3].call = cf_call(sc, car_x, s_func, 2); - if (is_symbol(cadr(car_x))) + if ((is_code_constant(sc, arg1)) && (is_code_constant(sc, arg2))) { - opc->v[1].p = s7_slot(sc, cadr(car_x)); + opc->v[0].fp = opt_p_call_cc; + opc->v[1].p = (is_pair(arg1)) ? cadr(arg1) : arg1; + opc->v[2].p = (is_pair(arg2)) ? cadr(arg2) : arg2; + return_true(sc, car_x); + } + if (is_symbol(arg1)) + { + opc->v[1].p = s7_slot(sc, arg1); if ((is_slot(opc->v[1].p)) && (!has_methods(slot_value(opc->v[1].p)))) { - if (is_symbol(caddr(car_x))) + if (is_symbol(arg2)) { - opc->v[2].p = opt_simple_symbol(sc, caddr(car_x)); + opc->v[2].p = opt_simple_symbol(sc, arg2); if (opc->v[2].p) { opc->v[0].fp = opt_p_call_ss; @@ -64163,9 +64098,9 @@ static bool p_call_pp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_poi sc->pc = pstart; return_false(sc, car_x); } - if (!is_pair(caddr(car_x))) + if (!is_pair(arg2)) { - opc->v[2].p = caddr(car_x); + opc->v[2].p = arg2; opc->v[0].fp = opt_p_call_sc; return_true(sc, car_x); } @@ -64185,9 +64120,9 @@ static bool p_call_pp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_poi if (cell_optimize(sc, cdr(car_x))) { opc->v[11].fp = opc->v[10].o1->v[0].fp; - if (is_symbol(caddr(car_x))) + if (is_symbol(arg2)) { - opc->v[1].p = opt_simple_symbol(sc, caddr(car_x)); + opc->v[1].p = opt_simple_symbol(sc, arg2); if (opc->v[1].p) { opc->v[0].fp = opt_p_call_fs; @@ -64196,6 +64131,13 @@ static bool p_call_pp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_poi sc->pc = pstart; return_false(sc, car_x); } + if ((!is_pair(arg2)) || (is_proper_quote(sc, arg2))) /* (char-ci<? (null? i) (quote . let)) t101-43.scm */ + { + opc->v[0].fp = opt_p_call_fc; + opc->v[2].p = (is_pair(arg2)) ? cadr(arg2) : arg2; + check_opc_vector_wraps(opc); + return_true(sc, car_x); + } opc->v[8].o1 = sc->opts[sc->pc]; if (cell_optimize(sc, cddr(car_x))) { @@ -64282,7 +64224,7 @@ static bool p_pip_ssf_combinable(s7_scheme *sc, opt_info *opc, int32_t start) static bool p_pip_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x) { - s7_pointer obj, slot1, sig, checker = NULL, val_type; + s7_pointer obj, slot1, obj1, sig, checker = NULL, val_type; s7_p_pip_t func = s7_p_pip_function(s_func); if (!func) return_false(sc, car_x); @@ -64295,12 +64237,12 @@ static bool p_pip_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer /* here we know cadr is a symbol */ slot1 = s7_slot(sc, cadr(car_x)); - if ((!is_slot(slot1)) || - (has_methods(slot_value(slot1))) || - (is_immutable(slot_value(slot1)))) + if (!is_slot(slot1)) return_false(sc, car_x); - if ((is_any_vector(slot_value(slot1))) && - (vector_rank(slot_value(slot1)) > 1)) + obj1 = slot_value(slot1); + if ((has_methods(obj1)) || (is_immutable(obj1))) + return_false(sc, car_x); + if ((is_any_vector(obj1)) && (vector_rank(obj1) > 1)) return_false(sc, car_x); val_type = opt_arg_type(sc, cdddr(car_x)); @@ -64326,6 +64268,7 @@ static bool p_pip_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer if (is_symbol(caddr(car_x))) { int32_t start = sc->pc; + s7_pointer arg3 = cadddr(car_x); /* see val_type above */ s7_pointer slot2 = opt_integer_symbol(sc, caddr(car_x)); if (slot2) { @@ -64358,9 +64301,9 @@ static bool p_pip_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer break; } /* T_PAIR here would require list_length check which sort of defeats the purpose */ - if (is_symbol(cadddr(car_x))) + if (is_symbol(arg3)) { - s7_pointer val_slot = opt_simple_symbol(sc, cadddr(car_x)); + s7_pointer val_slot = opt_simple_symbol(sc, arg3); /* TODO: for int|byte|float-vector and string need opt_arg_type check?? see val_type above, if vector-set! but have int-vector sig is wrong */ if (val_slot) { @@ -64370,10 +64313,10 @@ static bool p_pip_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer return_true(sc, car_x); }} else - if ((!is_pair(cadddr(car_x))) || - (is_proper_quote(sc, cadddr(car_x)))) + if ((!is_pair(arg3)) || + (is_proper_quote(sc, arg3))) { - opc->v[4].p = (is_pair(cadddr(car_x))) ? cadr(cadddr(car_x)) : cadddr(car_x); + opc->v[4].p = (is_pair(arg3)) ? cadr(arg3) : arg3; opc->v[0].fp = opt_p_pip_ssc; return_true(sc, car_x); } @@ -64597,8 +64540,7 @@ static bool p_ppi_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer static s7_pointer opt_p_ppp_ssf(opt_info *o) {return(o->v[3].p_ppp_f(o->sc, slot_value(o->v[1].p), slot_value(o->v[2].p), o->v[5].fp(o->v[4].o1)));} static s7_pointer opt_p_ppp_hash_table_increment(opt_info *o) {return(fx_hash_table_increment_1(o->sc, slot_value(o->v[1].p), slot_value(o->v[2].p), o->v[5].p));} static s7_pointer opt_p_ppp_sfs(opt_info *o) {return(o->v[3].p_ppp_f(o->sc, slot_value(o->v[1].p), o->v[5].fp(o->v[4].o1), slot_value(o->v[2].p)));} -static s7_pointer opt_p_ppp_scs(opt_info *o) {return(o->v[3].p_ppp_f(o->sc, slot_value(o->v[1].p), o->v[4].p, slot_value(o->v[2].p)));} -static s7_pointer opt_p_ppp_scs_eset(opt_info *o) {return(let_set_1(o->sc, slot_value(o->v[1].p), o->v[4].p, slot_value(o->v[2].p)));} +static s7_pointer opt_p_ppp_scs(opt_info *o) {return(o->v[3].p_ppp_f(o->sc, slot_value(o->v[1].p), o->v[2].p, slot_value(o->v[4].p)));} static s7_pointer opt_p_ppp_sss(opt_info *o) {return(o->v[4].p_ppp_f(o->sc, slot_value(o->v[1].p), slot_value(o->v[2].p), slot_value(o->v[3].p)));} static s7_pointer opt_p_ppp_sss_mul(opt_info *o) {return(multiply_p_ppp(o->sc, slot_value(o->v[1].p), slot_value(o->v[2].p), slot_value(o->v[3].p)));} static s7_pointer opt_p_ppp_sss_hset(opt_info *o) {return(s7_hash_table_set(o->sc, slot_value(o->v[1].p), slot_value(o->v[2].p), slot_value(o->v[3].p)));} @@ -64609,7 +64551,7 @@ static s7_pointer opt_p_ppp_sff(opt_info *o) { s7_pointer res; s7_scheme *sc = o->sc; - gc_protect_2_via_stack(sc, T_Ext(o->v[11].fp(o->v[10].o1)), T_Ext(o->v[9].fp(o->v[8].o1))); + gc_protect_2_via_stack_no_let(sc, T_Ext(o->v[11].fp(o->v[10].o1)), T_Ext(o->v[9].fp(o->v[8].o1))); res = o->v[3].p_ppp_f(o->sc, slot_value(o->v[1].p), stack_protected1(sc), stack_protected2(sc)); unstack_gc_protect(sc); return(res); @@ -64619,12 +64561,54 @@ static s7_pointer opt_p_ppp_fff(opt_info *o) { s7_pointer res; s7_scheme *sc = o->sc; - gc_protect_2_via_stack(sc, T_Ext(o->v[11].fp(o->v[10].o1)), T_Ext(o->v[9].fp(o->v[8].o1))); + gc_protect_2_via_stack_no_let(sc, T_Ext(o->v[11].fp(o->v[10].o1)), T_Ext(o->v[9].fp(o->v[8].o1))); res = o->v[3].p_ppp_f(sc, stack_protected1(sc), stack_protected2(sc), o->v[5].fp(o->v[4].o1)); unstack_gc_protect(sc); return(res); } +static s7_pointer opt_p_ppc_slot_set(opt_info *o) {slot_set_value(o->v[2].p, o->v[4].p); return(o->v[4].p);} +static s7_pointer opt_p_pps_slot_set(opt_info *o) {slot_set_value(o->v[2].p, slot_value(o->v[4].p)); return(slot_value(o->v[4].p));} +static s7_pointer opt_p_ppf_slot_set(opt_info *o) {slot_set_value(o->v[2].p, o->v[5].fp(o->v[4].o1)); return(slot_value(o->v[2].p));} + +static bool use_ppc_slot_set(s7_scheme *sc, opt_info *opc, s7_pointer let, s7_pointer symbol, s7_pointer value) +{ + s7_pointer slot = symbol_to_local_slot(sc, symbol, let); + if ((is_slot(slot)) && (!is_immutable(slot))) + { + opc->v[2].p = slot; + opc->v[4].p = value; + opc->v[0].fp = opt_p_ppc_slot_set; + return(true); + } + return(false); +} + +static bool use_pps_slot_set(s7_scheme *sc, opt_info *opc, s7_pointer let, s7_pointer symbol, s7_pointer val_slot) +{ + s7_pointer slot = symbol_to_local_slot(sc, symbol, let); + if ((is_slot(slot)) && (!is_immutable(slot))) + { + opc->v[2].p = slot; + opc->v[4].p = val_slot; + opc->v[0].fp = opt_p_pps_slot_set; + return(true); + } + return(false); +} + +static bool use_ppf_slot_set(s7_scheme *sc, opt_info *opc, s7_pointer let, s7_pointer symbol) +{ + s7_pointer slot = symbol_to_local_slot(sc, symbol, let); + if ((is_slot(slot)) && (!is_immutable(slot))) + { + opc->v[2].p = slot; + opc->v[0].fp = opt_p_ppf_slot_set; + return(true); + } + return(false); +} + static bool p_ppp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x) { s7_pointer arg1 = cadr(car_x); @@ -64635,7 +64619,7 @@ static bool p_ppp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer if (!func) return_false(sc, car_x); opc->v[3].p_ppp_f = func; - if (is_symbol(arg1)) /* dealt with at the top -> p1 */ + if (is_symbol(arg1)) { s7_pointer obj; opt_info *o1; @@ -64666,10 +64650,17 @@ static bool p_ppp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer if (is_symbol(arg2)) { + if ((is_keyword(arg2)) && (is_symbol(arg3)) && (is_let(obj)) && (opc->v[3].p_ppp_f == let_set_2)) + { + s7_pointer val_slot = opt_simple_symbol(sc, arg3); + if ((val_slot) && (use_pps_slot_set(sc, opc, obj, keyword_symbol(arg2), val_slot))) + return_true(sc, car_x); + } slot = opt_simple_symbol(sc, arg2); if (slot) { opc->v[2].p = slot; + arg2 = slot_value(slot); if (is_symbol(arg3)) { slot = opt_simple_symbol(sc, arg3); @@ -64687,6 +64678,8 @@ static bool p_ppp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer { opc->v[4].p = (is_pair(arg3)) ? cadr(arg3) : arg3; opc->v[0].fp = opt_p_ppp_ssc; + if ((is_let(obj)) && (opc->v[3].p_ppp_f == let_set_2) && (is_symbol(arg2))) /* (let-set! L3 :x 0) */ + use_ppc_slot_set(sc, opc, obj, (is_keyword(arg2)) ? keyword_symbol(arg2) : arg2, opc->v[4].p); return_true(sc, car_x); } if (optimize_op(car_x) == HOP_HASH_TABLE_INCREMENT) @@ -64700,6 +64693,8 @@ static bool p_ppp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer opc->v[4].o1 = sc->opts[start]; opc->v[5].fp = opc->v[4].o1->v[0].fp; opc->v[0].fp = opt_p_ppp_ssf; + if ((is_let(obj)) && (is_symbol_and_keyword(arg2)) && (opc->v[3].p_ppp_f == let_set_2)) /* (let-set! L3 :x (+ (L3 'x) 1)) */ + use_ppf_slot_set(sc, opc, obj, keyword_symbol(arg2)); return_true(sc, car_x); } sc->pc = start; @@ -64710,15 +64705,11 @@ static bool p_ppp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer s7_pointer val_slot = opt_simple_symbol(sc, arg3); if (val_slot) { - opc->v[4].p = cadr(arg2); - opc->v[2].p = val_slot; + opc->v[2].p = cadr(arg2); + opc->v[4].p = val_slot; opc->v[0].fp = opt_p_ppp_scs; - if (opc->v[3].p_ppp_f == let_set) - { - if (is_symbol(cadr(arg2))) /* checked is_let, has_methods and is_immutable above */ - opc->v[0].fp = opt_p_ppp_scs_eset; - else return_false(sc, car_x); - } + if ((is_let(obj)) && (opc->v[3].p_ppp_f == let_set_2) && (is_symbol(cadr(arg2)))) + use_pps_slot_set(sc, opc, obj, cadr(arg2), val_slot); return_true(sc, car_x); }} o1 = sc->opts[sc->pc]; @@ -64736,8 +64727,20 @@ static bool p_ppp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer opc->v[5].fp = o1->v[0].fp; return_true(sc, car_x); }} + if ((!is_pair(arg3)) && (is_let(obj)) && (is_quoted_symbol(arg2)) && + (opc->v[3].p_ppp_f == let_set_2) && /* (let-set! L3 'x 0) */ + (use_ppc_slot_set(sc, opc, obj, cadr(arg2), arg3))) + return_true(sc, car_x); + if (cell_optimize(sc, cdddr(car_x))) { + if ((is_let(obj)) && (is_quoted_symbol(arg2)) && (opc->v[3].p_ppp_f == let_set_2) && /* (let-set! L3 'x (+ (L3 'x) 1)) */ + (use_ppf_slot_set(sc, opc, obj, cadr(arg2)))) + { + opc->v[4].o1 = o2; + opc->v[5].fp = opc->v[4].o1->v[0].fp; + return_true(sc, car_x); + } opc->v[0].fp = opt_p_ppp_sff; opc->v[10].o1 = o1; opc->v[11].fp = o1->v[0].fp; @@ -64745,7 +64748,7 @@ static bool p_ppp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer opc->v[9].fp = o2->v[0].fp; return_true(sc, car_x); }}} - else + else /* arg1 not symbol */ { opc->v[10].o1 = sc->opts[start]; if (cell_optimize(sc, cdr(car_x))) @@ -64774,12 +64777,18 @@ static bool p_ppp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer return_false(sc, car_x); } + /* -------- p_call_ppp -------- */ static s7_pointer opt_p_call_sss(opt_info *o) { return(o->v[4].call(o->sc, set_plist_3(o->sc, slot_value(o->v[1].p), slot_value(o->v[2].p), slot_value(o->v[3].p)))); } +static s7_pointer opt_p_call_ccs(opt_info *o) +{ + return(o->v[4].call(o->sc, set_plist_3(o->sc, o->v[1].p, o->v[2].p, slot_value(o->v[3].p)))); +} + static s7_pointer opt_p_call_css(opt_info *o) { return(o->v[4].call(o->sc, set_plist_3(o->sc, o->v[1].p, slot_value(o->v[2].p), slot_value(o->v[3].p)))); @@ -64794,7 +64803,7 @@ static s7_pointer opt_p_call_ppp(opt_info *o) { s7_pointer res; s7_scheme *sc = o->sc; - gc_protect_2_via_stack(sc, o->v[4].fp(o->v[3].o1), o->v[6].fp(o->v[5].o1)); + gc_protect_2_via_stack_no_let(sc, o->v[4].fp(o->v[3].o1), o->v[6].fp(o->v[5].o1)); res = o->v[11].fp(o->v[10].o1); /* not combinable into next */ res = o->v[2].call(sc, set_plist_3(sc, stack_protected1(sc), stack_protected2(sc), res)); unstack_gc_protect(sc); @@ -64807,14 +64816,14 @@ static bool p_call_ppp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_po if ((is_safe_procedure(s_func)) && (c_function_is_aritable(s_func, 3)) && (s_func != global_value(sc->hash_table_ref_symbol)) && (s_func != global_value(sc->list_ref_symbol))) { - s7_pointer slot, arg = cadr(car_x); + s7_pointer slot, arg1 = cadr(car_x), arg2 = caddr(car_x), arg3 = cadddr(car_x); opt_info *o1 = sc->opts[sc->pc]; - if (!is_pair(arg)) + if (!is_pair(arg1)) { - if (is_symbol(arg)) + if (is_normal_symbol(arg1)) { - slot = opt_simple_symbol(sc, arg); + slot = opt_simple_symbol(sc, arg1); if (slot) { opc->v[1].p = slot; @@ -64826,21 +64835,31 @@ static bool p_call_ppp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_po } else { - opc->v[1].p = arg; + if ((is_code_constant(sc, arg1)) && (is_code_constant(sc, arg2)) && (is_normal_symbol(arg3))) + { + s7_pointer val_slot = opt_simple_symbol(sc, arg3); + if (val_slot) + { + opc->v[1].p = (is_pair(arg1)) ? cadr(arg1) : arg1; + opc->v[2].p = (is_pair(arg2)) ? cadr(arg2) : arg2; + opc->v[3].p = val_slot; + opc->v[4].call = cf_call(sc, car_x, s_func, 3); + opc->v[0].fp = opt_p_call_ccs; + return_true(sc, car_x); + }} + opc->v[1].p = arg1; if (s_func == global_value(sc->vector_ref_symbol)) return_false(sc, car_x); } - arg = caddr(car_x); - if (is_symbol(arg)) + if (is_normal_symbol(arg2)) { - slot = opt_simple_symbol(sc, arg); + slot = opt_simple_symbol(sc, arg2); if (slot) { opc->v[2].p = slot; - arg = cadddr(car_x); - if (is_symbol(arg)) + if (is_normal_symbol(arg3)) { - slot = opt_simple_symbol(sc, arg); + slot = opt_simple_symbol(sc, arg3); if (slot) { opc->v[3].p = slot; @@ -64904,7 +64923,7 @@ static s7_pointer opt_p_call_any(opt_info *o) s7_scheme *sc = o->sc; s7_pointer val = safe_list_if_possible(sc, o->v[1].i); s7_pointer arg = val; - if (in_heap(val)) gc_protect_via_stack(sc, val); + if (in_heap(val)) gc_protect_via_stack_no_let(sc, val); for (s7_int i = 0; i < o->v[1].i; i++, arg = cdr(arg)) { opt_info *o1 = o->v[i + P_CALL_O1].o1; @@ -64961,6 +64980,7 @@ static bool p_fx_any_ok(s7_scheme *sc, opt_info *opc, s7_pointer x) static bool p_implicit_ok(s7_scheme *sc, s7_pointer s_slot, s7_pointer car_x, int32_t len) { s7_pointer obj = slot_value(s_slot); + s7_pointer arg1 = (len > 1) ? cadr(car_x) : sc->F; opt_info *opc; int32_t start; @@ -64998,9 +65018,9 @@ static bool p_implicit_ok(s7_scheme *sc, s7_pointer s_slot, s7_pointer car_x, in return_false(sc, car_x); } /* now v3.p_pi|pp.f is set */ - if (is_symbol(cadr(car_x))) + if (is_symbol(arg1)) { - s7_pointer slot = s7_slot(sc, cadr(car_x)); + s7_pointer slot = s7_slot(sc, arg1); /* not the desired slot if let+keyword, see below */ if (is_slot(slot)) { opc->v[2].p = slot; @@ -65017,18 +65037,19 @@ static bool p_implicit_ok(s7_scheme *sc, s7_pointer s_slot, s7_pointer car_x, in } opc->v[0].fp = ((is_hash_table(obj)) && (opc->v[3].p_pp_f == s7_hash_table_ref)) ? opt_p_pp_ss_href : (((is_let(obj)) && (opc->v[3].p_pp_f == let_ref)) ? opt_p_pp_ss_lref : opt_p_pp_ss); - /* if (opc->v[0].fp != opt_p_pp_ss) abort(); */ + if ((opc->v[0].fp == opt_p_pp_ss_lref) && (is_keyword(arg1))) + use_slot_ref(sc, opc, obj, keyword_symbol(arg1)); /* if keyword, slot is: (L3 :x) -> #<slot: :x :x> */ return_true(sc, car_x); }} - else + else /* arg1 not a symbol */ { if ((!is_hash_table(obj)) && (!is_let(obj))) { opt_info *o1; - if (is_t_integer(cadr(car_x))) + if (is_t_integer(arg1)) { - opc->v[2].i = integer(cadr(car_x)); + opc->v[2].i = integer(arg1); opc->v[0].fp = opt_p_pi_sc; return_true(sc, car_x); } @@ -65040,6 +65061,17 @@ static bool p_implicit_ok(s7_scheme *sc, s7_pointer s_slot, s7_pointer car_x, in opc->v[5].fi = o1->v[0].fi; return_true(sc, car_x); } + + if ((!is_pair(arg1)) || + (is_proper_quote(sc, arg1))) + { + opc->v[2].p = (!is_pair(arg1)) ? arg1 : cadr(arg1); + opc->v[0].fp = opt_p_pp_sc; + if ((is_pair(arg1)) && (is_symbol(opc->v[2].p)) && (is_let(obj)) && (opc->v[3].p_pp_f == let_ref)) + use_slot_ref(sc, opc, obj, cadr(arg1)); + return_true(sc, car_x); + } + if (cell_optimize(sc, cdr(car_x))) { /* need both type check and func check! (hash-table-ref or 123) */ opc->v[0].fp = ((is_hash_table(obj)) && (opc->v[3].p_pp_f == s7_hash_table_ref)) ? opt_p_pp_sf_href : @@ -65056,7 +65088,7 @@ static bool p_implicit_ok(s7_scheme *sc, s7_pointer s_slot, s7_pointer car_x, in if (slot) { opc->v[3].p = slot; - slot = opt_integer_symbol(sc, cadr(car_x)); + slot = opt_integer_symbol(sc, arg1); if (slot) { opc->v[2].p = slot; @@ -65388,6 +65420,7 @@ static bool opt_cell_set(s7_scheme *sc, s7_pointer car_x) /* len == 3 here (p_sy { opt_info *opc = alloc_opt_info(sc); s7_pointer target = cadr(car_x); + s7_pointer value = caddr(car_x); if (is_symbol(target)) { s7_pointer settee; @@ -65422,9 +65455,9 @@ static bool opt_cell_set(s7_scheme *sc, s7_pointer car_x) /* len == 3 here (p_sy if (stype == sc->is_integer_symbol) { - if (is_symbol(caddr(car_x))) + if (is_symbol(value)) { - s7_pointer val_slot = opt_integer_symbol(sc, caddr(car_x)); + s7_pointer val_slot = opt_integer_symbol(sc, value); if (val_slot) { opc->v[2].p = val_slot; @@ -65439,7 +65472,6 @@ static bool opt_cell_set(s7_scheme *sc, s7_pointer car_x) /* len == 3 here (p_sy if (!set_p_i_f_combinable(sc, opc)) { opc->v[0].fp = opt_set_p_i_f; - /* fprintf(stderr, "%d: %s\n", __LINE__, display(car_x)); */ opc->v[6].fi = opc->v[5].o1->v[0].fi; } return_true(sc, car_x); @@ -65448,15 +65480,15 @@ static bool opt_cell_set(s7_scheme *sc, s7_pointer car_x) /* len == 3 here (p_sy } if (stype == sc->is_float_symbol) { - if (is_t_real(caddr(car_x))) + if (is_t_real(value)) { - opc->v[2].p = caddr(car_x); + opc->v[2].p = value; opc->v[0].fp = opt_set_p_c; return_true(sc, car_x); } if (is_symbol(caddr(car_x))) { - s7_pointer val_slot = opt_float_symbol(sc, caddr(car_x)); + s7_pointer val_slot = opt_float_symbol(sc, value); if (val_slot) { opc->v[2].p = val_slot; @@ -65465,7 +65497,7 @@ static bool opt_cell_set(s7_scheme *sc, s7_pointer car_x) /* len == 3 here (p_sy }} else { - if ((is_pair(caddr(car_x))) && + if ((is_pair(value)) && (float_optimize(sc, cddr(car_x)))) { if (!set_p_d_f_combinable(sc, opc)) @@ -65473,7 +65505,6 @@ static bool opt_cell_set(s7_scheme *sc, s7_pointer car_x) /* len == 3 here (p_sy opc->v[4].o1 = sc->opts[start_pc]; opc->v[5].fd = sc->opts[start_pc]->v[0].fd; opc->v[0].fp = (opc->v[5].fd == opt_d_dd_sf_add) ? opt_set_p_d_f_sf_add : opt_set_p_d_f; - /* if (opc->v[0].fp == opt_set_p_d_f) fprintf(stderr, "%d: %s\n", __LINE__, display(car_x)); */ } return_true(sc, car_x); } @@ -65609,15 +65640,14 @@ static bool opt_cell_set(s7_scheme *sc, s7_pointer car_x) /* len == 3 here (p_sy opc->v[3].p_pip_f = list_set_p_pip_unchecked; { /* an experiment -- is this ever hit in normal code? (for tref.scm) */ - s7_pointer val = caddr(car_x); - if ((is_pair(val)) && (car(val) == sc->add_symbol) && (is_t_integer(caddr(val))) && (is_null(cdddr(val))) && (is_symbol(cadr(target))) && - (car(target) == (caadr(val))) && (is_pair(cdadr(val))) && (is_null(cddadr(val))) && (cadr(target) == cadadr(val))) + if ((is_pair(value)) && (car(value) == sc->add_symbol) && (is_t_integer(caddr(value))) && (is_null(cdddr(value))) && (is_symbol(cadr(target))) && + (car(target) == (caadr(value))) && (is_pair(cdadr(value))) && (is_null(cddadr(value))) && (cadr(target) == cadadr(value))) { s7_pointer slot = opt_simple_symbol(sc, index); if ((slot) && (is_t_integer(slot_value(slot)))) { opc->v[2].p = slot; - opc->v[3].p = caddr(val); + opc->v[3].p = caddr(value); opc->v[0].fp = list_increment_p_pip_unchecked; return_true(sc, car_x); }}} @@ -65635,7 +65665,7 @@ static bool opt_cell_set(s7_scheme *sc, s7_pointer car_x) /* len == 3 here (p_sy if ((is_symbol_and_keyword(cadr(target))) || ((is_quoted_symbol(cadr(target))))) opc->v[3].p_ppp_f = let_set_1; - else opc->v[3].p_ppp_f = let_set_p_ppp_2; + else opc->v[3].p_ppp_f = let_set_p_ppp_2; /* (set! (L3 'x) (+ (L3 'x) 1)) */ break; default: @@ -65672,9 +65702,9 @@ static bool opt_cell_set(s7_scheme *sc, s7_pointer car_x) /* len == 3 here (p_sy opc->v[3].p_pip_f = typed_t_vector_set_p_pip_direct; else opc->v[3].p_pip_f = t_vector_set_p_pip_direct; }}} - if (is_symbol(caddr(car_x))) + if (is_symbol(value)) { - s7_pointer val_slot = opt_simple_symbol(sc, caddr(car_x)); + s7_pointer val_slot = opt_simple_symbol(sc, value); if (val_slot) { s7_p_ppp_t func1; @@ -65687,19 +65717,23 @@ static bool opt_cell_set(s7_scheme *sc, s7_pointer car_x) /* len == 3 here (p_sy opc->v[0].fp = opt_p_pip_sss; return_true(sc, car_x); } + if ((is_let(obj)) && (is_keyword(index)) && (opc->v[3].p_ppp_f == let_set_1) && /* (set! (L3 :x) i) */ + (use_pps_slot_set(sc, opc, obj, keyword_symbol(index), val_slot))) + return_true(sc, car_x); func1 = opc->v[3].p_ppp_f; opc->v[4].p_ppp_f = func1; opc->v[3].p = val_slot; - opc->v[0].fp = (func1 == multiply_p_ppp) ? opt_p_ppp_sss_mul : ((func1 == s7_hash_table_set) ? opt_p_ppp_sss_hset : opt_p_ppp_sss); + opc->v[0].fp = (func1 == multiply_p_ppp) ? opt_p_ppp_sss_mul : + (((is_hash_table(obj)) && (func1 == s7_hash_table_set)) ? opt_p_ppp_sss_hset : opt_p_ppp_sss); return_true(sc, car_x); }} else - if ((!is_pair(caddr(car_x))) || - (is_proper_quote(sc, caddr(car_x)))) + if ((!is_pair(value)) || + (is_proper_quote(sc, value))) { - if (!is_pair(caddr(car_x))) - opc->v[4].p = caddr(car_x); - else opc->v[4].p = cadaddr(car_x); + if (!is_pair(value)) + opc->v[4].p = value; + else opc->v[4].p = cadr(value); if ((is_string(obj)) || (is_any_vector(obj)) || (is_pair(obj))) @@ -65707,6 +65741,9 @@ static bool opt_cell_set(s7_scheme *sc, s7_pointer car_x) /* len == 3 here (p_sy opc->v[0].fp = opt_p_pip_ssc; return_true(sc, car_x); } + if ((is_let(obj)) && (is_keyword(index)) && (opc->v[3].p_ppp_f == let_set_1) && /* (set! (L3 :x) 0) */ + (use_ppc_slot_set(sc, opc, obj, keyword_symbol(index), opc->v[4].p))) + return_true(sc, car_x); opc->v[0].fp = opt_p_ppp_ssc; return_true(sc, car_x); } @@ -65723,6 +65760,10 @@ static bool opt_cell_set(s7_scheme *sc, s7_pointer car_x) /* len == 3 here (p_sy opc->v[0].fp = opt_p_pip_ssf; return_true(sc, car_x); } + if ((is_let(obj)) && (is_keyword(index)) && (opc->v[3].p_ppp_f == let_set_1) && /* (set! (L3 :x) (+ (L3 'x) 1)) */ + (use_ppf_slot_set(sc, opc, obj, keyword_symbol(index)))) + return_true(sc, car_x); + opc->v[0].fp = opt_p_ppp_ssf; return_true(sc, car_x); }}} @@ -65746,24 +65787,31 @@ static bool opt_cell_set(s7_scheme *sc, s7_pointer car_x) /* len == 3 here (p_sy }} return_false(sc, car_x); } - if ((is_proper_quote(sc, cadr(target))) && - (is_symbol(caddr(car_x)))) + if (is_quoted_symbol(cadr(target))) { - s7_pointer val_slot = opt_simple_symbol(sc, caddr(car_x)); - if (val_slot) + if (is_symbol(value)) { - opc->v[4].p = cadadr(target); - opc->v[2].p = val_slot; - opc->v[0].fp = (opc->v[3].p_ppp_f == let_set_1) ? opt_p_ppp_scs_eset : opt_p_ppp_scs; - return_true(sc, car_x); - }} + s7_pointer val_slot = opt_simple_symbol(sc, value); + if (val_slot) + { + opc->v[2].p = cadadr(target); + opc->v[4].p = val_slot; + opc->v[0].fp = opt_p_ppp_scs; + if ((is_let(obj)) && (opc->v[3].p_ppp_f == let_set_1)) + use_pps_slot_set(sc, opc, obj, cadadr(target), val_slot); + return_true(sc, car_x); + }} + if ((!is_pair(value)) && (is_let(obj)) && (opc->v[3].p_ppp_f == let_set_1) && + (use_ppc_slot_set(sc, opc, obj, cadadr(target), value))) + return_true(sc, car_x); + } o1 = sc->opts[sc->pc]; if (cell_optimize(sc, cdr(target))) { opt_info *o2; - if (is_symbol(caddr(car_x))) + if (is_symbol(value)) { - s7_pointer val_slot = opt_simple_symbol(sc, caddr(car_x)); + s7_pointer val_slot = opt_simple_symbol(sc, value); if (val_slot) { opc->v[2].p = val_slot; @@ -65776,6 +65824,13 @@ static bool opt_cell_set(s7_scheme *sc, s7_pointer car_x) /* len == 3 here (p_sy if (cell_optimize(sc, cddr(car_x))) { opc->v[0].fp = opt_p_ppp_sff; + if ((is_let(obj)) && (is_quoted_symbol(cadr(target))) && (opc->v[3].p_ppp_f == let_set_1) && /* (set! (L3 'x) (+ (L3 'x) 1)) */ + (use_ppf_slot_set(sc, opc, obj, cadadr(target)))) + { + opc->v[4].o1 = o2; + opc->v[5].fp = opc->v[4].o1->v[0].fp; + return_true(sc, car_x); + } opc->v[10].o1 = o1; opc->v[11].fp = o1->v[0].fp; opc->v[8].o1 = o2; @@ -67834,19 +67889,19 @@ static bool cell_optimize_1(s7_scheme *sc, s7_pointer expr) ((is_pair(cdr(car_x))) && (is_null(cddr(car_x))))) return(opt_cell_quote(sc, car_x)); - /* if head is ([let-ref] L 'multiply), it should be accessible now, so we could do the lookup, set up s_func and go on */ + /* if head is ([let-ref] L 'multiply), it should be accessible now, so we could do the lookup, set up s_func and go on */ if (is_pair(head)) { s7_pointer let, slot, sym; if ((car(head) == sc->let_ref_symbol) && (s7_list_length(sc, head) == 3)) { - let = cadr(head); + let = cadr(head); sym = caddr(head); } - else - if (s7_list_length(sc, head) == 2) + else + if (s7_list_length(sc, head) == 2) { - let = car(head); + let = car(head); sym = cadr(head); } else return_false(sc, car_x); @@ -69158,7 +69213,7 @@ a list of the results. Its arguments can be lists, vectors, strings, hash-table if (fp) { val = list_1_unchecked(sc, sc->nil); - push_stack_no_let_no_code(sc, OP_GC_PROTECT, val); + gc_protect_via_stack(sc, val); for (s7_pointer fast = cadr(args), slow = cadr(args); is_pair(fast); fast = cdr(fast), slow = cdr(slow)) { s7_pointer z = fp(sc, car(fast)); @@ -69179,7 +69234,7 @@ a list of the results. Its arguments can be lists, vectors, strings, hash-table if (fp) { val = list_1_unchecked(sc, sc->nil); - push_stack_no_let_no_code(sc, OP_GC_PROTECT, val); + gc_protect_via_stack(sc, val); for (s7_pointer fast1 = cadr(args), slow1 = cadr(args), fast2 = caddr(args), slow2 = caddr(args); (is_pair(fast1)) && (is_pair(fast2)); fast1 = cdr(fast1), slow1 = cdr(slow1), fast2 = cdr(fast2), slow2 = cdr(slow2)) @@ -69206,7 +69261,7 @@ a list of the results. Its arguments can be lists, vectors, strings, hash-table s7_pointer str = cadr(args); const char *s = string_value(str); val = list_1_unchecked(sc, sc->nil); - push_stack_no_let_no_code(sc, OP_GC_PROTECT, val); + gc_protect_via_stack(sc, val); len = string_length(str); for (s7_int i = 0; i < len; i++) { @@ -69223,7 +69278,7 @@ a list of the results. Its arguments can be lists, vectors, strings, hash-table { s7_pointer vec = cadr(args); val = list_1_unchecked(sc, sc->nil); - push_stack_no_let_no_code(sc, OP_GC_PROTECT, val); + gc_protect_via_stack(sc, val); len = vector_length(vec); for (s7_int i = 0; i < len; i++) { @@ -69626,6 +69681,15 @@ static s7_pointer op_safe_c_ssp_mv(s7_scheme *sc, s7_pointer args) /*sc->code: ( return(sc->value); } +static s7_pointer op_safe_c_3p_mv(s7_scheme *sc, s7_pointer args) +{ + s7_pointer res; + sc->temp8 = copy_proper_list(sc, args); + res = cons(sc, sc->unused, sc->temp8); + sc->temp8 = sc->unused; + return(res); +} + static s7_pointer op_c_p_mv(s7_scheme *sc, s7_pointer args) /* (values (values 1 2)) or (apply (values + '(2))) */ { sc->value = args; @@ -69721,7 +69785,7 @@ static s7_pointer splice_in_values(s7_scheme *sc, s7_pointer args) case OP_ANY_CLOSURE_NP_1: case OP_ANY_CLOSURE_NP_2: sc->code = pop_op_stack(sc); - error_nr(sc, sc->wrong_number_of_args_symbol, + error_nr(sc, sc->wrong_number_of_args_symbol, set_elist_3(sc, too_many_arguments_string, closure_name(sc, sc->code), set_ulist_1(sc, sc->value_symbol, args))); case OP_ANY_C_NP_2: @@ -69762,7 +69826,7 @@ static s7_pointer splice_in_values(s7_scheme *sc, s7_pointer args) case OP_SAFE_C_3P_1: case OP_SAFE_C_3P_2: case OP_SAFE_C_3P_3: /* (let ((g-1 (lambda (x a b c) (x (+ a 1) (- b 1) (values c 2))))) (g-1 + 2 3 5)) */ set_stack_top_op(sc, stack_top_op(sc) + 3); /* change op to parallel mv case */ case OP_SAFE_C_3P_1_MV: case OP_SAFE_C_3P_2_MV: case OP_SAFE_C_3P_3_MV: /* (list-values '+ 1 (apply-values (list 2 3))) */ - return(cons(sc, sc->unused, copy_proper_list(sc, args))); + return(op_safe_c_3p_mv(sc, args)); case OP_SAFE_CLOSURE_P_1: case OP_CLOSURE_P_1: case OP_SAFE_CLOSURE_P_A_1: case OP_SAFE_CLOSURE_AP_1: case OP_CLOSURE_AP_1: @@ -69996,7 +70060,7 @@ s7_pointer s7_values(s7_scheme *sc, s7_pointer args) static s7_pointer values_p(s7_scheme *sc) {return(sc->no_value);} static s7_pointer values_p_p(s7_scheme *unused_sc, s7_pointer p) {return(p);} -static s7_pointer values_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer unused_expr, bool unused_ops) +static s7_pointer values_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer unused_expr) { if (args > 1) return(sc->values_uncopied); /* splice_in_values */ return(f); @@ -70086,7 +70150,7 @@ static s7_pointer g_simple_list_values(s7_scheme *sc, s7_pointer args) return(args); } -static s7_pointer list_values_chooser(s7_scheme *sc, s7_pointer f, int32_t unused_args, s7_pointer expr, bool unused_ops) +static s7_pointer list_values_chooser(s7_scheme *sc, s7_pointer f, int32_t unused_args, s7_pointer expr) { for (s7_pointer p = cdr(expr); is_pair(p); p = cdr(p)) if (is_unquoted_pair(car(p))) @@ -70286,7 +70350,7 @@ static s7_pointer make_unsafe_function_with_class(s7_scheme *sc, s7_pointer cls, return(uf); } -static s7_pointer set_function_chooser(s7_pointer sym, s7_pointer (*chooser)(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool ops)) +static s7_pointer set_function_chooser(s7_pointer sym, s7_pointer (*chooser)(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr)) { s7_pointer f = global_value(sym); c_function_chooser(f) = chooser; @@ -70808,32 +70872,7 @@ static s7_pointer unbound_variable(s7_scheme *sc, s7_pointer sym) return(sc->unbound_variable_symbol); } -static bool gx_annotate_arg(s7_scheme *sc, s7_pointer p, s7_pointer e) -{ - if (is_gxable(car(p))) - { - opcode_t old_op = optimize_op(car(p)); - s7_pointer fxf; - set_optimize_op(car(p), old_op + 1); - fxf = (s7_pointer)fx_choose(sc, p, e, (is_list(e)) ? pair_symbol_is_safe : let_symbol_is_safe); - if (fxf) - { - set_has_gx(p); - set_opt2(p, fxf, OPT2_FX); - } - set_optimize_op(car(p), old_op); - return(fxf); - } - return(false); -} - -static void gx_annotate_args(s7_scheme *sc, s7_pointer args, s7_pointer e) -{ - for (s7_pointer p = args; is_pair(p); p = cdr(p)) - gx_annotate_arg(sc, p, e); -} - -#define choose_c_function(Sc, Expr, Func, Args) set_c_function(Expr, c_function_chooser(Func)(Sc, Func, Args, Expr, true)) +#define choose_c_function(Sc, Expr, Func, Args) set_c_function(Expr, c_function_chooser(Func)(Sc, Func, Args, Expr)) static void fx_annotate_arg(s7_scheme *sc, s7_pointer arg, s7_pointer e) { @@ -70862,6 +70901,7 @@ static void fx_annotate_args(s7_scheme *sc, s7_pointer args, s7_pointer e) static opt_t optimize_thunk(s7_scheme *sc, s7_pointer expr, s7_pointer func, int32_t hop, s7_pointer e) { + if (SHOW_EVAL_OPS) fprintf(stderr, " %s[%d]: expr: %s, func: %s, hop: %d, e: %s\n", __func__, __LINE__, display_80(expr), display(func), hop, display_80(e)); if ((hop != 1) && (is_constant_symbol(sc, car(expr)))) hop = 1; if ((is_closure(func)) || (is_closure_star(func))) @@ -71586,7 +71626,7 @@ static opt_t optimize_func_one_arg(s7_scheme *sc, s7_pointer expr, s7_pointer fu } break; - case T_PAIR: case T_VECTOR: case T_INT_VECTOR: case T_BYTE_VECTOR: case T_FLOAT_VECTOR: + case T_PAIR: case T_VECTOR: case T_INT_VECTOR: case T_BYTE_VECTOR: case T_FLOAT_VECTOR: if (is_fxable(sc, arg1)) { set_unsafe_optimize_op(expr, (is_pair(func) ? OP_IMPLICIT_PAIR_REF_A : OP_IMPLICIT_VECTOR_REF_A)); @@ -71601,7 +71641,7 @@ static opt_t optimize_func_one_arg(s7_scheme *sc, s7_pointer expr, s7_pointer fu (is_symbol_and_keyword(arg1))) /* (e :a) */ { s7_pointer sym = (quotes == 1) ? cadr(arg1) : arg1; - if (is_keyword(sym)) sym = keyword_symbol(sym); + if (is_keyword(sym)) sym = keyword_symbol(sym); if (func == sc->s7_starlet) /* (*s7* ...), sc->s7_starlet is a let */ { set_safe_optimize_op(expr, OP_IMPLICIT_S7_STARLET_REF_S); @@ -71617,7 +71657,7 @@ static opt_t optimize_func_one_arg(s7_scheme *sc, s7_pointer expr, s7_pointer fu case T_HASH_TABLE: case T_C_OBJECT: if (is_fxable(sc, arg1)) { - set_unsafe_optimize_op(expr, (type(func) == T_LET) ? OP_IMPLICIT_LET_REF_A : + set_unsafe_optimize_op(expr, (type(func) == T_LET) ? OP_IMPLICIT_LET_REF_A : ((type(func) == T_HASH_TABLE) ? OP_IMPLICIT_HASH_TABLE_REF_A : OP_IMPLICIT_C_OBJECT_REF_A)); fx_annotate_arg(sc, cdr(expr), e); set_opt3_arglen(cdr(expr), 1); @@ -71670,11 +71710,7 @@ static opt_t set_any_c_np(s7_scheme *sc, s7_pointer func, s7_pointer expr, s7_po * or use op_stack? error clears this? op-any-c-fp: op_any_c_2p|3p|fp? -- mimic clo_3p|4p? */ for (s7_pointer p = cdr(expr); is_pair(p); p = cdr(p)) - { - set_fx(p, fx_choose(sc, p, e, (is_list(e)) ? pair_symbol_is_safe : let_symbol_is_safe)); - if (!has_fx(p)) - gx_annotate_arg(sc, p, e); - } + set_fx(p, fx_choose(sc, p, e, (is_list(e)) ? pair_symbol_is_safe : let_symbol_is_safe)); set_opt3_arglen(cdr(expr), num_args); /* for op_unknown_np */ set_unsafe_optimize_op(expr, op); choose_c_function(sc, expr, func, num_args); /* we can use num_args -- mv will redirect to generic call */ @@ -71802,7 +71838,7 @@ static opt_t optimize_func_two_args(s7_scheme *sc, s7_pointer expr, s7_pointer f }} else { - set_optimize_op(expr, hop + ((is_semisafe(func)) ? OP_CL_AA : + set_optimize_op(expr, hop + ((is_semisafe(func)) ? OP_CL_AA : (((symbols == 0) && (pairs == 0) && (car(expr) == sc->values_symbol)) ? OP_C_NC : OP_C_AA))); fx_annotate_args(sc, cdr(expr), e); set_opt3_arglen(cdr(expr), 2); @@ -71857,7 +71893,6 @@ static opt_t optimize_func_two_args(s7_scheme *sc, s7_pointer expr, s7_pointer f return(check_c_aa(sc, expr, func, hop, e)); /* AA case */ set_optimize_op(expr, hop + OP_SAFE_C_AP); fx_annotate_arg(sc, cdr(expr), e); - gx_annotate_arg(sc, cddr(expr), e); set_opt3_arglen(cdr(expr), 2); } else @@ -71865,11 +71900,8 @@ static opt_t optimize_func_two_args(s7_scheme *sc, s7_pointer expr, s7_pointer f { set_optimize_op(expr, hop + OP_SAFE_C_PA); fx_annotate_arg(sc, cddr(expr), e); - gx_annotate_arg(sc, cdr(expr), e); set_opt3_arglen(cdr(expr), 2); - } - else gx_annotate_args(sc, cdr(expr), e); - } + }} choose_c_function(sc, expr, func, 2); /* this might change the op to safe_c_c, so it has to be last */ return(OPT_T); }} @@ -72054,20 +72086,17 @@ static opt_t optimize_func_two_args(s7_scheme *sc, s7_pointer expr, s7_pointer f set_optimize_op(expr, hop + OP_SAFE_C_AP); opt_sp_1(sc, c_function_call(func), expr); fx_annotate_arg(sc, cdr(expr), e); - gx_annotate_arg(sc, cddr(expr), e); } else if (is_fxable(sc, arg2)) { set_optimize_op(expr, hop + OP_SAFE_C_PA); fx_annotate_arg(sc, cddr(expr), e); - gx_annotate_arg(sc, cdr(expr), e); } else { set_optimize_op(expr, hop + OP_SAFE_C_PP); opt_sp_1(sc, c_function_call(func), expr); - gx_annotate_args(sc, cdr(expr), e); } choose_c_function(sc, expr, func, 2); return(OPT_F); @@ -72603,7 +72632,7 @@ static opt_t optimize_func_three_args(s7_scheme *sc, s7_pointer expr, s7_pointer set_opt3_arglen(cdr(expr), 3); if (is_semisafe(func)) set_optimize_op(expr, hop + (((is_normal_symbol(arg1)) && (is_normal_symbol(arg3))) ? OP_CL_SAS : OP_CL_NA)); - else + else if ((fx_proc(cdr(expr)) == fx_c) && (fx_proc(cddr(expr)) == fx_c) && (fx_proc(cdddr(expr)) == fx_c)) set_optimize_op(expr, hop + OP_C_NC); else set_optimize_op(expr, hop + OP_C_NA); @@ -72935,7 +72964,7 @@ static opt_t optimize_func_many_args(s7_scheme *sc, s7_pointer expr, s7_pointer { if (safe_case) set_optimize_op(expr, hop + OP_SAFE_CLOSURE_NS); - else set_optimize_op(expr, hop + ((args == 4) ? ((is_null(cdr(closure_body(func)))) ? OP_CLOSURE_4S_O : OP_CLOSURE_4S) : + else set_optimize_op(expr, hop + ((args == 4) ? ((is_null(cdr(closure_body(func)))) ? OP_CLOSURE_4S_O : OP_CLOSURE_4S) : ((args == 5) ? OP_CLOSURE_5S : OP_CLOSURE_NS))); } return(OPT_F); @@ -72997,8 +73026,14 @@ static bool vars_opt_ok(s7_scheme *sc, s7_pointer vars, int32_t hop, s7_pointer { for (s7_pointer p = vars; is_pair(p); p = cdr(p)) { - s7_pointer init = cadar(p); - /* if ((is_slot(global_slot(caar(p)))) && (is_c_function(global_value(caar(p))))) return(false); */ /* too draconian (see snd-test) */ + s7_pointer var = car(p); + s7_pointer init = cadr(var); + /* if ((is_slot(global_slot(car(var)))) && (is_c_function(global_value(car(var))))) return(false); */ /* too draconian (see snd-test) */ + if ((is_normal_symbol(car(var))) && (is_global(car(var)))) /* (define (f) (let ((+ -)) (with-let (curlet) (#_integer? (+))))) (f) */ + { + set_local(car(var)); + return(false); + } if ((is_pair(init)) && (!is_checked(init)) && (optimize_expression(sc, init, hop, e, false) == OPT_OOPS)) @@ -73499,7 +73534,7 @@ static opt_t optimize_funcs(s7_scheme *sc, s7_pointer expr, s7_pointer func, int { int32_t pairs = 0, symbols = 0, args = 0, bad_pairs = 0, quotes = 0; s7_pointer p; - if (SHOW_EVAL_OPS) fprintf(stderr, " %s[%d]: %s\n", __func__, __LINE__, display_80(expr)); + if (SHOW_EVAL_OPS) fprintf(stderr, " %s[%d]: %s, func: %s\n", __func__, __LINE__, display_80(expr), display(func)); for (p = cdr(expr); is_pair(p); p = cdr(p), args++) /* check the args (the calling expression) */ { s7_pointer car_p = car(p); @@ -79149,7 +79184,6 @@ static void op_finish_expansion(s7_scheme *sc) { if (stack_top_op(sc) != OP_LOAD_RETURN_IF_EOF) /* latter op if empty expansion at top-level */ { - /* if (S7_DEBUGGING) fprintf(stderr, "%s[%d] ", op_names[stack_top_op(sc)], sc->input_port_stack_loc); */ if (stack_top_op(sc) != OP_READ_LIST) /* OP_EVAL_STRING: (eval-string "(reader-cond...)") where reader-cond returns (values) */ sc->value = sc->F; /* (eval-string "") -> #f, was nil_string for awhile */ else set_stack_top_op(sc, OP_READ_NEXT); @@ -79422,17 +79456,7 @@ static bool op_cond1(s7_scheme *sc) sc->cur_op = optimize_op(sc->code); return(true); } -#if 0 - /* sc->code is () */ - if (is_multiple_value(sc->value)) /* this can't happen since splicer returns car now */ - { - if (S7_DEBUGGING) fprintf(stderr, "cond1 mv case %s\n", display(sc->value)); - sc->value = splice_in_values(sc, multiple_value(sc->value)); - } - /* no result clause, so return test, (cond (#t)) -> #t, (cond ((+ 1 2))) -> 3 */ -#else if ((S7_DEBUGGING) && (is_multiple_value(sc->value))) fprintf(stderr, "cond1 mv case %s\n", display(sc->value)); -#endif pop_stack(sc); return(true); } @@ -79464,15 +79488,7 @@ static bool op_cond1_simple(s7_scheme *sc) sc->code = T_Lst(cdar(sc->code)); if (is_null(sc->code)) { -#if 0 - if (is_multiple_value(sc->value)) - { - if (S7_DEBUGGING) fprintf(stderr, "cond1_simple mv case %s\n", display(sc->value)); - sc->value = splice_in_values(sc, multiple_value(sc->value)); - } -#else - if ((S7_DEBUGGING) && (is_multiple_value(sc->value))) fprintf(stderr, "cond1_simple mv case %s\n", display(sc->value)); -#endif + if ((S7_DEBUGGING) && (is_multiple_value(sc->value))) fprintf(stderr, "cond1_simple mv case %s\n", display(sc->value)); pop_stack(sc); return(true); } @@ -79632,18 +79648,8 @@ static bool op_cond_feed(s7_scheme *sc) static void op_cond_feed_1(s7_scheme *sc) { if ((S7_DEBUGGING) && (is_multiple_value(sc->value))) fprintf(stderr, "%s %s unexpected mv\n", __func__, display(sc->value)); -#if 0 - if (is_multiple_value(sc->value)) - { - if (S7_DEBUGGING) fprintf(stderr, "%s %s\n", __func__, display(sc->value)); - sc->code = cons(sc, opt2_lambda(sc->code), multiple_value(sc->value)); - } - else -#endif - { - set_curlet(sc, inline_make_let_with_slot(sc, sc->curlet, caadr(opt2_lambda(sc->code)), sc->value)); - sc->code = caddr(opt2_lambda(sc->code)); - } + set_curlet(sc, inline_make_let_with_slot(sc, sc->curlet, caadr(opt2_lambda(sc->code)), sc->value)); + sc->code = caddr(opt2_lambda(sc->code)); } static bool feed_to(s7_scheme *sc) @@ -80089,7 +80095,7 @@ static bool set_pair3(s7_scheme *sc, s7_pointer obj, s7_pointer arg, s7_pointer break; case T_LET: - sc->value = let_set(sc, obj, arg, value); /* this checks immutable */ + sc->value = let_set_2(sc, obj, arg, value); /* this checks immutable */ break; case T_C_RST_NO_REQ_FUNCTION: case T_C_FUNCTION: @@ -81047,7 +81053,7 @@ static goto_t set_implicit_let(s7_scheme *sc, s7_pointer let, s7_pointer inds, s { if (is_symbol(value)) value = lookup_checked(sc, value); - sc->value = let_set(sc, let, symval, value); + sc->value = let_set_2(sc, let, symval, value); return(goto_start); } push_op_stack(sc, sc->let_set_function); @@ -81475,6 +81481,9 @@ static bool do_is_safe(s7_scheme *sc, s7_pointer body, s7_pointer stepper, s7_po ((is_c_function(setv)) && (is_safe_procedure(c_function_setter(setv))))))) return(false); + + /* if ((has_set) && (!is_sequence(setv))) (*has_set) = true; */ + /* ^ trouble in tmock.scm (opt2_fn not set) -- apparently op_simple_do assumes has_fn which set! lacks */ if (has_set) (*has_set) = true; } else @@ -82601,24 +82610,6 @@ static goto_t op_dox(s7_scheme *sc) } while ((sc->value = endf(sc, endp)) == sc->F); sc->code = cdr(end); return(goto_do_end_clauses); - } - - /* not fxable body (bodyf nil) but body might be gxable here: is_gxable(body) */ - if ((has_gx(body)) || (gx_annotate_arg(sc, code, sc->curlet))) - { - s7_function f = fx_proc_unchecked(code); - if (S7_DEBUGGING) fprintf(stderr, "%d: %s\n", __LINE__, display(form)); - do { - s7_pointer slot1 = slots; - f(sc, body); - do { - if (slot_has_expression(slot1)) - slot_set_value(slot1, fx_call(sc, slot_expression(slot1))); - slot1 = next_slot(slot1); - } while (tis_slot(slot1)); - } while ((sc->value = endf(sc, endp)) == sc->F); - sc->code = cdr(end); - return(goto_do_end_clauses); }} else /* more than one expr */ { @@ -83202,7 +83193,6 @@ static bool op_simple_do_1(s7_scheme *sc, s7_pointer code) { /* (do ((j (+ nv k -1) (- j 1))) ((< j k)) (set! (r j) (- (r j) (* (q k) (p2 (- j k)))))) */ /* (do ((__i__ 0 (+ __i__ 1))) ((= __i__ 1) 32.0) (b 0)) and many more, all wrap-int safe I think */ /* splitting out opt_float_any_nv here saves almost nothing */ - /* if (S7_DEBUGGING) fprintf(stderr, "%d: %s\n", __LINE__, display(code)); */ for (i = start; i < stop; i++) { slot_set_value(ctr_slot, make_integer(sc, i)); @@ -83224,20 +83214,17 @@ static bool op_simple_do_1(s7_scheme *sc, s7_pointer code) if (!opt_do_copy(sc, o, stop, start + 1)) { /* (do ((i 9 (- i 1))) ((< i 0) v) (vector-set! v i i)) */ s7_pointer (*fp)(opt_info *o) = o->v[0].fp; - /* if (S7_DEBUGGING) fprintf(stderr, "%d: %s\n", __LINE__, display(code)); */ for (i = start; i >= stop; i--) { slot_set_value(ctr_slot, make_integer(sc, i)); fp(o); }}} else /* (do ((i 9 (- i 1))) ((< i 0)) (set! (v i) (delay gen 0.5 i))) */ - { - /* if (S7_DEBUGGING) fprintf(stderr, "%d: %s\n", __LINE__, display(code)); */ - for (i = start; i >= stop; i--) - { - slot_set_value(ctr_slot, make_integer(sc, i)); - func(sc); - }} + for (i = start; i >= stop; i--) + { + slot_set_value(ctr_slot, make_integer(sc, i)); + func(sc); + } sc->value = sc->T; sc->code = cdadr(code); return(true); @@ -83253,20 +83240,17 @@ static bool op_simple_do_1(s7_scheme *sc, s7_pointer code) /* (do ((i 0 (+ i 8))) ((= i 64)) (write-byte (logand (ash int (- i)) 255))) */ opt_info *o = sc->opts[0]; s7_pointer (*fp)(opt_info *o) = o->v[0].fp; - /* if (S7_DEBUGGING) fprintf(stderr, "%d: %s\n", __LINE__, display(code)); */ for (i = start; i < stop; i += incr) { slot_set_value(ctr_slot, make_integer(sc, i)); fp(o); }} else - { - if (S7_DEBUGGING) fprintf(stderr, "%d: %s\n", __LINE__, display(code)); - for (i = start; i < stop; i += incr) - { - slot_set_value(ctr_slot, make_integer(sc, i)); - func(sc); - }} + for (i = start; i < stop; i += incr) + { + slot_set_value(ctr_slot, make_integer(sc, i)); + func(sc); + } sc->value = sc->T; sc->code = cdadr(code); return(true); @@ -83285,7 +83269,6 @@ static bool op_simple_do_1(s7_scheme *sc, s7_pointer code) s7_pointer (*test_fp)(opt_info *o) = o->v[4].o1->v[O_WRAP].fp; opt_info *test_o1 = o->v[4].o1; opt_info *o2 = o->v[6].o1; - /* if (S7_DEBUGGING) fprintf(stderr, "%d: %s\n", __LINE__, display(code)); */ for (s7_int i = start; i <= stop; i++) { slot_set_value(ctr_slot, make_integer(sc, i)); @@ -83485,10 +83468,10 @@ static /* inline */ bool op_dotimes_step_o(s7_scheme *sc) /* called once in eval return(false); } -static bool opt_dotimes(s7_scheme *sc, s7_pointer code, s7_pointer scc, bool one_expr) +static bool opt_dotimes(s7_scheme *sc, s7_pointer code, s7_pointer scc, bool loop_end_ok) { s7_pointer step_val; - if (one_expr) + if (loop_end_ok) set_safe_stepper(sc->args); else set_safe_stepper(let_dox_slot1(sc->curlet)); @@ -83502,7 +83485,7 @@ static bool opt_dotimes(s7_scheme *sc, s7_pointer code, s7_pointer scc, bool one set_no_cell_opt(code); return(false); } - if (one_expr) + if (loop_end_ok) { s7_int end = loop_end(sc->args); s7_pointer stepper = make_mutable_integer(sc, integer(slot_value(sc->args))); @@ -83596,7 +83579,7 @@ static bool opt_dotimes(s7_scheme *sc, s7_pointer code, s7_pointer scc, bool one func(sc); clear_mutable_integer(stepper); } - else /* not one_expr so use dox_slot1 ?? maybe also has return */ + else { s7_pointer step_slot = let_dox_slot1(sc->curlet); s7_pointer end_slot = let_dox_slot2(sc->curlet); @@ -83713,7 +83696,7 @@ static bool opt_dotimes(s7_scheme *sc, s7_pointer code, s7_pointer scc, bool one } else { - if (one_expr) + if (loop_end_ok) { /* (do ((i start (+ i 1))) ((= i end)) (outa i (* ampa (ina i *reverb*))) (outb i (* ampb (inb i *reverb*)))) */ s7_int end = loop_end(sc->args); s7_pointer stepper = make_mutable_integer(sc, integer(slot_value(sc->args))); @@ -83751,8 +83734,8 @@ static bool opt_dotimes(s7_scheme *sc, s7_pointer code, s7_pointer scc, bool one if (is_null(p)) { - if ((S7_DEBUGGING) && (one_expr) && (!has_loop_end(sc->args))) fprintf(stderr, "%s[%d]: one_expr but not has_loop_end\n", __func__, __LINE__); - if (one_expr) + if ((S7_DEBUGGING) && (loop_end_ok) && (!has_loop_end(sc->args))) fprintf(stderr, "%s[%d]: loop_end_ok but not has_loop_end\n", __func__, __LINE__); + if (loop_end_ok) { /* (do ((i 0 (+ i 1))) ((= i 1) strs) (copy (vector-ref strs i) (make-string 1)) (copy (vector-ref strs i) (make-string 0))) */ s7_int end = loop_end(sc->args); s7_pointer stepper = make_mutable_integer(sc, integer(slot_value(sc->args))); @@ -83940,7 +83923,7 @@ static bool do_let(s7_scheme *sc, s7_pointer step_slot, s7_pointer scc) return(true); } -static bool do_let_or_dotimes(s7_scheme *sc, s7_pointer code, bool one_expr) +static bool do_let_or_dotimes(s7_scheme *sc, s7_pointer code, bool loop_end_ok) { s7_pointer body = caddr(code); /* here we assume one expr in body?? */ if (((is_syntactic_pair(body)) || @@ -83948,7 +83931,7 @@ static bool do_let_or_dotimes(s7_scheme *sc, s7_pointer code, bool one_expr) ((symbol_syntax_op_checked(body) == OP_LET) || (symbol_syntax_op(car(body)) == OP_LET_STAR))) return(do_let(sc, sc->args, code)); - return(opt_dotimes(sc, cddr(code), code, one_expr)); + return(opt_dotimes(sc, cddr(code), code, loop_end_ok)); } static goto_t op_safe_dotimes(s7_scheme *sc) @@ -84079,6 +84062,7 @@ static goto_t op_safe_do(s7_scheme *sc) sc->code = cdadr(code); return(goto_safe_do_end_clauses); } + if (is_symbol(end)) let_set_dox_slot2(sc->curlet, s7_slot(sc, end)); else let_set_dox_slot2(sc->curlet, make_slot(sc, caaar(code), end)); @@ -84086,22 +84070,22 @@ static goto_t op_safe_do(s7_scheme *sc) { s7_pointer step_slot = let_dox_slot1(sc->curlet); - set_has_loop_end(step_slot); slot_set_value(step_slot, make_mutable_integer(sc, integer(slot_value(step_slot)))); set_loop_end(step_slot, s7_integer_clamped_if_gmp(sc, end_val)); + set_has_loop_end(step_slot); } if (!is_unsafe_do(sc->code)) { s7_pointer old_let = sc->curlet; sc->temp7 = old_let; - if (opt_dotimes(sc, cddr(sc->code), sc->code, false)) /* iv2 -- false means not one expr in body */ + if (opt_dotimes(sc, cddr(sc->code), sc->code, false)) return(goto_safe_do_end_clauses); set_curlet(sc, old_let); /* apparently s7_optimize can step on sc->curlet? */ sc->temp7 = sc->unused; } - if (is_null(cdddr(sc->code))) /* do body has one expr, (do ((k 0 (+ k 1))) ((= k 2)) (set! sum (+ sum 1))) */ + if (is_null(cdddr(sc->code))) /* (do ((k 0 (+ k 1))) ((= k 2)) (set! sum (+ sum 1))) */ { s7_pointer body = caddr(sc->code); if ((car(body) == sc->set_symbol) && @@ -84263,7 +84247,7 @@ static bool op_do_init(s7_scheme *sc) static void op_do_unchecked(s7_scheme *sc) { - push_stack_no_code(sc, OP_GC_PROTECT, sc->code); + gc_protect_via_stack(sc, sc->code); sc->code = cdr(sc->code); } @@ -85206,7 +85190,6 @@ static inline bool op_safe_closure_star_na(s7_scheme *sc, s7_pointer code) /* ca sc->args = arglist; for (s7_pointer p = arglist, old_args = cdr(code); is_pair(p); p = cdr(p), old_args = cdr(old_args)) set_car(p, fx_call(sc, old_args)); - if ((S7_DEBUGGING) && (sc->args != arglist)) fprintf(stderr, "%s[%d]: lost gc\n", __func__, __LINE__); return(call_lambda_star(sc, code, arglist)); /* clears list_in_use */ } @@ -89130,17 +89113,48 @@ static bool op_x_a(s7_scheme *sc, s7_pointer f) return(false); /* goto APPLY */ } +static bool op_x_sc(s7_scheme *sc, s7_pointer f) +{ + s7_pointer code = sc->code; + if (((type(f) == T_C_FUNCTION) && (c_function_is_aritable(f, 2))) || + ((type(f) == T_C_RST_NO_REQ_FUNCTION) && (c_function_max_args(f) >= 2))) + { /* ((L 'abs) x 0.0001) where 'abs is '* in timp.scm */ + if (!needs_copied_args(f)) + { + sc->value = c_function_call(f)(sc, set_plist_2(sc, lookup_checked(sc, cadr(code)), caddr(code))); + return(true); + } + sc->args = list_2(sc, lookup_checked(sc, cadr(code)), caddr(code)); + sc->code = f; + return(false); /* goto APPLY */ + } + if (!is_applicable(f)) + apply_error_nr(sc, f, cdr(code)); + if (dont_eval_args(f)) + sc->args = list_2(sc, cadr(code), caddr(code)); + else + if (!needs_copied_args(f)) + sc->args = set_plist_2(sc, lookup_checked(sc, cadr(code)), caddr(code)); + else sc->args = list_2(sc, lookup_checked(sc, cadr(code)), caddr(code)); + sc->code = f; + return(false); /* goto APPLY */ +} + static bool op_x_aa(s7_scheme *sc, s7_pointer f) { s7_pointer code = sc->code; - if ((((type(f) == T_C_FUNCTION) && - (c_function_is_aritable(f, 2))) || - ((type(f) == T_C_RST_NO_REQ_FUNCTION) && - (c_function_max_args(f) >= 2))) && - (!needs_copied_args(f))) - { - sc->value = c_function_call(f)(sc, with_list_t2(fx_call(sc, cdr(code)), fx_call(sc, cddr(code)))); - return(true); + if (((type(f) == T_C_FUNCTION) && (c_function_is_aritable(f, 2))) || + ((type(f) == T_C_RST_NO_REQ_FUNCTION) && (c_function_max_args(f) >= 2))) + { /* ((L 'abs) x 0.0001) where 'abs is '* in timp.scm */ + if (!needs_copied_args(f)) + { + sc->value = c_function_call(f)(sc, with_list_t2(fx_call(sc, cdr(code)), fx_call(sc, cddr(code)))); + return(true); + } + sc->args = fx_call(sc, cddr(code)); + sc->args = list_2(sc, sc->value = fx_call(sc, cdr(code)), sc->args); + sc->code = f; + return(false); /* goto APPLY */ } if (!is_applicable(f)) apply_error_nr(sc, f, cdr(code)); @@ -89374,23 +89388,12 @@ static inline void op_safe_c_pp(s7_scheme *sc) { s7_pointer args = cdr(sc->code); check_stack_size(sc); - /* has_fx check here is slower, we assume car(args) below is a pair (else cp/sp/ap?) */ - if ((has_gx(args)) && (symbol_ctr(caar(args)) == 1)) - { - sc->args = fx_proc_unchecked(args)(sc, car(args)); - push_stack_direct(sc, (opcode_t)T_Op(opt1_any(args))); /* args = first value, func(args, value) if no mv */ - sc->code = cadr(args); - } - else - { - push_stack_no_args_direct(sc, OP_SAFE_C_PP_1); /* first arg = p, if mv -> op_safe_c_pp_3 */ - sc->code = car(args); - } + push_stack_no_args_direct(sc, OP_SAFE_C_PP_1); /* first arg = p, if mv -> op_safe_c_pp_3 */ + sc->code = car(args); } static void op_safe_c_pp_1(s7_scheme *sc) { - /* it is much slower to check has_gx here! */ push_stack(sc, (opcode_t)T_Op(opt1_any(cdr(sc->code))), sc->value, sc->code); /* args[i.e. sc->value] = first value, func(args, value) if no mv */ sc->code = caddr(sc->code); } @@ -89490,14 +89493,11 @@ static Inline bool inline_collect_np_args(s7_scheme *sc, opcode_t op, s7_pointer if (has_fx(p)) sc->args = cons(sc, sc->value = fx_call(sc, p), sc->args); /* reversed before apply in OP_ANY_C_NP_1 */ else - if ((has_gx(p)) && (symbol_ctr(caar(p)) == 1)) - sc->args = cons(sc, sc->value = fx_proc_unchecked(p)(sc, car(p)), sc->args); - else - { - push_stack(sc, op, sc->args, cdr(p)); - sc->code = T_Pair(car(p)); - return(true); - } + { + push_stack(sc, op, sc->args, cdr(p)); + sc->code = T_Pair(car(p)); + return(true); + } return(false); } @@ -89510,19 +89510,15 @@ static /* inline */ bool op_any_c_np(s7_scheme *sc) /* code: (func . args) where if (has_fx(p)) sc->args = cons(sc, sc->value = fx_call(sc, p), sc->args); /* reversed before apply in OP_ANY_C_NP_1 */ else - if ((has_gx(p)) && (symbol_ctr(caar(p)) == 1)) - sc->args = cons(sc, sc->value = fx_proc_unchecked(p)(sc, car(p)), sc->args); - else - { - if (sc->op_stack_now >= sc->op_stack_end) - resize_op_stack(sc); - push_op_stack(sc, sc->code); - check_stack_size(sc); - push_stack(sc, ((intptr_t)((is_pair(cdr(p))) ? OP_ANY_C_NP_1 : OP_ANY_C_NP_2)), sc->args, cdr(p)); - sc->code = T_Pair(car(p)); - return(true); - } - /* here fx/gx got all the args */ + { + if (sc->op_stack_now >= sc->op_stack_end) + resize_op_stack(sc); + push_op_stack(sc, sc->code); + check_stack_size(sc); + push_stack(sc, ((intptr_t)((is_pair(cdr(p))) ? OP_ANY_C_NP_1 : OP_ANY_C_NP_2)), sc->args, cdr(p)); + sc->code = T_Pair(car(p)); + return(true); + } sc->args = proper_list_reverse_in_place(sc, sc->args); sc->value = fn_proc(sc->code)(sc, sc->args); return(false); @@ -89627,16 +89623,6 @@ static bool op_safe_c_ap(s7_scheme *sc) { s7_pointer code = cdr(sc->code); s7_pointer val = cdr(code); - if ((has_gx(val)) && (symbol_ctr(caar(val)) == 1)) - { - val = fx_proc_unchecked(val)(sc, car(val)); - gc_protect_via_stack(sc, val); - set_car(sc->t2_1, fx_call(sc, code)); - set_car(sc->t2_2, val); - unstack_gc_protect(sc); - sc->value = fn_proc(sc->code)(sc, sc->t2_1); - return(false); - } check_stack_size(sc); sc->args = fx_call(sc, code); push_stack_direct(sc, (opcode_t)T_Op(opt1_any(code))); /* safe_c_sp cases, mv->safe_c_sp_mv */ @@ -89647,15 +89633,6 @@ static bool op_safe_c_ap(s7_scheme *sc) static bool op_safe_c_pa(s7_scheme *sc) { s7_pointer args = cdr(sc->code); - if ((has_gx(args)) && (symbol_ctr(caar(args)) == 1)) - { - gc_protect_via_stack(sc, fx_proc_unchecked(args)(sc, car(args))); - set_car(sc->t2_2, fx_call(sc, cdr(args))); - set_car(sc->t2_1, stack_protected1(sc)); - unstack_gc_protect(sc); - sc->value = fn_proc(sc->code)(sc, sc->t2_1); - return(false); - } check_stack_size(sc); push_stack_no_args_direct(sc, OP_SAFE_C_PA_1); sc->code = car(args); @@ -89770,7 +89747,7 @@ static void op_apply_sl(s7_scheme *sc) static bool op_pair_pair(s7_scheme *sc) { - if (!is_pair(car(sc->code))) + if (!is_pair(car(sc->code))) /* (for-each (macro* (a . b) `(cons ,a ,b)) #(0 1) (list '(values +) -1)) sc->code is (-1) */ { clear_optimize_op(sc->code); return(false); @@ -89786,7 +89763,7 @@ static bool op_pair_pair(s7_scheme *sc) static bool op_pair_sym(s7_scheme *sc) { - if (!is_symbol(car(sc->code))) + if (!is_symbol(car(sc->code))) /* (for-each (macro* (a . b) `(cons ,a ,b)) #(0 1) (list `+ -1)) ! sc->code is (-1) */ { clear_optimize_op(sc->code); return(false); @@ -90029,7 +90006,9 @@ static bool eval_car_pair(s7_scheme *sc) { fx_annotate_args(sc, cdr(code), sc->curlet); set_fx_direct(code, fx_function[optimize_op(carc)]); - set_optimize_op(code, (is_null(cddr(code))) ? OP_A_A : OP_A_AA); + if (is_null(cddr(code))) + set_optimize_op(code, OP_A_A); + else set_optimize_op(code, ((is_symbol(cadr(code))) && (!is_pair(caddr(code))) && (!is_normal_symbol(caddr(code)))) ? OP_A_SC : OP_A_AA); return(false); /* goto eval in trailers */ }} set_no_cell_opt(carc); @@ -90049,7 +90028,9 @@ static bool eval_car_pair(s7_scheme *sc) { fx_annotate_args(sc, cdr(code), sc->curlet); set_fx_direct(code, fx_function[optimize_op(carc)]); - set_optimize_op(code, (is_null(cddr(code))) ? OP_A_A : OP_A_AA); + if (is_null(cddr(code))) + set_optimize_op(code, OP_A_A); + else set_optimize_op(code, ((is_symbol(cadr(code))) && (!is_pair(caddr(code))) && (!is_normal_symbol(caddr(code)))) ? OP_A_SC : OP_A_AA); sc->code = carc; return(false); /* goto eval in trailers */ } @@ -90103,10 +90084,10 @@ static goto_t trailers(s7_scheme *sc) sc->value = carc; return(goto_eval_args_top); } - if (is_symbol(code)) + if (is_normal_symbol(code)) { sc->value = lookup_checked(sc, code); - set_optimize_op(code, (is_keyword(code)) ? OP_CONSTANT : OP_SYMBOL); + set_optimize_op(code, OP_SYMBOL); } else { @@ -91332,7 +91313,7 @@ static bool op_unknown_a(s7_scheme *sc) if ((is_quoted_symbol(arg1)) || (is_symbol_and_keyword(arg1))) { s7_pointer sym = (is_pair(arg1)) ? cadr(arg1) : arg1; - if (is_keyword(sym)) sym = keyword_symbol(sym); + if (is_keyword(sym)) sym = keyword_symbol(sym); set_opt3_con(code, sym); return(fixup_unknown_op(sc, code, f, OP_IMPLICIT_LET_REF_C)); } @@ -91781,7 +91762,6 @@ static bool op_unknown_np(s7_scheme *sc) { set_any_c_np(sc, f, code, sc->curlet, 2, OP_SAFE_C_PP); opt_sp_1(sc, c_function_call(f), code); - gx_annotate_args(sc, cdr(code), sc->curlet); } else if ((num_args == 3) && @@ -92374,6 +92354,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) case OP_A_A: if (op_x_a(sc, fx_call(sc, sc->code))) continue; goto APPLY; case OP_S_AA: if (op_x_aa(sc, lookup_checked(sc, car(sc->code)))) continue; goto APPLY; case OP_A_AA: if (op_x_aa(sc, fx_call(sc, sc->code))) continue; goto APPLY; + case OP_A_SC: if (op_x_sc(sc, fx_call(sc, sc->code))) continue; goto APPLY; case OP_P_S: push_stack_no_args_direct(sc, OP_P_S_1); sc->code = car(sc->code); goto EVAL; case OP_P_S_1: op_p_s_1(sc); goto APPLY; @@ -94390,20 +94371,21 @@ static s7_pointer memory_usage(s7_scheme *sc) /* safe_lists */ { - s7_int live = 0, in_use = 0; + s7_int live = 0, in_use = 0, line_used = 0; for (i = 1; i < NUM_SAFE_LISTS; i++) if (is_pair(sc->safe_lists[i])) { live++; - if (list_is_in_use(sc->safe_lists[i])) in_use++; + if (list_is_in_use(sc->safe_lists[i])) {in_use++; line_used = i;} } sc->w = sc->nil; #if S7_DEBUGGING - for (i = NUM_SAFE_LISTS - 1; i > 0; i--) + for (i = NUM_SAFE_LISTS - 1; i > 0; i--) /* omit safe_lists[0]=() since it is never used */ sc->w = cons(sc, make_integer(sc, sc->safe_list_uses[i]), sc->w); #endif add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "safe-lists", 10), - list_3(sc, make_integer(sc, live), make_integer(sc, in_use), sc->w)); + (in_use == 0) ? list_3(sc, small_int(live), int_zero, sc->w) : + list_4(sc, small_int(live), small_int(in_use), small_int(line_used), sc->w)); #if S7_DEBUGGING sc->w = sc->unused; #endif @@ -95653,7 +95635,7 @@ static void init_opt_functions(s7_scheme *sc) s7_set_p_pip_unchecked_function(sc, global_value(sc->list_set_symbol), list_set_p_pip_unchecked); s7_set_p_p_function(sc, global_value(sc->cyclic_sequences_symbol), cyclic_sequences_p_p); s7_set_p_pp_function(sc, global_value(sc->let_ref_symbol), let_ref); - s7_set_p_ppp_function(sc, global_value(sc->let_set_symbol), let_set); + s7_set_p_ppp_function(sc, global_value(sc->let_set_symbol), let_set_2); /* originally named "let_set" but that was unsearchable */ s7_set_p_pi_function(sc, global_value(sc->string_ref_symbol), string_ref_p_pi); s7_set_p_pp_function(sc, global_value(sc->string_ref_symbol), string_ref_p_pp); s7_set_p_pip_function(sc, global_value(sc->string_set_symbol), string_set_p_pip); @@ -95710,6 +95692,7 @@ static void init_opt_functions(s7_scheme *sc) s7_set_p_pp_function(sc, global_value(sc->write_string_symbol), write_string_p_pp); s7_set_p_pp_function(sc, global_value(sc->read_line_symbol), read_line_p_pp); s7_set_p_p_function(sc, global_value(sc->read_line_symbol), read_line_p_p); + s7_set_p_pp_function(sc, global_value(sc->inlet_symbol), inlet_p_pp); s7_set_i_7p_function(sc, global_value(sc->port_line_number_symbol), s7_port_line_number); s7_set_p_pp_function(sc, global_value(sc->cons_symbol), cons_p_pp); @@ -96676,8 +96659,8 @@ static void init_rootlet(s7_scheme *sc) sc->symbol_to_keyword_symbol = defun("symbol->keyword", symbol_to_keyword, 1, 0, false); sc->keyword_to_symbol_symbol = defun("keyword->symbol", keyword_to_symbol, 1, 0, false); - sc->outlet_symbol = /* unsafe_ */ defun("outlet", outlet, 1, 0, false); - sc->rootlet_symbol = /* unsafe_ */ defun("rootlet", rootlet, 0, 0, false); + sc->outlet_symbol = defun("outlet", outlet, 1, 0, false); + sc->rootlet_symbol = defun("rootlet", rootlet, 0, 0, false); sc->curlet_symbol = unsafe_defun("curlet", curlet, 0, 0, false); /* (define (f a) (curlet)) exports the funclet, see s7test 50215 */ set_func_is_definer(sc->curlet_symbol); sc->unlet_symbol = defun("unlet", unlet, 0, 0, false); @@ -97259,9 +97242,6 @@ s7_scheme *s7_init(void) init_catchers(); init_s7_starlet_immutable_field(); already_inited = true; -#if WITH_ALLOC_COUNTERS - for (int i = 0; i < 100000; i++) allocs[i] = 0; -#endif } #if S7_DEBUGGING init_never_unheaped(); @@ -97605,19 +97585,20 @@ s7_scheme *s7_init(void) sc->tree_pointers = NULL; sc->tree_pointers_size = 0; sc->tree_pointers_top = 0; + sc->objstr_max_len = S7_INT64_MAX; + sc->let_temp_hook = sc->nil; sc->rootlet = alloc_pointer(sc); set_full_type(sc->rootlet, T_LET | T_SAFE_PROCEDURE | T_UNHEAP); let_set_id(sc->rootlet, -1); let_set_outlet(sc->rootlet, NULL); let_set_slots(sc->rootlet, slot_end); - add_semipermanent_let_or_slot(sc, sc->rootlet); /* need to mark outlet and maybe slot values */ + add_semipermanent_let_or_slot(sc, sc->rootlet); + sc->rootlet_slots = slot_end; set_curlet(sc, sc->rootlet); sc->shadow_rootlet = sc->rootlet; sc->unlet_slots = slot_end; - sc->objstr_max_len = S7_INT64_MAX; - sc->let_temp_hook = sc->nil; init_wrappers(sc); init_standard_ports(sc); @@ -97628,35 +97609,37 @@ s7_scheme *s7_init(void) s7_pointer p; new_cell(sc, p, T_RANDOM_STATE); /* s7_set_default_random_state might set sc->default_random_state, so this shouldn't be permanent */ sc->default_random_state = p; - - sc->bignum_precision = DEFAULT_BIGNUM_PRECISION; #if WITH_GMP - sc->bigints = NULL; - sc->bigrats = NULL; - sc->bigflts = NULL; - sc->bigcmps = NULL; - - mpfr_set_default_prec((mp_prec_t)DEFAULT_BIGNUM_PRECISION); - mpc_set_default_precision((mp_prec_t)DEFAULT_BIGNUM_PRECISION); - - mpz_inits(sc->mpz_1, sc->mpz_2, sc->mpz_3, sc->mpz_4, NULL); - mpq_inits(sc->mpq_1, sc->mpq_2, sc->mpq_3, NULL); - mpfr_inits2(DEFAULT_BIGNUM_PRECISION, sc->mpfr_1, sc->mpfr_2, sc->mpfr_3, NULL); - mpc_init(sc->mpc_1); - mpc_init(sc->mpc_2); - mpz_set_ui(sc->mpz_1, (uint64_t)my_clock()); gmp_randinit_default(random_gmp_state(p)); gmp_randseed(random_gmp_state(p), sc->mpz_1); - - sc->pi_symbol = s7_define_constant(sc, "pi", big_pi(sc)); /* not actually a constant because it changes with bignum-precision */ - s7_provide(sc, "gmp"); #else random_seed(p) = (uint64_t)my_clock(); /* used to be time(NULL), but that means separate threads can get the same random number sequence */ random_carry(p) = 1675393560; - sc->pi_symbol = s7_define_constant(sc, "pi", real_pi); #endif } + + sc->bignum_precision = DEFAULT_BIGNUM_PRECISION; +#if WITH_GMP + sc->bigints = NULL; + sc->bigrats = NULL; + sc->bigflts = NULL; + sc->bigcmps = NULL; + + mpfr_set_default_prec((mp_prec_t)DEFAULT_BIGNUM_PRECISION); + mpc_set_default_precision((mp_prec_t)DEFAULT_BIGNUM_PRECISION); + mpz_inits(sc->mpz_1, sc->mpz_2, sc->mpz_3, sc->mpz_4, NULL); + mpq_inits(sc->mpq_1, sc->mpq_2, sc->mpq_3, NULL); + mpfr_inits2(DEFAULT_BIGNUM_PRECISION, sc->mpfr_1, sc->mpfr_2, sc->mpfr_3, NULL); + mpc_init(sc->mpc_1); + mpc_init(sc->mpc_2); + + sc->pi_symbol = s7_define_constant(sc, "pi", big_pi(sc)); /* not actually a constant because it changes with bignum-precision */ + s7_provide(sc, "gmp"); +#else + sc->pi_symbol = s7_define_constant(sc, "pi", real_pi); +#endif + for (i = 0; i < 10; i++) sc->singletons[(uint8_t)'0' + i] = small_int(i); sc->singletons[(uint8_t)'+'] = sc->add_symbol; sc->singletons[(uint8_t)'-'] = sc->subtract_symbol; @@ -97811,7 +97794,7 @@ s7_scheme *s7_init(void) s7_define_function(sc, "report-missed-calls", g_report_missed_calls, 0, 0, false, NULL); /* tc/recur tests in s7test.scm */ if (strcmp(op_names[HOP_SAFE_C_PP], "h_safe_c_pp") != 0) fprintf(stderr, "c op_name: %s\n", op_names[HOP_SAFE_C_PP]); if (strcmp(op_names[OP_SET_WITH_LET_2], "set_with_let_2") != 0) fprintf(stderr, "set op_name: %s\n", op_names[OP_SET_WITH_LET_2]); - if (NUM_OPS != 926) fprintf(stderr, "size: cell: %d, block: %d, max op: %d, opt: %d\n", (int)sizeof(s7_cell), (int)sizeof(block_t), NUM_OPS, (int)sizeof(opt_info)); + if (NUM_OPS != 927) fprintf(stderr, "size: cell: %d, block: %d, max op: %d, opt: %d\n", (int)sizeof(s7_cell), (int)sizeof(block_t), NUM_OPS, (int)sizeof(opt_info)); /* cell size: 48, 120 if debugging, block size: 40, opt: 128 or 280 */ #endif return(sc); @@ -98184,70 +98167,66 @@ int main(int argc, char **argv) #endif /* -------------------------------------------------------------- - * 19.9 20.9 21.0 22.0 23.0 24.0 24.2 + * 19.9 20.9 21.0 22.0 23.0 24.0 24.3 * -------------------------------------------------------------- * tpeak 148 115 114 108 105 102 102 - * tref 1081 691 687 463 459 464 466 + * tref 1081 691 687 463 459 464 410 * index 1026 1016 973 967 972 973 - * tmock 1177 1165 1057 1019 1032 1031 - * tvect 3408 2519 2464 1772 1669 1497 1452 - * tauto 2562 2048 1729 1704 - * texit 1884 1930 1950 1778 1741 1770 1771 - * s7test 1873 1831 1818 1829 1830 1855 - * lt 2222 2187 2172 2150 2185 1950 1950 - * thook 7651 2590 2030 2046 2008 - * dup 3805 3788 2492 2239 2097 2076 - * tcopy 8035 5546 2539 2375 2386 2386 - * tread 2440 2421 2419 2408 2405 2259 + * tmock 1177 1165 1057 1019 1032 1029 + * tvect 3408 2519 2464 1772 1669 1497 1454 + * tauto 2562 2048 1729 1707 + * texit 1884 1930 1950 1778 1741 1770 1769 + * s7test 1873 1831 1818 1829 1830 1857 + * lt 2222 2187 2172 2150 2185 1950 1952 + * thook 7651 2590 2030 2046 2011 + * dup 3805 3788 2492 2239 2097 2031 + * tcopy 8035 5546 2539 2375 2386 2387 + * tread 2440 2421 2419 2408 2405 2256 * titer 3657 2865 2842 2641 2509 2449 2446 * trclo 8031 2735 2574 2454 2445 2449 2470 - * tload 3046 2404 2566 2549 - * fbench 2933 2688 2583 2460 2430 2478 2559 - * tmat 3065 3042 2524 2578 2590 2573 + * tload 3046 2404 2566 2537 + * fbench 2933 2688 2583 2460 2430 2478 2562 + * tmat 3065 3042 2524 2578 2590 2578 * tsort 3683 3105 3104 2856 2804 2858 2858 - * tobj 4016 3970 3828 3577 3508 3515 - * teq 4068 4045 3536 3486 3544 3537 + * tobj 4016 3970 3828 3577 3508 3518 + * teq 4068 4045 3536 3486 3544 3527 * tio 3816 3752 3683 3620 3583 3601 - * tmac 3950 3873 3033 3677 3677 3680 - * tclo 6362 4787 4735 4390 4384 4474 4339 - * tcase 4960 4793 4439 4430 4439 4443 - * tlet 9166 7775 5640 4450 4427 4457 4483 - * tfft 7820 7729 4755 4476 4536 4543 - * tmap 8869 8774 4489 4541 4586 4592 - * tstar 6139 5923 5519 4449 4550 4570 - * tshoot 5525 5447 5183 5055 5034 5034 - * tform 5357 5348 5307 5316 5084 5095 - * tstr 10.0 6880 6342 5488 5162 5180 5197 - * tnum 6348 6013 5433 5396 5409 5423 - * tgsl 8485 7802 6373 6282 6208 6186 - * tari 15.0 13.0 12.7 6827 6543 6278 6278 - * tlist 9219 7896 7546 6558 6240 6300 6298 - * tset 6260 6364 6408 - * trec 19.5 6936 6922 6521 6588 6583 6583 - * tleft 11.1 10.4 10.2 7657 7479 7627 7614 - * tmisc 8142 7631 7745 - * tlamb 8003 7941 7936 - * tgc 11.9 11.1 8177 7857 7986 8005 - * thash 11.8 11.7 9734 9479 9526 9260 - * cb 12.9 11.2 11.0 9658 9564 9609 9635 + * tmac 3950 3873 3033 3677 3677 3683 + * tclo 6362 4787 4735 4390 4384 4474 4337 + * tcase 4960 4793 4439 4430 4439 4446 + * tlet 9166 7775 5640 4450 4427 4457 4481 + * tfft 7820 7729 4755 4476 4536 4542 + * tstar 6139 5923 5519 4449 4550 4578 + * tmap 8869 8774 4489 4541 4586 4593 + * tshoot 5525 5447 5183 5055 5034 5052 + * tform 5357 5348 5307 5316 5084 5087 + * tstr 10.0 6880 6342 5488 5162 5180 5205 + * tnum 6348 6013 5433 5396 5409 5432 + * tgsl 8485 7802 6373 6282 6208 6181 + * tari 15.0 13.0 12.7 6827 6543 6278 6274 + * tlist 9219 7896 7546 6558 6240 6300 6305 + * tset 6260 6364 6394 + * trec 19.5 6936 6922 6521 6588 6583 6584 + * tleft 11.1 10.4 10.2 7657 7479 7627 7612 + * tmisc 8142 7631 7673 + * tlamb 8003 7941 7948 + * tgc 11.9 11.1 8177 7857 7986 8014 + * thash 11.8 11.7 9734 9479 9526 9254 + * cb 12.9 11.2 11.0 9658 9564 9609 9641 * tmap-hash 1671.0 1467.0 10.3 - * timp 16.4 15.8 11.8 11.7 11.7 10.4 * tmv 16.0 15.4 14.7 14.5 14.4 11.9 * tgen 11.2 11.4 12.0 12.1 12.2 12.3 * tall 15.9 15.6 15.6 15.6 15.6 15.1 15.1 - * calls 36.7 37.5 37.0 37.5 37.1 37.0 + * timp 25.4 24.4 20.0 19.6 19.7 15.6 + * calls 36.7 37.5 37.0 37.5 37.1 37.1 * sg 55.9 55.8 55.4 55.2 - * tbig 177.4 175.8 156.5 148.1 146.2 146.3 + * tbig 177.4 175.8 156.5 148.1 146.2 146.2 * -------------------------------------------------------------- * * snd-region|select: (since we can't check for consistency when set), should there be more elaborate writable checks for default-output-header|sample-type? * fx_chooser can't depend on the is_global bit because it sees args before local bindings reset that bit, get rid of these if possible * lots of is_global(sc->quote_symbol) - * safe/mutable lists in opt? savable mutable ints? (wrappers+in-use-flag?) second-layer of base safe_lists? need counts of fallbacks - * timing: setter, check op_s|a|x_* and trailers -- what is currently unopt'd - * t683 extended -> timp? - * op_x_aa: ss star, sc|cc imp - * strings, format individual tests - * let-temp in opt*, save slot (let), hash-entry (hash+resize check), maybe also for set! in opt* - * odd equal messages in t101-aux-*, t718 snd-test troubles, pair_to_port free cell + * (define print-length (list 1 2)) (define (f) (with-let *s7* (+ print-length 1))) (display (f)) (newline) -- need a placeholder-let (or actual let) for *s7*? + * so (with-let *s7* ...) would make a let with whatever *s7* entries are needed? -> (let ((print-length (*s7* 'print-length))) ...) + * currently sc->s7_starlet is a let (make_s7_starlet) using g_s7_let_ref_fallback, so it assumes print-length above is undefined */ @@ -2,7 +2,7 @@ #define S7_H #define S7_VERSION "10.8" -#define S7_DATE "12-Mar-2024" +#define S7_DATE "14-Apr-2024" #define S7_MAJOR_VERSION 10 #define S7_MINOR_VERSION 8 @@ -2201,8 +2201,19 @@ variable named '+iterator+ with a non-#f value: </pre> <p>The +iterator+ variable is similar to the '+documentation+ variable used by documentation. It gives make-iterator some hope of catching inadvertent bogus function arguments that would -otherwise cause an infinite loop. +otherwise cause an infinite loop. But unfortunately it can escape and infect +other functions: </p> +<pre class="indented"> +(with-let (let ((<em class="red">+iterator+</em> #t)) + (lambda () #<eof>)) ; we intended this to be our iterator + (concatenate vector (lambda a (copy a)))) ; from stuff.scm + ;; (lambda a (copy a)) is also considered an iterator by map (in sequences->list) because + ;; the local +iterator+ is #t. "a" is () because there are no further arguments to + ;; concatenate, so (lambda a (copy a)) is generating infinitely many ()'s and this + ;; code eventually dies with a heap overflow! +</pre> + <div class="header" id="multidimensionalvectors"><h4>multidimensional vectors</h4></div> @@ -3947,7 +3958,7 @@ a modern GUI leaves formatting decisions to a text or table widget. <p>format is a mess. It is trying to cram two different choices into its first ("port") argument. Perhaps it should be split into format->string and format->port. format->string has no port argument and returns a string. format->port writes to its port argument (which must be an output -port, not a boolean), and returns #f or maybe <unspecified>. Then: +port, not a boolean), and returns an empty string. Then: </p> <pre> (format #f ...) -> (format->string ...) @@ -7810,6 +7810,11 @@ i" (lambda (p) (eval (read p)))) pi) (test (symbol? (string->symbol " hi")) #t) (test (symbol? (string->symbol "hi ")) #t) (test (keyword? (string->symbol ":asdf")) #t) +(test (symbol->string 'a'b) "a'b") +(test (string->symbol "a\"b") (symbol "a\"b")) +(test (symbol->string (symbol "a\"b")) "a\"b") +(test (symbol->string (symbol "a" (string #\") "b")) "a\"b") ; r7rs spec says no escapes -- how is it a legal string? +(test (string->symbol (string #\a #\" #\b)) (symbol "a\"b")) (test (reinvert 12 string->symbol symbol->string "hiho") "hiho") @@ -9886,22 +9891,19 @@ i" (lambda (p) (eval (read p)))) pi) (test (let ((c (cons 1 2))) (set-cdr! c _ht_) (cdr c)) _ht_) (test (let ((c (cons 1 2))) (set-cdr! c (list 3)) c) '(1 3)) -;;; this is a version of the (list-set! '(1 2 3) ...) problem -;;; (let () (define (func) (set-cdr! (quasiquote (int-vector)) imb)) (define (hi) (func) (func)) (hi) (hi)) - ;;; -------------------------------------------------------------------------------- ;;; list-ref (test (list-ref (list 1 2) 1) 2) (test (list-ref '(a b c d) 2) 'c) -(test (list-ref (cons 1 2) 0) 1) ; !! +(test (list-ref (cons 1 2) 0) 1) (test (list-ref ''foo 0) #_quote) (test (list-ref '((1 2) (3 4)) 1) '(3 4)) (test (list-ref (list-ref (list (list 1 2) (list 3 4)) 1) 1) 4) (test (let ((x (list 1 2 3))) (list-ref x (list-ref x 1))) 3) (test (list-ref '(1 2 . 3) 1) 2) -(test (list-ref '(1 2 . 3) 2) 'error) ; hmm... +(test (list-ref '(1 2 . 3) 2) 'error) (test ('(1 2 . 3) 0) 1) (test ('(1 . 2) 0) 1) @@ -10303,6 +10305,7 @@ i" (lambda (p) (eval (read p)))) pi) (test (make-list 8796093022208) 'error) (test (make-list 0 #\a) ()) (test (make-list 1 #\a) '(#\a)) +(test (let-temporarily (((*s7* 'max-list-length 32))) (make-list 64)) 'error) (for-each (lambda (arg) @@ -16929,6 +16932,18 @@ i" (lambda (p) (eval (read p)))) pi) (hash-inc) (test (hash-table-ref h 'a) 2)) +(let () + (define (f8) ; this shows why hash_ref -> entry_ref can't work + (let ((H (hash-table 'x 1)) + (sum 0)) + (do ((i 0 (+ i 1))) + ((= i 30) sum) + (set! sum (+ sum (H 'x))) + (hash-table-set! H 'x #f) ; release 'x entry + (hash-table-set! H 'y -1) ; grab 'x entry for 'y + (hash-table-set! H 'x 2)))) ; change 'x value + (test (f8) 59)) + (for-each (lambda (arg) (test (make-hash-table arg) 'error)) @@ -16977,7 +16992,7 @@ i" (lambda (p) (eval (read p)))) pi) (let () (define nan1 +nan.0) (define nan2 -nan.0) - + (let ((H (hash-table))) (set! (H nan1) 1) (test (H nan1) #f) @@ -16990,7 +17005,7 @@ i" (lambda (p) (eval (read p)))) pi) (test (H -nan.0) #f) (set! (H -nan.0) 3) (test (object->string H) "(hash-table +nan.0 3 +nan.0 2 +nan.0 1)")) - + (define vn1 (float-vector +nan.0)) (define vn2 (float-vector -nan.0)) @@ -17000,13 +17015,13 @@ i" (lambda (p) (eval (read p)))) pi) (set! (H vn2) 2) (test (object->string H) "(hash-table #r(+nan.0) 2 #r(+nan.0) 1)") (test (equal? vn1 vn1) #t)) ; see below - + (let ((H (hash-table))) (set! (H #(0)) 1) (test (H #(0)) 1) (test (H #(0.0)) #f) (test (H (vector 0)) 1)) - + (let ((H (hash-table)) (L1 (list +nan.0)) (L2 (list +nan.0))) @@ -17018,7 +17033,7 @@ i" (lambda (p) (eval (read p)))) pi) ;; is this inconsistent? It's the same object, so its contents aren't relevant?? ;; otherwise anything with a NaN in it can't be equal? even to itself -- seems perverse. - ;; guile: + ;; guile: ;; scheme@(guile-user)> (equal? (vector +nan.0) (vector +nan.0)) ;; $1 = #t ;; s7: @@ -17028,7 +17043,7 @@ i" (lambda (p) (eval (read p)))) pi) ;; #f ;; <3> (equivalent? (float-vector +nan.0) (float-vector +nan.0)) ;; #t - + (let ((typed-hash (make-hash-table 8 eq? (cons symbol? integer?)))) (define (f) (do ((i 0 (+ i 1))) ((= i 3)) (char-upcase (string-ref typed-hash else)))) (test (f) 'error)) ; opt_p_pp_sf_href problem @@ -17052,7 +17067,7 @@ i" (lambda (p) (eval (read p)))) pi) (test (H -nan.0) 2) (set! (H -nan.0) 3) (test (object->string H) "(hash-table +nan.0 3)")) - + (let ((H (make-hash-table 8 equivalent?))) (set! (H vn1) 1) (test (H vn1) 1) @@ -20521,6 +20536,15 @@ i" (lambda (p) (eval (read p)))) pi) (test (c) 'error)) ; ;read-error ("our input port got clobbered!") |# +(let () + (define (func) + (catch #t (lambda () + (call-with-exit (lambda (goto) (goto (display (make-list 512 '(1)) (open-output-function Hk)))))) ; fx_c_aa GC trouble + (lambda args + 'error))) + (define (f) (do ((i 0 (+ i 1))) ((= i 10)) (func))) ; GC -> free cell, either lst in pair_to_port, or port in display + (test (f) #t)) + (let ((stdin-wrapper (open-input-function (lambda (choice) (case choice @@ -22255,8 +22279,8 @@ a2" 3) "132") (test (format #f "~f" 1) "1") (test (format #f "~F" most-positive-fixnum) "9223372036854775807") -(test (format () "") #f) -(test (with-output-to-string (lambda () (display (format () "")))) "#f") +(test (format () "") "") ; changed 18-Mar-24, was #f +(test (with-output-to-string (lambda () (display (format () "")))) "") (test (with-output-to-string (lambda () (display #f))) "#f") (unless with-bignums @@ -22481,7 +22505,7 @@ a2" 3) "132") (list #\a #(1 2 3) "hi" () 'hi abs (lambda () 1) #(()) (list 1 2 3) '(1 . 2))) (test (format #f "~D") 'error) -(test (format () "hi") #f) ; not an error now -- will print "hi" also +(test (format () "hi") "") ; not an error now -- will print "hi" also (test (format #f "~F" "hi") 'error) (test (format #f "~D" #\x) 'error) (test (format #f "~C" (list 1 2 3)) 'error) @@ -22842,7 +22866,7 @@ a2" 3) "132") (test (let () (define (func) (format (list 1 2) "")) (define (hi) (func)) (hi)) 'error) (test (format :rest "") 'error) -(let* ((str1 #t) (str2 (with-output-to-string (lambda () (set! str1 (format () "~D" 1)))))) (test (and (not str1) (equal? str2 "1")) #t)) +(let* ((str1 #t) (str2 (with-output-to-string (lambda () (set! str1 (format () "~D" 1)))))) (test (and (equal? str1 "") (equal? str2 "1")) #t)) (test (format #f "~,'") 'error) (if with-bignums @@ -23785,7 +23809,7 @@ a2" 3) "132") "(list (macro (x) '#1=(1 2 . #1#)))") (test (format #f "~W" (list (apply lambda '(x) (let ((cp (list 1))) (set-cdr! cp cp) (list 'quote cp))))) 'error) ;;apply #_lambda: body is circular: ((x) quote #1=(1 . #1#)) - ) + (test (format #f "~W" (make-hook (let ((cp (list 1))) (set-cdr! cp cp) (list 'quote cp)))) "#<write_closure_readably: arglist is cyclic>")) ;;; -------- test that we can plow past errors -------- @@ -25476,8 +25500,9 @@ c" (require libdl.scm) (when (defined? '*libdl*) (testlet *libdl*)) - (require libutf8proc.scm) - (when (defined? '*libutf8proc*) (testlet *libutf8proc*)))) + (unless (provided? 'osx) + (require libutf8proc.scm) + (when (defined? '*libutf8proc*) (testlet *libutf8proc*))))) (let ((len 5)) (test (object->string (make-list 20) #f len) "(#...") @@ -26961,7 +26986,7 @@ c" (test ('quote 3) 'error) (test ((copy quote) 1) 1) (test ((copy quote) quote) 'quote) -(test ((lambda (q) (let ((x 1)) (q x))) quote) 'x) ; these two are strange -- not sure about them, but Guile 1.8 is the same +(test ((lambda (q) (let ((x 1)) (q x))) quote) 'x) (test ((lambda (s c) (s c)) quote #f) 'c) ;;; ((lambda (lambda) (lambda (else))) quote) -> '(else) (test ((quote and) #f) 'error) @@ -27282,6 +27307,11 @@ c" (define (func) (let () (for-each display (list ((let () msym1) cond (_fnc_ (c-pointer-weak1 0+0/0i))))))) ; cruel and unusual! (test (func) 'error)) +(test (for-each (macro* (a . b) `(cons ,a ,b)) #(0 1) (list `+ -1)) #<unspecified>) ; op_pair_sym initial (pair? (car code)) check +(test (for-each (macro* (a . b) `(cons ,a ,b)) #(0 1) (list '(values +) -1)) #<unspecified>) ; op_pair_pair case +(test (map (macro* (a . b) `(cons ,a ,b)) #(0 1) (list `+ -1)) 'error) ; attempt to apply an integer -1 in (-1) +(test (map (lambda* (a . b) `(cons ,a ,b)) #(0 1) (list `+ -1)) '((cons 0 (+)) (cons 1 (-1)))) + (let () (define (hi) (let ((lst '(1 2 3))) @@ -29173,7 +29203,7 @@ in s7: (lambda args 'error)))))) (test (iterate iter) 'error) - (let () ; catch #<unused temp11 from t101-aux-18 + (let () ; catch #<unused temp11 from t101-18 (define (f) (let ((x (map (lambda (a) (iterate iter)) '(0)))) (test x '(error)))) @@ -47265,7 +47295,7 @@ or better (define-macro (prog vars . body) `(call-with-exit (lambda (return) (ta (test (signature floor) '(integer? real?)) (test (signature flush-output-port) '(#t (output-port? not))) (test (signature for-each) (let ((L (list 'unspecified? 'procedure? 'sequence?))) (set-cdr! (cddr L) (cddr L)) L)) -(test (signature format) (let ((L (list '(string? not) '(output-port? boolean? null?) #t))) (set-cdr! (cddr L) (cddr L)) L)) +(test (signature format) (let ((L (list 'string? '(output-port? boolean? null?) #t))) (set-cdr! (cddr L) (cddr L)) L)) ; changed 19-Mar-24 (test (signature funclet) '((let? null?) (procedure? macro? symbol?))) (test (signature funclet?) '(boolean? #t)) (test (signature gc) '(#t boolean?)) @@ -51111,6 +51141,13 @@ or better (define-macro (prog vars . body) `(call-with-exit (lambda (return) (ta (test (let () (with-let (rootlet) +signature+)) 'error) ; unbound variable (test (let () (define (f) (with-let (rootlet) +signature+)) (f) (f)) 'error) ; unbound variable (test (with-let (rootlet) (and #t +iterator+)) 'error) ; let_symbol_is_safe T_Lsd bug +(test (let ((mlet (inlet 'a 1))) (define (f) (do ((i 0 (+ i 1))) ((= i 3)) (let-set! mlet with-let 0))) (f)) 'error) +(test (let ((mlet (inlet 'a 1)) (nsym :a)) (define (f) (do ((i 0 (+ i 1))) ((= i 3)) (let-set! mlet nsym 0))) (f)) #t) ; do loop return +(test (let ((mlet (inlet 'a 1)) (nsym 'a)) (define (f) (do ((i 0 (+ i 1))) ((= i 3)) (let-set! mlet nsym 0))) (f)) #t) +(test (let ((mlet (inlet 'a 1)) (nsym 32)) (define (f) (do ((i 0 (+ i 1))) ((= i 3)) (let-set! mlet nsym 0))) (f)) 'error) +(test (let ((L (inlet 'a 1)) (V (make-vector 8 'a symbol?))) (define (f) (do ((i 0 (+ i 1))) ((= i 2)) (let-set! L V (append)))) (f)) 'error) +(test (let ((imb (block 0.0 1.0 2.0))) (define (f) (do ((i 0 (+ i 1))) ((= i 2)) (hash-table? (memq imb `(+ x 1))))) (f)) #t) +(test (let ((clet (inlet 'a 1))) (define (f) (do ((i 0 (+ i 1))) ((= i 3)) (let? (inlet 'value clet)))) (f)) #t) (test (equivalent? (sublet (inlet) 'a 1 (inlet 'b 2)) (inlet 'b 2 'a 1)) #t) (test (equivalent? (sublet (inlet) (inlet 'b 2)) (inlet 'b 2)) #t) @@ -51556,9 +51593,9 @@ or better (define-macro (prog vars . body) `(call-with-exit (lambda (return) (ta (set! res (cons (L 'a) res)) (set! L H) (set! res (cons (L 'a) res))))) - + (test (f5) '(1 2)) - + (define (f6) (let ((L (inlet 'a 1)) (V (vector 2)) @@ -51568,7 +51605,7 @@ or better (define-macro (prog vars . body) `(call-with-exit (lambda (return) (ta (set! res (cons (L 'a) res)) (set! L V) (set! res (cons (L 'a) res))))) - + (test (f6) 'error)) (test (inlet :a 1) (inlet (cons 'a 1))) @@ -55329,7 +55366,7 @@ hi6: (string-app... (if (< b c) (tc-1 b c)))) (tc-1 0 32) - (if (> max-stack _max_stack_tc_) (format #t "tc-1 max: ~D~%" max-stack))) ; 18 here and below in repl.scm, 13 in t101-aux-3 + (if (> max-stack _max_stack_tc_) (format #t "tc-1 max: ~D~%" max-stack))) ; 18 here and below in repl.scm, 13 in t101-3 (let ((max-stack 0)) (define (tc-1 a c) @@ -58379,14 +58416,14 @@ hi6: (string-app... (test-t (equal (find-if-not (lambda (x) (not (eq x 'b))) #((a) (b) (c)) :key car) '(b))) (test-t (equal (find-if-not (lambda (x) (not (eq x 'c))) #((a) (b) (c)) :key car) '(c))) (test-t (null (find-if-not (lambda (x) (not (eq x 'z))) #((a) (b) (c)) :key car))) - (test-t (let ((vector #((a) (b) (c)))) - (and (eq (find-if-not (lambda (x) (not (eq x 'a))) vector :key car) - (aref vector 0)) - (eq (find-if-not (lambda (x) (not (eq x 'b))) vector :key car) - (aref vector 1)) - (eq (find-if-not (lambda (x) (not (eq x 'c))) vector :key car) - (aref vector 2)) - (null (find-if-not (lambda (x) (not (eq x 'z))) vector :key car))))) + (test-t (let ((vect #((a) (b) (c)))) + (and (eq (find-if-not (lambda (x) (not (eq x 'a))) vect :key car) + (aref vect 0)) + (eq (find-if-not (lambda (x) (not (eq x 'b))) vect :key car) + (aref vect 1)) + (eq (find-if-not (lambda (x) (not (eq x 'c))) vect :key car) + (aref vect 2)) + (null (find-if-not (lambda (x) (not (eq x 'z))) vect :key car))))) (test-t (equal (find-if-not (lambda (x) (not (eq x 'a))) #((a) (b) (c) (a a) (b b) (c c)) :key car) '(a))) (test-t (equal (find-if-not (lambda (x) (not (eq x 'a))) #((a) (b) (c) (a a) (b b) (c c)) :key car :from-end t) '(a a))) (test-t (equal (find-if-not (lambda (x) (not (eq x 'b))) #((a) (b) (c) (a a) (b b) (c c)) :key car) '(b))) @@ -95455,6 +95492,19 @@ etc ;; a=1 here, so use aa (test (let-values (((aa b) (values 1 2)) ((c d) (values aa 4))) (+ aa b c d)) 'error) ; 'a not in scope + (let () ; from bug-guile + (define* (newton-sqrt x (tolerance 0.001) (guess 1)) + (if (< (abs (- x (* guess guess))) tolerance) + (values guess (abs (- x (* guess guess))) tolerance) + (newton-sqrt x tolerance (/ (+ guess (/ x guess)) 2)))) + + (let-values (((root diff tolerance) (newton-sqrt 1000))) + (num-test (exact->inexact diff) 3.6992436605487455e-4) + (test tolerance 0.001) + (test (< diff tolerance) #t) + (test (< diff (inexact->exact tolerance)) #t) + (test (< (exact->inexact diff) tolerance) #t))) + (test (let*-values (((x) (values 1))) x) 1) (test (let*-values ((x (values 1))) x) '(1)) (test (let*-values (((x) (values 1)) ((y) (values 2))) (list x y)) '(1 2)) @@ -97216,6 +97266,17 @@ etc (test (let ((e (openlet (inlet 'call/cc (lambda (obj) 32))))) (call/cc e)) 32) (test (let ((e (openlet (inlet 'call-with-current-continuation (lambda (obj) 32))))) (call/cc e)) 32) + (let () ; from tmock, op_simple_do has_fn problem + (define dolph-1 + (lambda (N gamma) + (let ((w (make-vector 256 1.0))) + (do ((i 0 (+ i 1))) + ((= i N)) + (set! (w i) (abs i))) + w))) + (dolph-1 (expt 2 8) 0.5) + (dolph-1 ((*mock-number* 'mock-number) (expt 2 8)) 0.5)) + (define (gloomy-hash-table) (openlet (sublet (*mock-hash-table* 'mock-hash-table-class) @@ -97930,6 +97991,10 @@ etc (close-input-port mip) )) (test (with-let (mock-port (open-input-string "asdf")) (append (block) (block))) (block)) + (when full-s7test + (let ((imfi (mock-port (open-input-string "asdf")))) ; pair_to_port GC problem in fx_c_opaaq + (define (func) (object->string (make-list (*s7* 'rootlet-size) imfi))) + (do ((i 0 (+ i 1))) ((= i 10)) (func)))) (test (catch #t (lambda () (with-let (mock-port (open-input-string "asdf")) (append "hi" (block)))) @@ -99785,9 +99850,6 @@ etc (test (string? (_do1_ (map cons (let ((<1> #f) (<2> (vector #f))) (set! <1> (make-iterator <2>)) (set! (<2> 0) <1>) <1>) "aa"))) #t) (test (_do1_ (for-each cons (let ((<1> #f) (<2> (vector #f))) (set! <1> (make-iterator <2>)) (set! (<2> 0) <1>) <1>) "aa")) "#<unspecified>") ;;; ^ these are regression tests for an over-eager free_cell use -(let-temporarily (((current-output-port) #f)) - (if (let ((false #f)) (define (func) (do () ((not false) (format () "ra")))) (define (hi) (func)) (hi)) (format *stderr* "format1 bug~%")) - (if (let ((false #f)) (define (func) (when (not false) (format () "ra"))) (define (hi) (func)) (hi)) (format *stderr* "format2 bug~%"))) (let () (let ((x 1)) (define (func) (do ((i 0 (+ i 1))) ((= i 1) x) (set! x (clamp 0 x 10)))) (define (hi) (func)) (hi)) @@ -101148,7 +101210,10 @@ etc (reader-cond ((not (provided? 'openbsd)) (test (string? (let ((w (wordexp.make))) (wordexp "~/cl/snd-gdraw" w 0) - (car (wordexp.we_wordv w)))) + (let ((res (car (wordexp.we_wordv w)))) + (wordfree w) + (wordexp.free w) + res))) #t))) (test (pair? (system-limits)) #t) (test (> (file-length "s7test.scm") 4000000) #t) @@ -101826,70 +101891,10 @@ etc ;;; -------------------------------------------------------------------------------- -;;; libutf8proc -;;; -;;; these are from the libutf8proc test directory - -(when full-s7test - (load "libutf8proc.scm") - - (when (defined? '*libutf8proc*) - (with-let *libutf8proc* - - (define (print-property c) - (format *stderr* " category = ~S~% charwidth = ~D~%~A~%" - (utf8proc_category_string c) - (utf8proc_charwidth c) - (utf8proc_get_property c))) - - (do ((c 1 (+ c 1))) - ((= c #x110000)) - (let ((l (utf8proc_tolower c)) - (u (utf8proc_toupper c))) - (if (not (or (= l c) - (utf8proc_codepoint_valid l))) - (format *stderr* "~X: invalid tolower~%" c)) - (if (not (or (= u c) - (utf8proc_codepoint_valid u))) - (format *stderr* "~X: invalid toupper~%" c)) - )) - - (do ((c 0 (+ c 1))) - ((or (= c #xd800) - (and (not (utf8proc_codepoint_valid c)) - (not (format *stderr* "~X: codepoint invalid~%" c)))))) - - (do ((c #xd800 (+ c 1))) - ((or (= c #xe000) - (and (utf8proc_codepoint_valid c) - (not (format *stderr* "~X: codepoint valid?~%" c)))))) - - (do ((c #xe000 (+ c 1))) - ((or (= c #x110000) - (and (not (utf8proc_codepoint_valid c)) - (not (format *stderr* "~X: codepoint invalid~%" c)))))) - - (do ((c #x110000 (+ c 1))) - ((or (= c #x110010) - (and (utf8proc_codepoint_valid c) - (not (format *stderr* "~X: codepoint valid?~%" c)))))) - - ;; (print-property #xbb) - - (do ((c 1 (+ c 1))) - ((= c #x110000)) - (let ((cat ((utf8proc_get_property c) 'category)) - (w (utf8proc_charwidth c))) - (if (and (or (= cat UTF8PROC_CATEGORY_MN) (= cat UTF8PROC_CATEGORY_ME)) - (positive? w)) - (format *stderr* "nonzero width ~D for combining char ~X~%" w c)) - (if (and (zero? w) - (or (and (>= cat UTF8PROC_CATEGORY_LU) (<= cat UTF8PROC_CATEGORY_LO)) - (and (>= cat UTF8PROC_CATEGORY_ND) (<= cat UTF8PROC_CATEGORY_SC)) - (and (>= cat UTF8PROC_CATEGORY_SO) (<= cat UTF8PROC_CATEGORY_ZS)))) - (format *stderr* "zero width for symbol-like char ~X~%" c)))) - ))) - +;;; libutf8proc (now moved to utf8-tests.scm) + (when (and full-s7test (provided? 'system-extras) (not (provided? 'osx)) (file-exists? "utf8-tests.scm")) + (load "utf8-tests.scm")) +;;; -------------------------------------------------------------------------------- (test (procedure? (symbol->value-anywhere 'getchar)) #t) (test (integer? (symbol->value-anywhere 'GSL_SUCCESS)) #t) @@ -101906,7 +101911,8 @@ etc (regcomp rg "a.b" 0) (let ((res (regexec rg "acb" 0 0))) ; 0 = match (regfree rg) - res)) + (regex.free rg) + res)) 0) (unless (provided? 'osx) @@ -101920,6 +101926,7 @@ etc (not (zero? res))) (error 'regex-error "~S: ~S~%" "colou\\?r" (regerror res rg))) (regfree rg) + (regex.free rg) res)) #i(4 9)) @@ -101933,6 +101940,7 @@ etc (not (zero? res))) (error 'regex-error "~S~%" (regerror res rg))) (regfree rg) + (regex.free rg) res)) #i(0 8 0 8 4 6))) @@ -106134,6 +106142,7 @@ etc format: perhaps (format \"buffer?\") -> \"buffer?\"") (lint-test "(format (format #f str))" " format: format needs at least 2 arguments: (format (format #f str)) + format: in (format (format #f str)), format's argument should be an output-port or a boolean, but (format #f str) is a string? format: redundant format: (format (format #f str))") (lint-test "(format #f \"~H\" 1)" " format: unrecognized format directive: H in \"~H\", (format #f \"~H\" 1)") (lint-test "(format #f \"~^\")" " format: ~^ has ~^ outside ~{~}?") @@ -107093,9 +107102,7 @@ etc (lint-test "(even? (+ 2 x))" " even?: perhaps (even? (+ 2 x)) -> (even? x)") (lint-test "(even? (- 1 x))" " even?: perhaps (even? (- 1 x)) -> (odd? x)") (lint-test "(even? (- 1 2))" " even?: perhaps (even? (- 1 2)) -> #f even?: perhaps (- 1 2) -> -1") - (let-temporarily ((*report-sloppy-assoc* #t)) - (lint-test "(string-append str (format () str arg))" - " string-append: in (string-append str (format () str arg)), string-append's second argument should be a string, but (format () str arg) might also be #f")) + (lint-test "(string-append str (format () str arg))" "") ; 19-Mar-24 (lint-test "(not (peek-char))" " not: (not (peek-char)) can't be true (peek-char never returns #f) not: perhaps (not (peek-char)) -> #f") @@ -109185,7 +109192,7 @@ etc func: in (load - -1 3/4), load's first argument should be a string, but - is a procedure? func: in (load - -1 3/4), load's second argument should be a let, but -1 is an integer? func: perhaps (- -1 3/4) -> -7/4 - func: in (positive? (format 0 (inlet (make-list)))), positive?'s argument should be real, but (format 0 (inlet (make-list))) is a string or #f + func: in (positive? (format 0 (inlet (make-list)))), positive?'s argument should be real, but (format 0 (inlet (make-list))) is a string? func: in (format 0 (inlet (make-list))), format's first argument should be an output-port or a boolean, but 0 is an integer? func: make-list needs at least 1 argument: (make-list)") (lint-test "(zero? (system str))" "") @@ -110018,6 +110025,9 @@ etc (let ((f #_abs)) (test (set! #_abs +) 'error) (set! abs +) (test (eq? f abs) #f) (test (eq? f #_abs) #t) (set! abs #_abs)) (when (zero? (*s7* 'debug)) (test (let ((+ -)) (define (f x) (#_+ x 1)) (object->string f :readable)) "(lambda (x) (#_+ x 1))")) +(let () (define-macro (q x) `(symbol? ',x)) (let ((quote "Friends, Romans, countrymen")) (test (q 123) #f))) ; an error in Guile ("Friends..." is applied to 123) +;; if 123 -> quote, returns #t + (test (let ((quote 32)) (+ quote 1)) 33) (test (let (' 32) (+ quote 1)) 'error) (test (let ((quote 32)) (define (f) (+ quote 1)) (f)) 33) @@ -110279,7 +110289,6 @@ etc ((#_not ,test) (exit)) ,@body))) (,loop)))))) - (let ((i 0) (j 0) (loop 3)) @@ -47,11 +47,11 @@ #include "snd-strings.h" -#define SND_DATE "12-Mar-24" +#define SND_DATE "14-Apr-24" #ifndef SND_VERSION -#define SND_VERSION "24.2" +#define SND_VERSION "24.3" #endif #define SND_MAJOR_VERSION "24" -#define SND_MINOR_VERSION "2" +#define SND_MINOR_VERSION "3" #endif diff --git a/tools/auto-tester.scm b/tools/auto-tester.scm index 543b55b..e70d1bf 100644 --- a/tools/auto-tester.scm +++ b/tools/auto-tester.scm @@ -6,7 +6,7 @@ (define with-mock-data #f) ;(set! (*s7* 'profile) 1) (when (provided? 'number-separator) (set! (*s7* 'number-separator) #\,)) -;(set! (*s7* 'gc-stats) 4) ; heap-stats +;(set! (*s7* 'gc-stats) 4) ; stack-stats (unless (defined? 'fuzzies) (define fuzzies 100000)) @@ -715,7 +715,7 @@ (define-constant imfv2 (immutable! #r2d((1 2 3) (4 5 6)))) (define-constant imfv3 (immutable! #r3d(((1 2 3) (1 2 4)) ((1 2 5) (1 2 6)) ((1 2 7) (1 2 8))))) (define-constant imi (immutable! (inlet 'a 3 'b 2))) -(define-constant ilt (immutable! (openlet (inlet 'a 1 'let-ref-fallback (lambda (e sym) #<undefined>))))) +(define-constant ilt (immutable! (openlet (inlet 'let-ref-fallback (lambda (e sym) #<undefined>))))) (define-constant imh (immutable! (let ((H (make-hash-table 8 #f (cons symbol? integer?)))) (set! (H 'a) 1) (set! (H 'b) 2) H))) (define-constant imp (immutable! (cons 0 (immutable! (cons 1 (immutable! (cons 2 ()))))))) @@ -783,6 +783,7 @@ (define max-stack (*s7* 'stack-top)) (define last-error-type #f) (define old-definee #f) +(define L0 (inlet 'a 1)) (define (tp val) ; omits trailing " if val long and already a string (let ((str (object->string val))) @@ -800,9 +801,9 @@ (define-macro (with-immutable objs . body) `(let-temporarily (,@(map (lambda (obj) - `((setter ',obj) (lambda (s v) - (error 'immutable-object-error - "in with-immutable, can't set! ~A" + `((setter ',obj) (lambda (s v) + (error 'immutable-object-error + "in with-immutable, can't set! ~A" ',obj)))) objs)) ,@body)) @@ -820,7 +821,7 @@ 'even? 'string-append 'char-upcase 'sqrt 'my-make-string 'char-alphabetic? 'odd? 'call-with-exit 'tanh 'copy 'sinh 'make-vector 'string 'char-ci=? 'caddr 'tan 'reverse 'cddr 'append 'vector? 'list? 'exp 'acos 'asin 'symbol? 'char-numeric? 'string-ci=? - 'char-downcase 'acosh 'vector-length 'asinh 'format + 'char-downcase 'acosh 'vector-length 'asinh 'format 'make-list 'goto? ;'sort! ; qsort_r has a memory leak if error raised by comparison function 'atanh 'modulo 'make-polar 'gcd 'angle 'remainder 'quotient 'lcm @@ -869,7 +870,7 @@ 'c-pointer->list 'c-pointer-info 'c-pointer-type 'c-pointer-weak1 'c-pointer-weak2 ;'show-profile - 'make-hook + ;'make-hook ; can get #=1(1 . #1#) as arglist! 'let 'let* 'letrec 'letrec* ;'lambda 'lambda* ; these cause built-ins to become locals if with-method=#f? ;'macro 'macro* 'bacro 'bacro* ; -- same as lambda above @@ -949,7 +950,7 @@ '=> 'constant? - '*unbound-variable-hook* '*load-hook* '*rootlet-redefinition-hook* '*missing-close-paren-hook* + '*unbound-variable-hook* '*load-hook* '*rootlet-redefinition-hook* '*missing-close-paren-hook* '*read-error-hook* '*after-gc-hook* '*autoload* @@ -961,7 +962,7 @@ 'cyclic-sequences 'let->list 'setter 'int-vector? - 'int-vector-set! 'c-object? 'c-object-type 'proper-list? + 'int-vector-set! 'c-object? 'c-object-type 'proper-list? 'symbol->dynamic-value 'vector-append 'flush-output-port 'c-pointer 'make-float-vector @@ -1032,7 +1033,7 @@ 'gb1 'gb2 'gb3 'cf00 'c-function-with-values 'c-macro-with-values 'safe-c-function-with-2-values - 'bignum 'symbol 'count-if ;'pretty-print + 'bignum 'symbol 'count-if ;'pretty-print 'tree-member 'funclet? 'bignum? 'copy-tree ;'dynamic-unwind ; many swaps that are probably confused ;'function-open-output 'function-open-input 'function-get-output 'function-close-output ;see s7test, not set up for t725 @@ -1065,7 +1066,7 @@ "(dilambda (lambda args args) (lambda args args))" "(dilambda (lambda* (a b) a) (lambda* (a b c) c))" "((lambda (a) (+ a 1)) 2)" "((lambda* ((a 1)) (+ a 1)) 1)" "(lambda (a) (values a (+ a 1)))" "((lambda (a) (values a (+ a 1))) 2)" "(lambda a (copy a))" "(lambda (a . b) (cons a b))" "(lambda* (a . b) (cons a b))" "(lambda (a b . c) (list a b c))" - "(define-macro (_m1_ a) `(+ ,a 1))" "(define-bacro (_b1_ a) `(* ,a 2))" + "(define-macro (_m1_ a) `(+ ,a 1))" "(define-bacro (_b1_ a) `(* ,a 2))" "(macro (x) (let ((g (gensym))) (let ((,g ,x)) `(values g g))))" "((dilambda (lambda () 3) (lambda (x) x)))" "(macro (a) `(+ ,a 1))" "(bacro (a) `(* ,a 2))" "(macro* (a (b 1)) `(+ ,a ,b))" "(bacro* (a (b 2)) `(* ,a ,b))" @@ -1100,7 +1101,8 @@ "(inlet 'integer? (lambda (f) #f))" "(inlet 'a 1)" "(openlet (inlet 'abs (lambda (x) (if (real? x) (if (< x 0.0) (- x) x) (error 'wrong-type-arg \"not a real\")))))" "(openlet (inlet 'zero? (lambda (x) (if (number? x) (= x 0.0) (error 'wrong-type-arg \"not a number\")))))" - "(inlet 'a (inlet 'b 1))" + "(inlet 'a (inlet 'b 1))" "(if (integer? (with-let ilt (abs -1))) (error 'oops \"oops ilt\"))" + "(L0 'a)" "(L0 :a)" "(let-ref L0 (keyword->symbol :a))" "(let-ref L0 :a)" "(L0 ':a)" "(let-ref L0 'a)" "'(15 26 . 36)" ;" . " ; -- read-errors "((i 0 (+ i 1)))" "(= i 2)" "(zero? i)" "((null? i) i)" @@ -1141,6 +1143,8 @@ "#i(60 0 0 0 0 1 0 0 0 1 1 0 0 1 0 1 0 0 1 1 1 0 1 1 0 1 0 0 0 0 0 0 0 0 0 0 1 1 0 1 0 1 0 0 0 1 0 1 1 0 0 0 1 1 1 1 1 0 0 1 1)" "#r(0.000000 0.303100 0.261228 0.917131 0.691793 -0.677124 0.027342 -0.014801 1.166154 0.416979 0.851167 1.410955 0.139409 -0.306122 1.416862 1.054300 0.792442 0.062922 1.507148 0.118287 1.375215 1.459904 1.620963 0.828106 -0.237368 0.987982 0.753194 0.096604 1.712227 1.239483 0.673351 0.871862 0.125962 0.260000 0.626286 0.147473 0.131774 0.201212 -0.194457 0.538798 0.418147 1.292448 0.871870 0.794549 0.988888 1.131816 -0.166311 0.052304 0.543793 -0.229410 0.113585 0.733683 0.271039 1.008427 1.788452 0.654055 0.106430 0.828086 0.097436 0.376461)" "(let ((x 0.0) (y 1.0)) (do ((.i 0 (#_+ .i 1))) ((#_= .i 2) (set! x (#_+ x y))) (set! x (#_* .i .1))))" ; if = is -, infinite loop + "(values 60 0 0 0 0 1 0 0 0 1 1 0 0 1 0 1 0 0 1 1 1 0 1 1 0 1 0 0 0 0 0 0 0 0 0 0 1 1 0 1 0 1 0 0 0 1 0 1 1 0 0 0 1 1 1 1 1 0 0 1 1)" + "(values 512 0 0 1 1 0 0 0 0 1 0 0 0 1 0 0 1 0 0 1 1 0 0 1 1 1 0 1 1 1 0 0 1 1 1 0 0 1 1 1 0 1 0 0 0 0 1 1 1 0 0 1 0 0 1 1 0 0 1 0 0 0 1 0 1 1 1 0 1 0 0 1 0 0 1 0 0 0 0 0 1 1 0 0 1 0 1 0 0 0 0 1 0 0 0 1 0 1 1 1 1 1 0 1 1 0 1 1 1 1 0 0 0 0 0 0 1 1 1 0 0 1 0 0 0 0 1 0 0 0 1 0 1 0 0 0 0 0 0 0 0 0 0 1 0 1 0 1 1 0 0 1 1 1 0 0 1 0 1 1 0 0 1 0 1 0 0 1 1 1 0 1 0 0 1 0 0 1 0 0 0 1 0 1 1 0 0 0 1 1 1 0 0 0 0 1 1 1 0 1 0 0 1 1 0 1 0 0 0 0 0 0 1 0 0 0 1 1 0 1 0 1 0 0 0 0 1 1 1 0 0 0 0 0 0 0 1 0 1 1 0 0 1 0 0 0 1 0 1 0 0 1 1 1 0 0 1 0 1 1 1 1 0 1 1 1 1 0 0 1 0 0 1 0 0 1 1 1 1 0 0 1 1 1 1 0 0 0 1 0 0 0 1 1 1 0 0 1 0 0 0 0 0 0 1 1 0 0 0 0 0 0 1 0 0 0 1 0 0 1 0 1 0 1 1 1 1 0 0 1 0 0 1 1 0 1 0 1 1 0 0 0 1 0 1 1 0 0 1 1 1 0 0 1 0 0 1 1 1 1 0 0 1 0 1 1 1 1 1 1 1 0 0 0 1 0 1 1 1 0 1 0 1 1 1 1 0 1 0 1 0 1 0 0 0 0 0 1 1 1 1 1 1 1 1 1 1 0 1 0 1 1 0 1 0 1 1 0 0 1 1 0 0 0 1 0 0 1 1 0 0 0 0 1 0 0 0 0 1 1 0 0 0 0 1 0 1 0 0 1 0 0 0 0 0 0 0 1 0 0 1 0 1 0 1 1 0 1 1 1 0 0 1 1 1 1 1 0 0 0 0 1 1 0 0 0 0 1 1 1 0 1 0 1 0 0 1 0 0 1 0 0 1 1 1 0 0 0 0 0 1 0 1)" "(call-with-exit (lambda (goto) goto))" "(symbol->string 'x)" "(symbol \"a b\")" "(symbol \"(\\\")\")" @@ -1271,7 +1275,7 @@ "(make-vector 3 #f (let ((calls 0)) (lambda (x) (set! calls (+ calls 1)) (= calls 1))))" ; 2 calls = error I hope "(immutable! #(1 2))" "(immutable! #r(1 2))" "(immutable! \"asdf\")" "(immutable! '(1 2))" "(immutable! (hash-table 'a 1))" - ;"(immutable! 'x)" + ;"(immutable! 'x)" "(immutable! 'asdf)" "(lambda (x) (fill! (copy x) 0))" @@ -1617,7 +1621,7 @@ (let ((tree (catch #t (lambda () ; try to catch read errors - (eval-string (string-append "'" str))) + (eval-string (string-append "'" str))) ;;(with-input-from-string str read) -- causes missing close paren troubles with eval-time reader-cond (read error not caught) (lambda (t i) ())))) @@ -1648,7 +1652,7 @@ (eq? val2 'error) (eq? val3 'error) (eq? val4 'error)) - (format #t " from same-type type-eqv: ~S: ~S~%" + (format #t " from same-type type-eqv: ~S: ~S~%" error-type (if (pair? error-info) (catch #t @@ -1901,7 +1905,7 @@ (when (= m 100000) (set! m 0) (set! n (+ n 1)) - (when (= n 8) + (when (= n 8) (set! n 0) (format *stderr* " ~A " (daytime))) (format *stderr* "~A" (vector-ref dots n))) diff --git a/tools/ffitest.c b/tools/ffitest.c index 66f5704..e3a40d6 100644 --- a/tools/ffitest.c +++ b/tools/ffitest.c @@ -1609,7 +1609,7 @@ int main(int argc, char **argv) {fprintf(stderr, "%d: %s is not 4?\n", __LINE__, s1 = TO_STR(p)); free(s1);} { s7_int val; - val = s7_integer(s7_apply_function_star(sc, s7_name_to_value(sc, "plus"), + val = s7_integer(s7_apply_function_star(sc, s7_name_to_value(sc, "plus"), s7_list(sc, 2, s7_make_integer(sc, 1), s7_make_integer(sc, 2)))); if (val != 4) fprintf(stderr, "%d: plus: %" ld64 "\n", __LINE__, val); @@ -2826,20 +2826,20 @@ int main(int argc, char **argv) { /* check realloc'd large block handling in s7_free */ int i; s7_int addrs[20000]; - + for (i = 0; i < 20000; i++) /* gc_protected_objects */ addrs[i] = s7_gc_protect(sc, s7_cons(sc, s7_f(sc), s7_t(sc))); - - for (i = 19999; i >= 0; i--) + + for (i = 19999; i >= 0; i--) s7_gc_unprotect_at(sc, addrs[i]); - + for (i = 0; i < 10000; i++) /* rootlet */ { char buf[128]; snprintf(buf, 128, "sym-%d", i); s7_define(sc, s7_nil(sc), s7_make_symbol(sc, (const char *)buf), s7_make_integer(sc, i)); } - + for (i = 0; i < 10000; i++) /* stack */ { s7_pointer p = s7_make_vector(sc, 3); diff --git a/tools/sam.c b/tools/sam.c index 7d0a4c9..100faef 100644 --- a/tools/sam.c +++ b/tools/sam.c @@ -4,7 +4,7 @@ * not an exact replica of the Samson box output. The latter used 12, 14, 20, 24, 28, and 30-bit * fractional and integer fields, which are a pain to deal with when we would rather use doubles. * - * gcc sam.c -o sam -lm -O2 + * gcc sam.c -o sam -lm -O2 -Wall * sam TEST.SAM * -> TEST.wav ("wav" or "riff" header, quad, little-endian float data at box srate) * @@ -17,28 +17,24 @@ (define* (quad->stereo (snd 0)) "turn a quad sound into a (new) stereo sound by mixing 4->1 and 3->2" (let ((r0 (make-sampler 0 snd 0)) - (r1 (make-sampler 0 snd 1)) - (r2 (make-sampler 0 snd 2)) - (r3 (make-sampler 0 snd 3))) - (let ((new-snd (new-sound :channels 2 - :srate (srate snd) - :size (frames snd) - :header-type (header-type snd) - :sample-type (sample-type snd)))) - (map-channel (lambda (y) - (+ (next-sample r0) (next-sample r3))) - 0 (frames snd) new-snd 0) - (map-channel (lambda (y) - (+ (next-sample r1) (next-sample r2))) - 0 (frames snd) new-snd 1) + (r1 (make-sampler 0 snd 1)) + (r2 (make-sampler 0 snd 2)) + (r3 (make-sampler 0 snd 3))) + (let ((new-snd (new-sound :channels 2 + :srate (srate snd) + :size (frames snd) + :header-type (header-type snd) + :sample-type (sample-type snd)))) + (map-channel (lambda (y) (+ (next-sample r0) (next-sample r3))) 0 (frames snd) new-snd 0) + (map-channel (lambda (y) (+ (next-sample r1) (next-sample r2))) 0 (frames snd) new-snd 1) (let* ((mx (apply max (maxamp new-snd #t))) - (scl (/ 0.9 mx))) - (map-channel (lambda (y) (* y scl)) 0 (frames snd) new-snd 0) - (map-channel (lambda (y) (* y scl)) 0 (frames snd) new-snd 1))))) + (scl (/ 0.9 mx))) + (map-channel (lambda (y) (* y scl)) 0 (frames snd) new-snd 0) + (map-channel (lambda (y) (* y scl)) 0 (frames snd) new-snd 1))))) * - * - * Thanks to Michael McNabb for bug fixes and enhancements! - * And thanks to Peter Samson for going back to the schematics to answer our questions! + * Thanks to Michael McNabb for bug fixes and enhancements. + * And thanks to Peter Samson for going back to the schematics to answer our questions. + * Thanks also to David Jaffe for onepole and onezero changes. */ #include <stdlib.h> @@ -54,7 +50,8 @@ #define DEFAULT_DESCRIBE_COMMANDS false #define REPORT_BAD_COMMANDS true #define FLUSH_BAD_COMMANDS false -#define FLUSH_TRAILING_LINGERS false +#define FLUSH_TRAILING_LINGERS true +#define DAJ_FIXES false /* bugfixes involving onepole (see code for discussion) and onezero */ static bool describe_commands = DEFAULT_DESCRIBE_COMMANDS; static int start_describing = -1, stop_describing = -1; @@ -96,7 +93,7 @@ typedef struct { } generator; typedef struct { - int M0, M1, L0, L1, MIN, MRM, MSUM, MMODE, MMMMM, T, mult_scl_1, mult_scl_0, o_M0, o_M1; + int M0, M1, L0, L1, MIN, MRM, MSUM, MMODE, MMMMM, T, mult_scl_1, mult_scl_0, o_M0, o_M1; double f_M0, f_M1, f_L0, f_L1, o_f_M0, o_f_M1; /* by "2nd multiplication" I think Pete means M0 since it follows M1 so AA -> M0 and BB -> M1 */ } modifier; @@ -198,7 +195,7 @@ static void all_done(void) static void dac_write(double data, int chan) { /* during a given pass we accumulate output to the dac */ - dac_out[chan] += (float)(data / 2.0); + dac_out[chan] += (float)(data / 2.0); /* mmm - /2 seems best now that other scalings have been adjusted */ } @@ -219,87 +216,87 @@ static void dac_write(double data, int chan) * AmpOff12 (12 bits) asymptote * OutSum6 (6 bits) sum memory address into which output is added * FmSum7 (7 bits) sum memory address from which frequency modulation data is taken - * FmSum7 = QAAAAAA - * Q: 0 generator-last-pass quadrant - * 1 modifier-last-pass quadrant - * AAAAAA: sum address within quadrant + * FmSum7 = QAAAAAA + * Q: 0 generator-last-pass quadrant + * 1 modifier-last-pass quadrant + * AAAAAA: sum address within quadrant * Gmode10 (10 bits) generator mode - * Gmode10 = RRRREESSSS + * Gmode10 = RRRREESSSS * * Processing * ---------- * - * Calculations performed for a generator, governed by its + * Calculations performed for a generator, governed by its * mode, proceed as detailed below. * * 1) The word in sum memory addressed by FmSum7 is read (20 bits); - * the sum is formed of it and the high-order 20 bits of - * OscFrq28 (call the result FmPhase20). - * + * the sum is formed of it and the high-order 20 bits of + * OscFrq28 (call the result FmPhase20). + * * 2) If the oscillator side is running, FrqSwp20, right-adjusted with - * sign extended, is added into OscFrq28. - * + * sign extended, is added into OscFrq28. + * * 3) If the oscillator mode is SIN(J+Fm), FmPhase20 is taken; otherwise OscAng20. - * Call the 20-bit result Phase20, and its high-order 13 bits - * Phase13. - * + * Call the 20-bit result Phase20, and its high-order 13 bits + * Phase13. + * * 4) If the oscillator side is running, FmPhase20 is added into OscAng20. - * + * * 5) If the run mode is WRITEDATA, the word in sum memory addressed by FmSum7 - * is sent to the CPU as the next write-data item; if the run - * mode is DACOUT it is sent to the DAC addressed by the low-order - * 4 bits of FrqSwp20. - * + * is sent to the CPU as the next write-data item; if the run + * mode is DACOUT it is sent to the DAC addressed by the low-order + * 4 bits of FrqSwp20. + * * 6) In oscillator modes other than SIN(K) and SIN(J+Fm), Phase13 is multiplied - * by NumCos11. Call the low-order 12 bits of the product, with two bits - * equal to 01 appended to the right, the 14-bit result SinAdr. - * In oscillator modes SIN(K) and SIN(J+Fm), SinAdr is the high-order 13 - * bits of Phase20, with a bit equal to 1 appended to the right. - * + * by NumCos11. Call the low-order 12 bits of the product, with two bits + * equal to 01 appended to the right, the 14-bit result SinAdr. + * In oscillator modes SIN(K) and SIN(J+Fm), SinAdr is the high-order 13 + * bits of Phase20, with a bit equal to 1 appended to the right. + * * 7) If the oscillator mode is SIN(K) or SIN(J+Fm), pi/2 is taken (the binary - * number 010...0); otherwise Phase13. Call the result CscAdr. - * + * number 010...0); otherwise Phase13. Call the result CscAdr. + * * 8) In floating point, the product csc (CscAdr) * sin (SinAdr) is - * formed; then converted to fixed point with a scale factor - * of 2**(-CosScl4). Call the result (13 bits) TblOut13. - * - * + * formed; then converted to fixed point with a scale factor + * of 2**(-CosScl4). Call the result (13 bits) TblOut13. + * + * * 9) The result of the oscillator side (13 bits, call it OscOut13) is - * then determined according to the oscillator mode. - * SSSS: SUMCOS TblOut13 - * SAWTOOTH Phase13 (but 0 when Phase13 is 1000000000000) - * SQUARE -1/2 (on a scale from -1 to +1) if Phase13 is negative, - * else +1/2 - * PULSE +1/2 if overflow occurred in step 1) or 4) above; - * else 0. - * SIN(K) TblOut13 - * SIN(J+Fm) TblOut13 - * + * then determined according to the oscillator mode. + * SSSS: SUMCOS TblOut13 + * SAWTOOTH Phase13 (but 0 when Phase13 is 1000000000000) + * SQUARE -1/2 (on a scale from -1 to +1) if Phase13 is negative, + * else +1/2 + * PULSE +1/2 if overflow occurred in step 1) or 4) above; + * else 0. + * SIN(K) TblOut13 + * SIN(J+Fm) TblOut13 + * * 10) The high-order 12 bits of CurAmp24 are taken (call the result CurAmp12). - * + * * 11) If the envelope side is running, AmpSwp20 right-adjusted, sign - * extended, is added into CurAmp24 (overflow dealt with according - * to the run mode). (The overflow condition is CurAmp24 changing - * sign such that the high-order bit of the resultant CurAmp24 equals - * the sign bit of AmpSwp20.) - * + * extended, is added into CurAmp24 (overflow dealt with according + * to the run mode). (The overflow condition is CurAmp24 changing + * sign such that the high-order bit of the resultant CurAmp24 equals + * the sign bit of AmpSwp20.) + * * 12) If the envelope mode is 10 or 11, 2**(-CurAmp12) is looked up; - * otherwise CurAmp12 is taken. Call the resulting 12 bits NewAmp12. - * Scaling is such that if CurAmp12 is 0 then 2**(-CurAmp12) is - * 111 111 111 101 binary; if CurAmp12 is 000 100 000 000 binary, - * then 2**(-CurAmp12) is 011 111 111 110. - * + * otherwise CurAmp12 is taken. Call the resulting 12 bits NewAmp12. + * Scaling is such that if CurAmp12 is 0 then 2**(-CurAmp12) is + * 111 111 111 101 binary; if CurAmp12 is 000 100 000 000 binary, + * then 2**(-CurAmp12) is 011 111 111 110. + * * 13) If the envelope mode is 01 or 11, NewAmp12 is added to AmpOff12; else - * it is subtracted from AmpOff12. This creates Env12, the result - * of the envelope side. - * + * it is subtracted from AmpOff12. This creates Env12, the result + * of the envelope side. + * * 14) OscOut13 is multiplied by Env12. If the run mode specifies adding - * into sum memory, the high-order 19 bits of the rounded product, - * right-adjusted with sign extended, are added into the sum - * memory location designated by OutSum6; except that in run mode - * READDATA, the product is added to the next read-data item from the - * CPU and the sum replaces the contents of the sum memory - * location addressed. + * into sum memory, the high-order 19 bits of the rounded product, + * right-adjusted with sign extended, are added into the sum + * memory location designated by OutSum6; except that in run mode + * READDATA, the product is added to the next read-data item from the + * CPU and the sum replaces the contents of the sum memory + * location addressed. */ #define osc_mode(gmode) (gmode & 0xf) @@ -349,22 +346,22 @@ static void set_osc_run(int gen, int RRRR) if (g->GMODE == 3) g->GMODE = 2; /* if write data, send it to the DAC outputs instead */ } -/* osc. run? env. run? add to sum? - RRRR:0000 inactive no no no - 0001 pause no no no - 1111 running A yes yes, sticky yes - 1110 running B yes yes, free; yes - triggers subseq. - on overflow - 1001 wait yes no no - 1101 running C yes yes, free; yes - stops and - triggers subseq. - on overflow - 0111 read data from computer no yes yes - 0011 write data to computer no no no - 0010 write data to DAC no no no - (address in GO) +/* osc. run? env. run? add to sum? + RRRR:0000 inactive no no no + 0001 pause no no no + 1111 running A yes yes, sticky yes + 1110 running B yes yes, free; yes + triggers subseq. + on overflow + 1001 wait yes no no + 1101 running C yes yes, free; yes + stops and + triggers subseq. + on overflow + 0111 read data from computer no yes yes + 0011 write data to computer no no no + 0010 write data to DAC no no no + (address in GO) */ @@ -406,13 +403,13 @@ static double gen_amp(generator *g) if (osc_run(g->GMODE) == 0) return(0.0); emode = osc_env(g->GMODE); - if ((emode == L_PLUS_2_TO_MINUS_Q) || + if ((emode == L_PLUS_2_TO_MINUS_Q) || (emode == L_MINUS_2_TO_MINUS_Q)) Q = pow(2.0, -16.0 * g->f_GQ); else Q = g->f_GQ; - if ((emode == L_PLUS_Q) || - (emode == L_PLUS_2_TO_MINUS_Q)) + if ((emode == L_PLUS_Q) || + (emode == L_PLUS_2_TO_MINUS_Q)) return(g->f_GL + Q); return(g->f_GL - Q); } @@ -436,7 +433,7 @@ static void process_gen(int gen) #define ShiftOut g->GS generator *g; - double fm, FmPhase20, Phase20, SinAdr, CscAdr, TblOut13, OscOut13, CurAmp12, NewAmp12, Env12, temp; + double fm, FmPhase20, Phase20, SinAdr, CscAdr, TblOut13, OscOut13 = 0.0, CurAmp12, NewAmp12, Env12, temp; g = gens[gen]; if (osc_run(g->GMODE) == 0) /* inactive */ @@ -453,11 +450,11 @@ static void process_gen(int gen) else fm = mod_ins[FmSum7 & 0x3f]; /* fm *= 0.5; */ - FmPhase20 = fm + OscFreq28; - + FmPhase20 = fm + OscFreq28; + if (osc_is_running(Gmode10)) OscFreq28 += (FrqSwp20 / 256.0); /* right adjusted 20 bit */ - + if (osc_mode(Gmode10) == SIN_FM) /* sin(J+fm) */ Phase20 = FmPhase20; else Phase20 = OscAng20; @@ -479,10 +476,10 @@ static void process_gen(int gen) SinAdr = (Phase20 * NumCos11); /* was & 0xfff) << 2) + 1 */ CscAdr = Phase20; if (fmod(CscAdr, 1.0) != 0.0) - temp = sin(M_PI * SinAdr) / sin(M_PI * CscAdr); /* was (1 << 13)) */ + temp = sin(M_PI * SinAdr) / sin(M_PI * CscAdr); /* was (1 << 13)) */ else temp = (double)NumCos11; } - else + else { SinAdr = Phase20; /* was >> 6) | 1 */ temp = sin(M_PI * SinAdr); @@ -495,87 +492,87 @@ static void process_gen(int gen) case SUMCOS: case SIN_K: case SIN_FM: OscOut13 = TblOut13; break; - + case SAWTOOTH: OscOut13 = fmod(Phase20, 2.0) - 1.0; break; case SQUARE: - if (fmod(Phase20, 2.0) < 1.0) - OscOut13 = -0.5; + if (fmod(Phase20, 2.0) < 1.0) + OscOut13 = -0.5; else OscOut13 = 0.5; break; case PULSE: /* pulse mode was primarily used for triggered noise */ if ((OscAng20 >= 2.0) || (OscAng20 < -2.0)) - { - OscAng20 = fmod(OscAng20, 2.0); - OscOut13 = 0.5; - } + { + OscAng20 = fmod(OscAng20, 2.0); + OscOut13 = 0.5; + } else OscOut13 = 0.0; break; } CurAmp12 = CurAmp24; - + if (env_is_running(Gmode10)) { double old_amp; old_amp = CurAmp24; CurAmp24 += (AmpSwp20 / 32.0); /* was 16.0 */ /* mmm - don't know why 32 but it seems to be more accurate than 16 */ /* - The envelope side of the generator can be sticky, which means - that rather than overflow it will stay at the last value it attained - before it would have overflowed; or it can be free, in which case it - wraps around. - - Transitions between run modes can be accomplished in various ways. - 1) A command can output a new GMODE. - 2) A MISC command can specify "clear all pause bits", which - will cause any generator in run mode 0001 to change to - mode 1111. - 3) A MISC command can specify "clear all wait bits", which - will cause any generator in run mode 1001 to change to - mode 1111. - 4) If the envelope side of a generator in run mode 1101 - overflows, that generator goes to run mode 1001. - 5) A generator in run mode 1001 will go to run mode 1101 if - on the same pass the preceding generator (the one - whose generator number is one less) caused a - trigger (was in run mode 1110 or 1101 and envelope - overflowed). + The envelope side of the generator can be sticky, which means + that rather than overflow it will stay at the last value it attained + before it would have overflowed; or it can be free, in which case it + wraps around. + + Transitions between run modes can be accomplished in various ways. + 1) A command can output a new GMODE. + 2) A MISC command can specify "clear all pause bits", which + will cause any generator in run mode 0001 to change to + mode 1111. + 3) A MISC command can specify "clear all wait bits", which + will cause any generator in run mode 1001 to change to + mode 1111. + 4) If the envelope side of a generator in run mode 1101 + overflows, that generator goes to run mode 1001. + 5) A generator in run mode 1001 will go to run mode 1101 if + on the same pass the preceding generator (the one + whose generator number is one less) caused a + trigger (was in run mode 1110 or 1101 and envelope + overflowed). */ if ((CurAmp24 > 1.0) || (CurAmp24 < 0.0)) /* if ((BIT(CurAmp24, 23) != BIT(old_amp, 23)) && (BIT(CurAmp24, 22) == BIT(AmpSwp20, 19))) */ - { - /* overflow */ - if (osc_run(Gmode10) == 15) /* "running A" */ - CurAmp24 = old_amp; - else - { - if (osc_run(Gmode10) == 13) /* "running C" */ - { - set_osc_run(gen, 9); - if (osc_run(gens[gen + 1]->GMODE) == 9) - set_osc_run(gen + 1, 13); - } - else - { - if ((osc_run(Gmode10) == 14) && /* "running B" */ - (osc_run(gens[gen + 1]->GMODE) == 9)) - set_osc_run(gen + 1, 13); - } - } - } - } - - if ((osc_env(Gmode10) == L_PLUS_2_TO_MINUS_Q) || + { + /* overflow */ + if (osc_run(Gmode10) == 15) /* "running A" */ + CurAmp24 = old_amp; + else + { + if (osc_run(Gmode10) == 13) /* "running C" */ + { + set_osc_run(gen, 9); + if (osc_run(gens[gen + 1]->GMODE) == 9) + set_osc_run(gen + 1, 13); + } + else + { + if ((osc_run(Gmode10) == 14) && /* "running B" */ + (osc_run(gens[gen + 1]->GMODE) == 9)) + set_osc_run(gen + 1, 13); + } + } + } + } + + if ((osc_env(Gmode10) == L_PLUS_2_TO_MINUS_Q) || (osc_env(Gmode10) == L_MINUS_2_TO_MINUS_Q)) NewAmp12 = pow(2.0, -16.0 * CurAmp12); else NewAmp12 = CurAmp12; /* was / 4 */ /* mmm - no scaling called for here */ /* I think this matches the spec: - * if temp6 is 0, then 2^(-temp6) is 1, the specs say #b111111111101, + * if temp6 is 0, then 2^(-temp6) is 1, the specs say #b111111111101, * which assuming 12 bit unsigned fractions is 4093/4096, * if temp6 is #b000100000000 (256), 2^(-temp6) is #b011111111110, * which is .5 (fractional) so we really want 2^(-16*temp6) = 2^-1 @@ -585,8 +582,8 @@ static void process_gen(int gen) * This scaling matters in FM since it is a multiplier on the index, and in pluck. */ - if ((osc_env(Gmode10) == L_PLUS_Q) || - (osc_env(Gmode10) == L_PLUS_2_TO_MINUS_Q)) + if ((osc_env(Gmode10) == L_PLUS_Q) || + (osc_env(Gmode10) == L_PLUS_2_TO_MINUS_Q)) Env12 = AmpOff12 + NewAmp12; else Env12 = AmpOff12 - NewAmp12; @@ -594,65 +591,65 @@ static void process_gen(int gen) if (adding_to_sum(Gmode10)) { if (osc_run(Gmode10) != 7) - { - /* "If GS is 0, the high-order 19 bits - of the rounded product are taken, right-adjusted with sign - extended; if GS is 1, the high-order 20 bits of the rounded - product are taken." - */ - if (g->GS == 0) - gen_outs[OutSum6] += OscOut13 / 2.0; /* mmm - right-shifted high order 19 bits so divide by 2 */ - else gen_outs[OutSum6] += OscOut13; /* mmm - no shift, so leave value alone */ - } - else - { - /* read-data: assume we're reading floats from a raw file */ - if (read_data_file) - { - float read_data_value; - fread((void *)(&read_data_value), 4, 1, read_data_file); - gen_outs[OutSum6] = OscOut13 + read_data_value; /* was * 2 */ - /* - "If the run mode - specifies adding into sum memory, Temp9 is added into the sum - memory location designated by GSUM; except that in run mode - 0111, the product is added to the next read-data item from the - CPU and the sum replaces the contents of the sum memory - location addressed." - */ - } - else - { - if (!read_data_warned) - { - fprintf(stderr, "read data?!?\n"); - read_data_warned = true; - } - } - } + { + /* "If GS is 0, the high-order 19 bits + of the rounded product are taken, right-adjusted with sign + extended; if GS is 1, the high-order 20 bits of the rounded + product are taken." + */ + if (g->GS == 0) + gen_outs[OutSum6] += OscOut13 / 2.0; /* mmm - right-shifted high order 19 bits so divide by 2 */ + else gen_outs[OutSum6] += OscOut13; /* mmm - no shift, so leave value alone */ + } + else + { + /* read-data: assume we're reading floats from a raw file */ + if (read_data_file) + { + float read_data_value; + fread((void *)(&read_data_value), 4, 1, read_data_file); + gen_outs[OutSum6] = OscOut13 + read_data_value; /* was * 2 */ + /* + "If the run mode + specifies adding into sum memory, Temp9 is added into the sum + memory location designated by GSUM; except that in run mode + 0111, the product is added to the next read-data item from the + CPU and the sum replaces the contents of the sum memory + location addressed." + */ + } + else + { + if (!read_data_warned) + { + fprintf(stderr, "read data?!?\n"); + read_data_warned = true; + } + } + } } } /* ---------------------------------------- modifier processing ---------------------------------------- */ -/* - * Each modifier has the following numeric parameters. +/* + * Each modifier has the following numeric parameters. * M0 (30 bits) coefficient * M1 (30 bits) other coefficient * L0 (20 bits) running term * L1 (20 bits) other running term * MIN (8 bits) address in sum memory where modifier reads "A" data * MRM (8 bits) address in sum memory where modifier reads "B" data - * MIN, MRM = QQAAAAAA - * QQ: + * MIN, MRM = QQAAAAAA + * QQ: * 00 generator-last-pass quadrant - * 01 modifier-last-pass quadrant - * 10 modifier-this-pass quadrant - * 11 (reserved) + * 01 modifier-last-pass quadrant + * 10 modifier-this-pass quadrant + * 11 (reserved) * AAAAAA: sum address within quadrant * MSUM (7 bits) result address in sum memory - * MSUM = RAAAAAA + * MSUM = RAAAAAA * R: 0 add to sum * 1 replace sum * AAAAAA: sum address in modifier-this-pass quadrant @@ -662,7 +659,7 @@ static void print_mod_read_name(int m) { char *mem_names[4] = {"gen-ins", "mod-ins", "mod-outs", "oops"}; fprintf(stderr, "%s[", mem_names[(m >> 6) & 0x3]); - if (((m & 0x3f) == 0) && (((m >> 6) & 0x3) != 0)) + if (((m & 0x3f) == 0) && (((m >> 6) & 0x3) != 0)) fprintf(stderr, "zero"); else fprintf(stderr, "%d", m & 0x3f); fprintf(stderr, "]"); @@ -680,14 +677,14 @@ static double mod_read(int addr) case 1: return(mod_ins[A]); case 2: return(mod_outs[A]); - case 3: + case 3: /* "reserved", but it seems to happen in MARS.SAM, and Pete says: * - * "Thanks to Al Kossow of the Computer History Museum for putting scans - * of the (preliminary) synthesizer schematics and the theory-of- - * operation manual up on bitsavers.org. + * "Thanks to Al Kossow of the Computer History Museum for putting scans + * of the (preliminary) synthesizer schematics and the theory-of- + * operation manual up on bitsavers.org. * - * It appears that QQ=3 will work the same as QQ=1, i.e. modifier last + * It appears that QQ=3 will work the same as QQ=1, i.e. modifier last * pass quadrant." */ return(mod_ins[A]); @@ -714,7 +711,7 @@ static void mod_write(int addr, double val) /* * MMODE (9 bits) modifier mode - * MMODE = MMMMMAABB + * MMODE = MMMMMAABB * AA: scale of second multiplication * BB: scale of first multiplication * For fraction multiplications: @@ -729,7 +726,7 @@ static void mod_write(int addr, double val) * 11: x 2 * A multiplication involving parameter M1 will be the first * multiplication; one involving M0 will be the second. - * + * * MMMMM: function * 00000: inactive * 00010: uniform noise @@ -737,26 +734,26 @@ static void mod_write(int addr, double val) * 00100: latch * 00110: threshold * 00111: invoke delay unit - * + * * 01000: two poles * 01001: two poles, M0 variable * 01011: two poles, M1 variable * 01100: two zeros * 01101: two zeros, M0 variable * 01111: two zeros, M1 variable - * + * * 10000: integer mixing * 10001: one pole * 10100: mixing * 10110: one zero - * + * * 11000: four-quadrant multiplication * 11001: amplitude modulation * 11010: maximum * 11011: minimum * 11100: signum * 11101: zero-crossing pulser - * + * * others: (reserved) */ @@ -803,16 +800,16 @@ static void process_mod(int mod) A = mod_read(m->MIN); B = mod_read(m->MRM); - + switch (mode) { case M_INACTIVE: - /* 00000: inactive. S := 0 + /* 00000: inactive. S := 0 */ break; case M_NOISE: - /* 00010: uniform noise. S := L0 + L1*M0 (integer multiply, low-order + /* 00010: uniform noise. S := L0 + L1*M0 (integer multiply, low-order * 20 bits of product used; overflow ignored); L1 := S * * see below -- I don't think this is correct. @@ -825,7 +822,7 @@ static void process_mod(int mod) break; case M_TRIGGERED_NOISE: - /* 00011: triggered uniform noise. S := L0 + L1*M0 (integer multiply, + /* 00011: triggered uniform noise. S := L0 + L1*M0 (integer multiply, * low-order 20 bits of product used; overflow ignored); * if B*M1 (integer multiply, low-order 20 bits of product * used; overflow ignored) is not 0, L1 := S @@ -838,54 +835,54 @@ static void process_mod(int mod) IS = (m->L0 + ((m->L1 * m->M0) >> 10)) & 0xfffff; mod_write(m->MSUM, TWOS_20_TO_DOUBLE(IS)); - if ((B != 0.0) && - (m->M1 != 0)) - m->L1 = IS; + if ((B != 0.0) && + (m->M1 != 0)) + m->L1 = IS; break; case M_LATCH: - /* 00100: latch (sample and hold). S := L1; If B*M1 is not 0, L1 := A + /* 00100: latch (sample and hold). S := L1; If B*M1 is not 0, L1 := A * but in the errata: * "BIL has discovered empirically that the modifier latch mode operation should actually read - * 00100: latch (sample and hold). S := L1; If B*M1 is not 0, L1 := A*M0" + * 00100: latch (sample and hold). S := L1; If B*M1 is not 0, L1 := A*M0" */ mod_write(m->MSUM, m->f_L1); if ((B * m->f_M1) != 0.0) m->f_L1 = A * m->f_M0; break; case M_THRESHOLD: - /* 00110: threshold. If A*M0 + L0 is less than 0, then S := 0; + /* 00110: threshold. If A*M0 + L0 is less than 0, then S := 0; * if A*M0 + L0 is equal to or greater than 0, then S := B*M1 */ tmp0 = A * m->f_M0 + m->f_L0; if (tmp0 < 0.0) - mod_write(m->MSUM, 0.0); + mod_write(m->MSUM, 0.0); else mod_write(m->MSUM, B * m->f_M1); break; case M_DELAY: - /* 00111: invoke delay unit. + /* 00111: invoke delay unit. * Unit # := MRM (low-order 5 bits); * S := L0 + L1*M0; L0 := DM; Temp0 := A + DM*M1; * L1 := Temp0; DM := Temp0 */ /* to handle table lookups, we need the integer side here */ /* fprintf(stderr, "d%d, m%d: %.4f = %.4f + %.4f * %.4f\n", m->MRM & 0x1f, mod, m->f_L0 + m->f_L1 * m->f_M0, m->f_L0, m->f_L1, m->f_M0); */ - + mod_write(m->MSUM, m->f_L0 + m->f_L1 * m->f_M0); m->f_L0 = delay_read(m->MRM & 0x1f); m->f_L1 = A + m->f_L0 * m->f_M1; delay_write(m->MRM & 0x1f, m->f_L1); break; - + case M_TWO_POLE: case M_TWO_POLE_M0: case M_TWO_POLE_M1: - /* 01000: two poles. S := L1*M1 + L0*M0 + A; L0 := L1; L1 := S + /* 01000: two poles. S := L1*M1 + L0*M0 + A; L0 := L1; L1 := S * - * 01001: two poles, M0 variable. S := L1*M1 + L0*M0 + A; L0 := L1; L1 := S; M0 := M0 + B + * 01001: two poles, M0 variable. S := L1*M1 + L0*M0 + A; L0 := L1; L1 := S; M0 := M0 + B * - * 01011: two poles, M1 variable. S := L1*M1 + L0*M0 + A; L0 := L1; L1 := S; M1 := M1 + B + * 01011: two poles, M1 variable. S := L1*M1 + L0*M0 + A; L0 := L1; L1 := S; M1 := M1 + B */ tmp0 = m->f_L1 * m->f_M1; tmp1 = m->f_L0 * m->f_M0; @@ -894,22 +891,22 @@ static void process_mod(int mod) m->f_L0 = m->f_L1; m->f_L1 = S; if (mode == M_TWO_POLE_M0) - m->f_M0 += (B / 1024.0); + m->f_M0 += (B / 1024.0); /* "when a quantity is added to M0 or M1 it is added right-justified, with sign extended" * does that include "A" above? I think it does... (see one and two_zero below). */ if (mode == M_TWO_POLE_M1) - m->f_M1 += (B / 1024.0); + m->f_M1 += (B / 1024.0); break; case M_TWO_ZERO: case M_TWO_ZERO_M0: case M_TWO_ZERO_M1: - /* 01100: two zeros. S := L1*M1 + L0*M0 + A; L0 := L1; L1 := A + /* 01100: two zeros. S := L1*M1 + L0*M0 + A; L0 := L1; L1 := A * * 01101: two zeros, M0 variable. S := L1*M1 + L0*M0 + A; L0 := L1; L1 := A; M0 := M0 + B * - * 01101: two zeros, M0 variable. S := L1*M1 + L0*M0 + A; L0 := L1; L1 := A; M1 := M1 + B + * 01101: two zeros, M0 variable. S := L1*M1 + L0*M0 + A; L0 := L1; L1 := A; M1 := M1 + B */ tmp0 = m->f_L1 * m->f_M1; tmp1 = m->f_L0 * m->f_M0; @@ -917,13 +914,13 @@ static void process_mod(int mod) m->f_L0 = m->f_L1; m->f_L1 = A / 1024.0; if (mode == M_TWO_ZERO_M0) - m->f_M0 += (B / 1024.0); + m->f_M0 += (B / 1024.0); if (mode == M_TWO_ZERO_M1) - m->f_M1 += (B / 1024.0); + m->f_M1 += (B / 1024.0); break; case M_INTEGER_MIXING: - /* 10000: integer mixing. S := A*M0 + B*M1 (integer multiply, low-order + /* 10000: integer mixing. S := A*M0 + B*M1 (integer multiply, low-order * 20 bits of product used; overflow ignored) */ /* I don't remember how we used this -- I'll assume the M's are the ints */ @@ -931,47 +928,53 @@ static void process_mod(int mod) break; case M_MIXING: - /* 10100: mixing. S := A*M0 + B*M1 + /* 10100: mixing. S := A*M0 + B*M1 */ mod_write(m->MSUM, A * m->f_M0 + B * m->f_M1); break; case M_ONE_POLE: - /* 10001: one pole. S := L1*M1 + B*M0; L1 := S + /* 10001: one pole. S := L1*M1 + B*M0; L1 := S * * but in the errata: * "DAJ - It seems that the modifier mode one pole is really - * 10001: one pole. S := L1*M1 + B*L0; L1 := S" + * 10001: one pole. S := L1*M1 + B*L0; L1 := S" * * but I think that is incorrect; old reverbs are definitely using the spec form of the 1-pole filter */ tmp0 = m->f_L1 * m->f_M1; - /* tmp1 = B * m->f_L0; */ +#if DAJ_FIXES + tmp1 = B * m->f_L0; +#else tmp1 = B * m->f_M0; - +#endif m->f_L1 = tmp0 + tmp1; mod_write(m->MSUM, m->f_L1); break; - + case M_ONE_ZERO: - /* 10110: one zero. S := L1*M1 + L0*M0; L0 := L1; L1 := A + /* 10110: one zero. S := L1*M1 + L0*M0; L0 := L1; L1 := A */ tmp0 = m->f_L1 * m->f_M1; tmp1 = m->f_L0 * m->f_M0; m->f_L0 = m->f_L1; +#if DAJ_FIXES + m->f_L1 = A; +#else m->f_L1 = A / 1024.0; +#endif mod_write(m->MSUM, tmp0 + tmp1); break; case M_MULTIPLY: - /* 11000: four-quadrant multiplication. S := L1*M1; L1 := A*B + /* 11000: four-quadrant multiplication. S := L1*M1; L1 := A*B */ mod_write(m->MSUM, m->f_L1 * m->f_M1); m->f_L1 = A * B; break; case M_AMP_MOD: - /* 11001: amplitude modulation. S := L1*M1; L1 := A * ((B+1)/2) + /* 11001: amplitude modulation. S := L1*M1; L1 := A * ((B+1)/2) * (The term ((B+1)/2) interprets B as a signed two's-complement * fraction ranging in value from -1 to +1-epsilon.) */ @@ -980,7 +983,7 @@ static void process_mod(int mod) break; case M_MAX: - /* 11010: maximum. S := max (A*M0, B*M1) + /* 11010: maximum. S := max (A*M0, B*M1) */ tmp0 = A * m->f_M0; tmp1 = B * m->f_M1; @@ -988,7 +991,7 @@ static void process_mod(int mod) break; case M_MIN: - /* 11011: minimum. S := min (A*M0, B*M1) + /* 11011: minimum. S := min (A*M0, B*M1) */ tmp0 = A * m->f_M0; tmp1 = B * m->f_M1; @@ -996,7 +999,7 @@ static void process_mod(int mod) break; case M_SIGNUM: - /* 11100: signum. If A*M0 is less than B*M1, then S := -1 (integer) + /* 11100: signum. If A*M0 is less than B*M1, then S := -1 (integer) * if A*M0 equals B*M1, then S := 0; * if A*M0 is greater than B*M1, the S := 1 (integer) */ @@ -1006,9 +1009,9 @@ static void process_mod(int mod) else if (tmp0 == tmp1) mod_write(m->MSUM, 0.0); else mod_write(m->MSUM, TWOS_20_TO_DOUBLE(1)); break; - + case M_ZERO_CROSS: - /* 11101: zero-crossing pulser. Temp0 := B*M0; Temp1 := L1*M1; + /* 11101: zero-crossing pulser. Temp0 := B*M0; Temp1 := L1*M1; * if Temp1 is not 0 and either Temp0 is 0 or Temp0*Temp1 is * negative then S := -epsilon, else S := 0; L1 := Temp0 * (The term -epsilon is a binary number with all bits set.) @@ -1016,8 +1019,8 @@ static void process_mod(int mod) tmp0 = B * m->f_M0; tmp1 = m->f_L1 * m->f_M0; if ((tmp1 != 0) && - ((tmp0 == 0) || (tmp0 * tmp1 < 0))) - mod_write(m->MSUM, TWOS_20_TO_DOUBLE(-1)); + ((tmp0 == 0) || (tmp0 * tmp1 < 0))) + mod_write(m->MSUM, TWOS_20_TO_DOUBLE(-1)); m->f_L1 = tmp0; break; @@ -1031,15 +1034,15 @@ static void process_mod(int mod) /* ---------------------------------------- delay processing ---------------------------------------- */ -/* Each delay unit has the following numeric parameters. - * +/* Each delay unit has the following numeric parameters. + * * P mode (4 bits). The mode is interpreted as follows: - * mode: 0000 inactive - * 1000 delay line - * 1010 table look-up - * 1011 table look-up, argument rounded - * 1100 delay tap - * others: (reserved) + * mode: 0000 inactive + * 1000 delay line + * 1010 table look-up + * 1011 table look-up, argument rounded + * 1100 delay tap + * others: (reserved) */ #define D_INACTIVE 0 @@ -1050,36 +1053,36 @@ static void process_mod(int mod) /* * Z unit length (16 bits) or binary scale factor (4 bits). - * In delay line and delay tap modes, Z gives 1 less than the - * total number of locations in delay memory used by the delay - * unit, i.e. the index of the last delay memory address for - * this unit. In table look-up modes, the low-order four bits - * of Z specify the number of binary places that the argument - * is shifted to the right before it is used to address the - * memory; if rounding is specified, the address after shifting - * is incremented by 1 if the most-significant bit shifted out - * was a 1. - * - * Y index (16 bits). In delay line and delay tap modes, this is the - * running index on the memory area for the unit. - * + * In delay line and delay tap modes, Z gives 1 less than the + * total number of locations in delay memory used by the delay + * unit, i.e. the index of the last delay memory address for + * this unit. In table look-up modes, the low-order four bits + * of Z specify the number of binary places that the argument + * is shifted to the right before it is used to address the + * memory; if rounding is specified, the address after shifting + * is incremented by 1 if the most-significant bit shifted out + * was a 1. + * + * Y index (16 bits). In delay line and delay tap modes, this is the + * running index on the memory area for the unit. + * * X base address (16 bits). The base address is the lowest-numbered - * delay memory location used by this unit. + * delay memory location used by this unit. * - * In inactive mode, delay memory is not modified and the unit + * In inactive mode, delay memory is not modified and the unit * returns indeterminate results. Delay units not accommodated due * to the number of ticks in a pass act as if in the inactive mode. * If the number of processing ticks is 4*n + m where m is 1, 2, or 3, * delay unit number n should be put in the inactive mode. - * - * In delay line mode, a 20-bit data word is received from + * + * In delay line mode, a 20-bit data word is received from * the modifier that calls for the delay unit, and another 20-bit * word is sent to it. The word received is put into the next slot * in the delay line. It will be retrieved and sent back to the * modifier Z+3 passes later. In delay tap mode, a word is sent to * the modifier but delay memory is not written into. * - * In table look-up mode, the 20-bit data word received + * In table look-up mode, the 20-bit data word received * from the modifier is shifted to the right Z bits, bringing in zeros, * and the right 16 bits of the result are used to address the memory * area assigned to the unit. The 20-bit word in the addressed memory @@ -1096,7 +1099,7 @@ static double delay_read(int dly) { case D_INACTIVE: return(0.0); - + case D_LINE: case D_TAP: /* return the value with a hidden 2 sample delay (Z+3 == total delay length + 2) */ @@ -1104,27 +1107,27 @@ static double delay_read(int dly) return(delay_memory[d->X + d->Y]); #else { - /* I originally thought this was making a raspy or crackling sound in the reverbs, but now I don't hear it (bil) */ - double val; - val = d->xd2; - d->xd2 = d->xd1; - d->xd1 = delay_memory[d->X + d->Y]; - return val; + /* I originally thought this was making a raspy or crackling sound in the reverbs, but now I don't hear it (bil) */ + double val; + val = d->xd2; + d->xd2 = d->xd1; + d->xd1 = delay_memory[d->X + d->Y]; + return val; } #endif case D_TABLE_LOOKUP: case D_TABLE_LOOKUP_ROUNDED: { - int Z_shift, dY; - if (!table_read_warned) - { - fprintf(stderr, "table lookup read is unlikely to work.\n"); - table_read_warned = true; - } - Z_shift = d->Z & 0xf; - dY = (d->I >> Z_shift) & 0xffff; - return(delay_memory[d->X + dY]); + int Z_shift, dY; + if (!table_read_warned) + { + fprintf(stderr, "table lookup read is unlikely to work.\n"); + table_read_warned = true; + } + Z_shift = d->Z & 0xf; + dY = (d->I >> Z_shift) & 0xffff; + return(delay_memory[d->X + dY]); } } return(0); @@ -1140,18 +1143,18 @@ static void delay_write(int dly, double val) case D_INACTIVE: case D_TAP: break; - + case D_LINE: delay_memory[d->X + d->Y] = val; break; - + case D_TABLE_LOOKUP: case D_TABLE_LOOKUP_ROUNDED: - if (!table_write_warned) - { - fprintf(stderr, "table lookup write is unlikely to work.\n"); - table_write_warned = true; - } + if (!table_write_warned) + { + fprintf(stderr, "table lookup write is unlikely to work.\n"); + table_write_warned = true; + } d->I = DOUBLE_TO_TWOS_20(val); /* can this work? */ break; } @@ -1176,7 +1179,7 @@ static void linger(int time) { /* process each sample ("pass") until pass == time */ /* but linger was a 20-bit number, so it wrapped around I believe, so pass should be mod 2^20? */ - + if (!snd_file) { fprintf(stderr, "no ticks setting found!\n"); @@ -1192,92 +1195,92 @@ static void linger(int time) */ if ((FLUSH_TRAILING_LINGERS) && - ((total_commands - current_command) < 100) && + ((total_commands - current_command) < 100) && (total_commands > 1000) && ((time - pass) > (6 * srate))) { - fprintf(stderr, "ignore trailing %d sample (%.3f second) linger (%d)\n", - time - pass, (double)(time - pass) / (double)srate, total_commands - current_command); + fprintf(stderr, "ignore trailing %d sample (%.3f second) linger (%d)\n", + time - pass, (double)(time - pass) / (double)srate, total_commands - current_command); pass = time; return; } while (pass < time) { - /* run through all available ticks, processing gen+mod+dly, + /* run through all available ticks, processing gen+mod+dly, * then write accumulated dac_outs, clear, update memories (this-pass -> last-pass), - * and increment pass + * and increment pass */ int i, tick, gen = 0, mod = 0, dly = 0; for (tick = 0; tick < processing_ticks; tick++) - { - /* given the timing info I'll simplify a bit and run 1 gen per tick, 1 mod every 2 ticks, and 1 delay every 4 ticks */ - if (gen < GENERATORS) - process_gen(gen++); + { + /* given the timing info I'll simplify a bit and run 1 gen per tick, 1 mod every 2 ticks, and 1 delay every 4 ticks */ + if (gen < GENERATORS) + process_gen(gen++); - /* I'm guessing... */ - if (((tick & 1) == 0) && - (mod < MODIFIERS)) - process_mod(mod++); + /* I'm guessing... */ + if (((tick & 1) == 0) && + (mod < MODIFIERS)) + process_mod(mod++); - if (((tick & 3) == 0) && - (dly < DELAYS)) - process_dly(dly++); - } + if (((tick & 3) == 0) && + (dly < DELAYS)) + process_dly(dly++); + } if (dump_patch_at == samples) - dump_patch(); + dump_patch(); for (i = 0; i < SUM_MEMORY_SIZE; i++) - { - if (fabs(gen_ins[i]) > peak_gen_ins[i]) - peak_gen_ins[i] = fabs(gen_ins[i]); - prev_gen_ins[i] = gen_ins[i]; - gen_ins[i] = gen_outs[i]; - gen_outs[i] = 0.0; - - if (fabs(mod_ins[i]) > peak_mod_ins[i]) - peak_mod_ins[i] = fabs(mod_ins[i]); - prev_mod_ins[i] = mod_ins[i]; - mod_ins[i] = mod_outs[i]; - mod_outs[i] = 0.0; - } + { + if (fabs(gen_ins[i]) > peak_gen_ins[i]) + peak_gen_ins[i] = fabs(gen_ins[i]); + prev_gen_ins[i] = gen_ins[i]; + gen_ins[i] = gen_outs[i]; + gen_outs[i] = 0.0; + + if (fabs(mod_ins[i]) > peak_mod_ins[i]) + peak_mod_ins[i] = fabs(mod_ins[i]); + prev_mod_ins[i] = mod_ins[i]; + mod_ins[i] = mod_outs[i]; + mod_outs[i] = 0.0; + } fwrite(dac_out, 4, 4, snd_file); samples++; - for (i = 0; i < 4; i++) - { - if (fabs(dac_out[i]) > dac_out_peak[i]) - dac_out_peak[i] = fabs(dac_out[i]); - dac_out[i] = 0.0; - } + for (i = 0; i < 4; i++) + { + if (fabs(dac_out[i]) > dac_out_peak[i]) + dac_out_peak[i] = fabs(dac_out[i]); + dac_out[i] = 0.0; + } pass++; - if (samples == TOTAL_SAMPLES) - all_done(); + if (samples == TOTAL_SAMPLES) + all_done(); } } /* ---------------------------------------- commands ---------------------------------------- */ -/* +/* * ----------------------------------------------------------------- - * : (20) data : 0 0 0 0 0: RR : x x: W: P: S: + * : (20) data : 0 0 0 0 0: RR : x x: W: P: S: * ----------------------------------------------------------------- * MISC * RR: 00 no effect * 01 load DX from data - * 10 load TTL buffer A from left 16 bits of data - * 11 load TTL buffer B from left 16 bits of data - * set analog output filters from right 4 bits of data: - * 01xx Mode 0 - * 00nn Mode 1, frequency f0, f1, f2, or f3 according - * to nn - * W: if 1, clear all wait bits - * P: if 1, clear all pause bits - * S: if 1, stop clock + * 10 load TTL buffer A from left 16 bits of data + * 11 load TTL buffer B from left 16 bits of data + * set analog output filters from right 4 bits of data: + * 01xx Mode 0 + * 00nn Mode 1, frequency f0, f1, f2, or f3 according + * to nn + * W: if 1, clear all wait bits + * P: if 1, clear all pause bits + * S: if 1, stop clock */ static void misc_command(int cmd) @@ -1292,52 +1295,52 @@ static void misc_command(int cmd) S = BIT(cmd, 0); if (describe_commands) - fprintf(stderr, "sam: %d, %s%s%s%s\n", - data, - RR_name[RR], - (W == 1) ? "" : ", clear waits", - (P == 1) ? "" : ", clear pauses", - (S == 1) ? "" : ", stop clock"); + fprintf(stderr, "sam: %d, %s%s%s%s\n", + data, + RR_name[RR], + (W == 1) ? "" : ", clear waits", + (P == 1) ? "" : ", clear pauses", + (S == 1) ? "" : ", stop clock"); if (RR == 1) DX = data; - if (W == 1) + if (W == 1) { /* cause any generator in run mode 1001 to change to mode 1111 */ int i; for (i = 0; i < GENERATORS; i++) - if ((gens[i]) && (osc_run(gens[i]->GMODE) == 9)) - set_osc_run(i, 15); + if ((gens[i]) && (osc_run(gens[i]->GMODE) == 9)) + set_osc_run(i, 15); } - if (P == 1) + if (P == 1) { /* cause any generator in run mode 0001 to change to mode 1111 */ int i; for (i = 0; i < GENERATORS; i++) - if ((gens[i]) && (osc_run(gens[i]->GMODE) == 1)) - set_osc_run(i, 15); + if ((gens[i]) && (osc_run(gens[i]->GMODE) == 1)) + set_osc_run(i, 15); } if (REPORT_BAD_COMMANDS) { - if ((S == 1) && - ((total_commands - current_command) > 1000)) - fprintf(stderr, "sam: %x: stop clock?\n", cmd); + if ((S == 1) && + ((total_commands - current_command) > 1000)) + fprintf(stderr, "sam: %x: stop clock?\n", cmd); } } /* * ----------------------------------------------------------------- - * : (16) data :(4)data: 0 0 0 0 1: U U: (5) unit # : + * : (16) data :(4)data: 0 0 0 0 1: U U: (5) unit # : * ----------------------------------------------------------------- * DLY X, Y, Z - * UU: 00 X 16 bits base address; clear Y - * 01 Y 16 bits one's complement of index - * 10 Z,P 16 bits delay unit size minus 1, or scale (low - * 4 bits of 16); 4 bits mode - * 11 (unused) + * UU: 00 X 16 bits base address; clear Y + * 01 Y 16 bits one's complement of index + * 10 Z,P 16 bits delay unit size minus 1, or scale (low + * 4 bits of 16); 4 bits mode + * 11 (unused) */ static const char *P_name(int P) @@ -1371,11 +1374,11 @@ static void dly_command(int cmd) data_4 = LDB(cmd, 4, 12); data_16 = LDB(cmd, 16, 16); - + d = dlys[unit]; switch (UU) { - case 0: + case 0: d->X = data_16; d->Y = 0; break; @@ -1394,13 +1397,13 @@ static void dly_command(int cmd) { fprintf(stderr, "d%d %s", unit, UU_name[UU]); if (UU == 0) - fprintf(stderr, ": X: %d", d->X); + fprintf(stderr, ": X: %d", d->X); else - { - if (UU == 1) - fprintf(stderr, ": Y: %d", d->Y); - else fprintf(stderr, ": Z: %d, P: %s", d->Z, P_name(d->P)); - } + { + if (UU == 1) + fprintf(stderr, ": Y: %d", d->Y); + else fprintf(stderr, ": Z: %d, P: %s", d->Z, P_name(d->P)); + } fprintf(stderr, "\n"); } } @@ -1408,14 +1411,14 @@ static void dly_command(int cmd) /* * ----------------------------------------------------------------- - * : (20) data : 0 0 0 1 0: x x: T T: x x x: + * : (20) data : 0 0 0 1 0: x x: T T: x x x: * ----------------------------------------------------------------- * TIMER - * TT: 00 no effect - * 10 Linger: process no further commands until pass counter - * equals data - * 11 clear pass counter, then Linger as for 10 - * 01 set pass counter from data + * TT: 00 no effect + * 10 Linger: process no further commands until pass counter + * equals data + * 11 clear pass counter, then Linger as for 10 + * 01 set pass counter from data */ static void timer_command(int cmd) @@ -1431,16 +1434,16 @@ static void timer_command(int cmd) switch (TT) { - case 0: + case 0: break; - case 1: - pass = data; + case 1: + pass = data; break; - case 2: + case 2: linger(data); break; - case 3: - pass = 0; + case 3: + pass = 0; linger(data); break; } @@ -1452,10 +1455,10 @@ static void timer_command(int cmd) * : xxx xxx xxx x : (10) data : 0 0 0 1 1: x x: 0: Q: x x x: * ----------------------------------------------------------------- * TICKS - * Q: 0 designate highest-numbered processing tick per pass - * (should not exceed 255 [See appendix - DAJ]) - * 1 designate next-to-highest-numbered tick (processing - * plus overhead plus update) per pass + * Q: 0 designate highest-numbered processing tick per pass + * (should not exceed 255 [See appendix - DAJ]) + * 1 designate next-to-highest-numbered tick (processing + * plus overhead plus update) per pass */ static bool bit_31_warned = false; @@ -1470,105 +1473,105 @@ static void ticks_command(int cmd) if (REPORT_BAD_COMMANDS) { - if (bit_31 != 0) - { - if (!bit_31_warned) - { - fprintf(stderr, "ticks bit 31 is on?\n"); - bit_31_warned = true; - } - return; /* what is going on here? */ - } + if (bit_31 != 0) + { + if (!bit_31_warned) + { + fprintf(stderr, "ticks bit 31 is on?\n"); + bit_31_warned = true; + } + return; /* what is going on here? */ + } } if (data != 0) /* used at end of some box sequences, but that confuses srate */ { if (Q == 0) - processing_ticks = data + 1; /* mmm - data is highest numbered processing tick per pass, so processing_ticks is 1 greater. */ - else - { - if (srate <= 1) - { - /* mmm - srate can now be set from the command line in certain cases. I had some weird tick settings for some reason. - * mmm - highest_tick_per_pass is actually being set here to the max *number* of ticks per pass, including overhead - */ - highest_tick_per_pass = data + 2; /* why isn't this 9? */ - - /* "It's not clear from the documentation, so to clarify: On the # TICKS - * command, the number to be supplied for Q=1 is the total number of ticks - * per pass minus 2. (TVR - 7 August 1984)" - */ - - /* it's a 10 bit field, and higher bits are ignored, so the slowest we - * can run is 5010Hz or thereabouts - */ - - if (highest_tick_per_pass > GENERATORS) - highest_tick_per_pass = GENERATORS; /* mmm - could it not be higher in some cases? */ - - srate = (int)(1000000000.0 / (double)(highest_tick_per_pass * 195)); - } - else - { - highest_tick_per_pass = (1000000000.0 / (double)srate / 195.0); - } - } + processing_ticks = data + 1; /* mmm - data is highest numbered processing tick per pass, so processing_ticks is 1 greater. */ + else + { + if (srate <= 1) + { + /* mmm - srate can now be set from the command line in certain cases. I had some weird tick settings for some reason. + * mmm - highest_tick_per_pass is actually being set here to the max *number* of ticks per pass, including overhead + */ + highest_tick_per_pass = data + 2; /* why isn't this 9? */ + + /* "It's not clear from the documentation, so to clarify: On the # TICKS + * command, the number to be supplied for Q=1 is the total number of ticks + * per pass minus 2. (TVR - 7 August 1984)" + */ + + /* it's a 10 bit field, and higher bits are ignored, so the slowest we + * can run is 5010Hz or thereabouts + */ + + if (highest_tick_per_pass > GENERATORS) + highest_tick_per_pass = GENERATORS; /* mmm - could it not be higher in some cases? */ + + srate = (int)(1000000000.0 / (double)(highest_tick_per_pass * 195)); + } + else + { + highest_tick_per_pass = (1000000000.0 / (double)srate / 195.0); + } + } } if (describe_commands) { fprintf(stderr, "sam %s: %d", Q_name[Q], data); if (Q == 1) - fprintf(stderr, " (%d Hz)", srate); + fprintf(stderr, " (%d Hz)", srate); fprintf(stderr, "\n"); } if ((data != 0) && (srate != 0)) { if ((snd_file) && (samples == 0) && (Q == 1)) /* 2 tick commands at the start? */ - { - fclose(snd_file); /* start over... */ - snd_file = NULL; - } + { + fclose(snd_file); /* start over... */ + snd_file = NULL; + } if (snd_file == NULL) - { - /* now that we know the sampling rate, open the output file */ - int header_info[24] = {1179011410, 88, 1163280727, 1263424842, - 28, 0, 0, 0, - 0, 0, 0, 0, - 544501094, 16, 262147, 44100, - 705600, 2097168, 1635017060, 16, - 0, 0, 0, 0}; - header_info[15] = srate; - - /* mmm - generate output filename based on input filename */ - { - char *dot; - int i, len; - len = strlen(filename); - output_filename = (char *)malloc(len + 1); - strcpy(output_filename, filename); - /* dot = strchr(output_filename, '.'); - * can be confused by ../test/TEST.SAM - */ - for (i = len - 1; i > 0; i--) - if (filename[i] == '.') - { - dot = (char *)(output_filename + i); - break; - } - strcpy(dot + 1, "wav"); - snd_file = fopen(output_filename, "w"); - } - - if (!snd_file) - { - fprintf(stderr, "can't open test.snd!\n"); - exit(0); - } - fwrite((void *)header_info, 4, 24, snd_file); - } + { + /* now that we know the sampling rate, open the output file */ + int header_info[24] = {1179011410, 88, 1163280727, 1263424842, + 28, 0, 0, 0, + 0, 0, 0, 0, + 544501094, 16, 262147, 44100, + 705600, 2097168, 1635017060, 16, + 0, 0, 0, 0}; + header_info[15] = srate; + + /* mmm - generate output filename based on input filename */ + { + char *dot = NULL; + int i, len; + len = strlen(filename); + output_filename = (char *)malloc(len + 1); + strcpy(output_filename, filename); + /* dot = strchr(output_filename, '.'); + * can be confused by ../test/TEST.SAM + */ + for (i = len - 1; i > 0; i--) + if (filename[i] == '.') + { + dot = (char *)(output_filename + i); + break; + } + strcpy(dot + 1, "wav"); + snd_file = fopen(output_filename, "w"); + } + + if (!snd_file) + { + fprintf(stderr, "can't open test.snd!\n"); + exit(0); + } + fwrite((void *)header_info, 4, 24, snd_file); + } } } @@ -1580,15 +1583,18 @@ static int last_GMODE_command = 0; * GQ : (20) data : 0 0 1: E: (8) gen # : * ----------------------------------------------------------------- * - * E: 0 Q right-adjusted, sign extended - * 1 Q left-adjusted, low bits from left of DX; clear DX + * E: 0 Q right-adjusted, sign extended + * 1 Q left-adjusted, low bits from left of DX; clear DX */ static void gq_command(int cmd) { /* GQ is 24 bits */ - int data, E, gen, old_DX = 0, old_GQ; + int data, E, gen, old_DX = 0; +#if 0 + int old_GQ; double old_f_GQ; +#endif generator *g; char *E_name[2] = {"right adjusted", "left adjusted + DX"}; @@ -1597,20 +1603,22 @@ static void gq_command(int cmd) data = LDB(cmd, 20, 12); g = gens[gen]; +#if 0 old_GQ = g->GQ; old_f_GQ = g->f_GQ; +#endif /* spec says "sign extended" which makes me think this number is signed, but I think it is unsigned in exp modes */ /* mmm - I also believe it is unsigned. */ - /* pete: - * Hmm, it looks like it makes more sense to call it unsigned. Certainly - * the multiplication of envelope times waveform treats the envelope as - * unsigned (i.e. non-negative). + /* pete: + * Hmm, it looks like it makes more sense to call it unsigned. Certainly + * the multiplication of envelope times waveform treats the envelope as + * unsigned (i.e. non-negative). */ if (E == 0) - g->GQ = data; /* mmm */ - else + g->GQ = data; /* mmm */ + else { g->GQ = (data << 4) | ((DX >> 16) & 0xf); /* mmm */ old_DX = DX; @@ -1622,24 +1630,24 @@ static void gq_command(int cmd) if (describe_commands) { if (E == 0) - fprintf(stderr, "g%d amp: %s, %d %.4f\n", gen, E_name[E], g->GQ, g->f_GQ); + fprintf(stderr, "g%d amp: %s, %d %.4f\n", gen, E_name[E], g->GQ, g->f_GQ); else fprintf(stderr, "g%d amp: %s, %d = %d %.4f (DX: %d)\n", gen, E_name[E], data, g->GQ, g->f_GQ, old_DX); } #if 0 - if ((gen_is_active(g)) && + if ((gen_is_active(g)) && (samples > last_GMODE_command)) { if (REPORT_BAD_COMMANDS) - fprintf(stderr, "sample %d (%.3f), command %d, stray amp: g%d %.4f from %.4f (last mode sample: %d)\n", - samples, (double)samples / (double)srate, current_command, - gen, g->f_GQ, old_f_GQ, - last_GMODE_command); + fprintf(stderr, "sample %d (%.3f), command %d, stray amp: g%d %.4f from %.4f (last mode sample: %d)\n", + samples, (double)samples / (double)srate, current_command, + gen, g->f_GQ, old_f_GQ, + last_GMODE_command); if (FLUSH_BAD_COMMANDS) - { - g->GQ = old_GQ; - g->f_GQ = old_f_GQ; - } + { + g->GQ = old_GQ; + g->f_GQ = old_f_GQ; + } } #endif } @@ -1650,8 +1658,8 @@ static void gq_command(int cmd) * GJ : (20) data : 0 1 0: E: (8) gen # : * ----------------------------------------------------------------- * - * E: 0 J right-adjusted, sign extended - * 1 J left-adjusted, low bits from left of DX; clear DX + * E: 0 J right-adjusted, sign extended + * 1 J left-adjusted, low bits from left of DX; clear DX */ static void gj_command(int cmd) @@ -1672,7 +1680,7 @@ static void gj_command(int cmd) if (E == 0) g->GJ = TWOS_20(data); - else + else { g->GJ = TWOS_28(((data << 8) + (DX >> 12))); /* need 28 - 20 = 8 bits? */ old_DX = DX; @@ -1684,25 +1692,26 @@ static void gj_command(int cmd) if (describe_commands) { if (E == 0) - fprintf(stderr, "g%d freq: %s, %d %.4f (%.4f Hz)\n", gen, E_name[E], g->GJ, g->f_GJ, g->f_GJ * 0.5 * srate); + fprintf(stderr, "g%d freq: %s, %d %.4f (%.4f Hz)\n", gen, E_name[E], g->GJ, g->f_GJ, g->f_GJ * 0.5 * srate); else fprintf(stderr, "g%d freq: %s (DX: %d), %d = %d %.4f (%.4f Hz)\n", gen, E_name[E], old_DX, data, g->GJ, g->f_GJ, g->f_GJ * 0.5 * srate); } - if ((gen_is_active(g)) && - (g->GJ != old_GJ) && + if ((gen_is_active(g)) && + (g->GJ != old_GJ) && (samples > last_GMODE_command)) { +#if (!DAJ_FIXES) if (REPORT_BAD_COMMANDS) - fprintf(stderr, "sample %d (%.3f), command %d, stray freq: g%d %.4f from %.4f (last mode sample: %d), data: %d\n", - samples, (double)samples / (double)srate, current_command, - gen, g->f_GJ * 0.5 * srate, DOUBLE_28(old_GJ) * 0.5 *srate, - last_GMODE_command, data); - + fprintf(stderr, "sample %d (%.3f), command %d, stray freq: g%d %.4f from %.4f (last mode sample: %d), data: %d\n", + samples, (double)samples / (double)srate, current_command, + gen, g->f_GJ * 0.5 * srate, DOUBLE_28(old_GJ) * 0.5 *srate, + last_GMODE_command, data); +#endif if (FLUSH_BAD_COMMANDS) - { - g->GJ = old_GJ; - g->f_GJ = old_f_GJ; - } + { + g->GJ = old_GJ; + g->f_GJ = old_f_GJ; + } } } @@ -1738,12 +1747,12 @@ static void gp_command(int cmd) * GM, :N:M:S S:x: (11) GN :(4) GM : 0 1 1 1: (8) gen # : * GS ----------------------------------------------------------------- * - * N: if 1, disable loading GN - * M: if 1, disable loading GM - * SS: 00 clear GS to 0 - * 01 set GS to 1 - * 10 no effect - * 11 (reserved) + * N: if 1, disable loading GN + * M: if 1, disable loading GM + * SS: 00 clear GS to 0 + * 01 set GS to 1 + * 10 no effect + * 11 (reserved) */ static void gn_command(int cmd) @@ -1762,17 +1771,17 @@ static void gn_command(int cmd) if (describe_commands) { if (N == 1) - { - if (M == 1) - fprintf(stderr, "g%d sum-memory shift:%s\n", gen, SS_name[SS]); - else fprintf(stderr, "g%d ncos scale: %d%s\n", gen, GM, SS_name[SS]); - } + { + if (M == 1) + fprintf(stderr, "g%d sum-memory shift:%s\n", gen, SS_name[SS]); + else fprintf(stderr, "g%d ncos scale: %d%s\n", gen, GM, SS_name[SS]); + } else - { - if (M == 1) - fprintf(stderr, "g%d ncos: %d%s\n", gen, GN, SS_name[SS]); - else fprintf(stderr, "g%d ncos: %d%s, scale: %d\n", gen, GN, SS_name[SS], GM); - } + { + if (M == 1) + fprintf(stderr, "g%d ncos: %d%s\n", gen, GN, SS_name[SS]); + else fprintf(stderr, "g%d ncos: %d%s, scale: %d\n", gen, GN, SS_name[SS], GM); + } } g = gens[gen]; @@ -1800,8 +1809,8 @@ static void gn_command(int cmd) * GL, :L:S: (12) GL : (6) GSUM : 1 0 0 0: (8) gen # : * GSUM ----------------------------------------------------------------- * - * L: if 1, disable loading GL - * S: if 1, disable loading GSUM + * L: if 1, disable loading GL + * S: if 1, disable loading GSUM */ static void gl_command(int cmd) @@ -1836,34 +1845,34 @@ static void gl_command(int cmd) if (describe_commands) { if (L == 1) - { - if (S == 1) - fprintf(stderr, "g%d: noop\n", gen); - else fprintf(stderr, "g%d outloc: gen-outs[%d]\n", gen, g->GSUM); - } + { + if (S == 1) + fprintf(stderr, "g%d: noop\n", gen); + else fprintf(stderr, "g%d outloc: gen-outs[%d]\n", gen, g->GSUM); + } else - { - if (S == 0) - fprintf(stderr, "g%d amp offset: %d = %.4f\n", gen, g->GL, g->f_GL); - else fprintf(stderr, "g%d outloc: gen-outs[%d] + amp offset: %d = %.4f\n", gen, g->GSUM, g->GL, g->f_GL); - } + { + if (S == 0) + fprintf(stderr, "g%d amp offset: %d = %.4f\n", gen, g->GL, g->f_GL); + else fprintf(stderr, "g%d outloc: gen-outs[%d] + amp offset: %d = %.4f\n", gen, g->GSUM, g->GL, g->f_GL); + } } if (REPORT_BAD_COMMANDS) { if ((GL == 1) && (L == 1) && (S == 0)) - fprintf(stderr, "sample %d (%.3f), command %d, possible gen output loc overflow: g%d %d\n", - samples, (double)samples / (double)srate, current_command, - gen, GSUM); - - if ((gen_is_active(g)) && - (g->GSUM != old_GSUM) && - (samples > last_GMODE_command) && - (S == 0)) - fprintf(stderr, "sample %d (%.3f), command %d, stray output loc: g%d %d from %d (last mode sample: %d)\n", - samples, (double)samples / (double)srate, current_command, - gen, g->GSUM, old_GSUM, - last_GMODE_command); + fprintf(stderr, "sample %d (%.3f), command %d, possible gen output loc overflow: g%d %d\n", + samples, (double)samples / (double)srate, current_command, + gen, GSUM); + + if ((gen_is_active(g)) && + (g->GSUM != old_GSUM) && + (samples > last_GMODE_command) && + (S == 0)) + fprintf(stderr, "sample %d (%.3f), command %d, stray output loc: g%d %d from %d (last mode sample: %d)\n", + samples, (double)samples / (double)srate, current_command, + gen, g->GSUM, old_GSUM, + last_GMODE_command); } } @@ -1894,19 +1903,19 @@ static void gk_command(int cmd) if (describe_commands) fprintf(stderr, "g%d phase: %d %.4f\n", gen, g->GK, g->f_GK); - if ((gen_is_active(g)) && + if ((gen_is_active(g)) && (samples > last_GMODE_command)) { if (REPORT_BAD_COMMANDS) - fprintf(stderr, "sample %d (%.3f), command %d, stray phase: g%d %.4f (last mode sample: %d)\n", - samples, (double)samples / (double)srate, current_command, - gen, g->f_GK, - last_GMODE_command); + fprintf(stderr, "sample %d (%.3f), command %d, stray phase: g%d %.4f (last mode sample: %d)\n", + samples, (double)samples / (double)srate, current_command, + gen, g->f_GK, + last_GMODE_command); if (FLUSH_BAD_COMMANDS) - { - g->GK = old_GK; - g->f_GK = old_f_GK; - } + { + g->GK = old_GK; + g->f_GK = old_f_GK; + } } } @@ -1917,32 +1926,32 @@ static void gk_command(int cmd) * :M:F:C: (10) GMODE :(7) GFM: 1 0 1 0: (8) gen # : * ----------------------------------------------------------------- * GMODE, - * GFM M: if 1, disable loading GMODE - * F: if 1, disable loading GFM - * C: if 1, clear GK + * GFM M: if 1, disable loading GMODE + * F: if 1, disable loading GFM + * C: if 1, clear GK */ static bool bad_mode(int mode) { - int R, E, S; + int R, S; R = osc_run(mode); - E = osc_env(mode); + /* E = osc_env(mode); */ S = osc_mode(mode); if ((R != 2) && (R != 7) && (R != 3) && (R != 0)) switch (S) { - case SUMCOS: case SAWTOOTH: case SQUARE: case PULSE: case SIN_K: case SIN_FM: - break; - default: - return(true); + case SUMCOS: case SAWTOOTH: case SQUARE: case PULSE: case SIN_K: case SIN_FM: + break; + default: + return(true); } switch (R) { - case 0: case 1: case 15: case 14: case 9: case 13: case 7: case 3: case 2: + case 0: case 1: case 15: case 14: case 9: case 13: case 7: case 3: case 2: break; - default: + default: return(true); } @@ -1969,16 +1978,16 @@ static void print_gmode_name(int mode) if ((R != 2) && (R != 7) && (R != 3)) { switch (S) - { - case SUMCOS: fprintf(stderr, "ncos"); break; - case SAWTOOTH: fprintf(stderr, "saw"); break; - case SQUARE: fprintf(stderr, "square"); break; - case PULSE: fprintf(stderr, "pulse"); break; - case SIN_K: fprintf(stderr, "sin"); break; - case SIN_FM: fprintf(stderr, "sin+fm"); break; - default: fprintf(stderr, "unknown"); break; - } - + { + case SUMCOS: fprintf(stderr, "ncos"); break; + case SAWTOOTH: fprintf(stderr, "saw"); break; + case SQUARE: fprintf(stderr, "square"); break; + case PULSE: fprintf(stderr, "pulse"); break; + case SIN_K: fprintf(stderr, "sin"); break; + case SIN_FM: fprintf(stderr, "sin+fm"); break; + default: fprintf(stderr, "unknown"); break; + } + fprintf(stderr, "-%s-", E_name[E]); } @@ -2032,65 +2041,65 @@ static void gmode_command(int cmd) { fprintf(stderr, "g%d ", gen); if (M == 0) - { - fprintf(stderr, "mode: "); - print_gmode_name(g->GMODE); - } + { + fprintf(stderr, "mode: "); + print_gmode_name(g->GMODE); + } if (F == 0) - { - if (M == 0) fprintf(stderr, ", "); - fprintf(stderr, "inloc: %s[%d]", ((g->GFM >> 6) == 0) ? "gen-ins" : "mod-ins", g->GFM & 0x3f); - } + { + if (M == 0) fprintf(stderr, ", "); + fprintf(stderr, "inloc: %s[%d]", ((g->GFM >> 6) == 0) ? "gen-ins" : "mod-ins", g->GFM & 0x3f); + } if (C == 1) - { - if ((M == 0) || (F == 0)) - fprintf(stderr, ", "); - fprintf(stderr, "clear phase"); - } + { + if ((M == 0) || (F == 0)) + fprintf(stderr, ", "); + fprintf(stderr, "clear phase"); + } fprintf(stderr, "\n"); } if (REPORT_BAD_COMMANDS) { if (bad_mode(GMODE)) - fprintf(stderr, "sample %d (%.3f), command %d, bad mode: g%d %x\n", - samples, (double)samples / (double)srate, current_command, - gen, GMODE); + fprintf(stderr, "sample %d (%.3f), command %d, bad mode: g%d %x\n", + samples, (double)samples / (double)srate, current_command, + gen, GMODE); if ((gen_is_active(g)) && - (gen >= processing_ticks)) - fprintf(stderr, "sample %d (%.3f), command %d, g%d cannot actually run (procticks: %d)\n", - samples, (double)samples / (double)srate, current_command, - gen, processing_ticks); - + (gen >= processing_ticks)) + fprintf(stderr, "sample %d (%.3f), command %d, g%d cannot actually run (procticks: %d)\n", + samples, (double)samples / (double)srate, current_command, + gen, processing_ticks); + #if 0 if ((gen_was_active) && - (!gen_is_active(g)) && - (g->f_GQ != 0.0)) - fprintf(stderr, "sample %d (%.3f), command %d, g%d turned off with amp %.4f\n", - samples, (double)samples / (double)srate, current_command, - gen, g->f_GQ); + (!gen_is_active(g)) && + (g->f_GQ != 0.0)) + fprintf(stderr, "sample %d (%.3f), command %d, g%d turned off with amp %.4f\n", + samples, (double)samples / (double)srate, current_command, + gen, g->f_GQ); #endif - - if ((gen_was_active) && - ((g->GFM != old_GFM) || (g->GMODE != old_GMODE)) && - (samples > last_GMODE_command)) - { - if (g->GFM != old_GFM) - fprintf(stderr, "sample %d (%.3f), command %d, stray input loc: g%d %d from %d (last mode sample: %d)\n", - samples, (double)samples / (double)srate, current_command, - gen, g->GFM, old_GFM, - last_GMODE_command); - else - { - fprintf(stderr, "sample %d (%.3f), command %d, stray mode: g%d ", - samples, (double)samples / (double)srate, current_command, gen); - print_gmode_name(g->GMODE); - fprintf(stderr, " from "); - print_gmode_name(old_GMODE); - fprintf(stderr, " (last mode sample: %d)\n", last_GMODE_command); - } - } + + if ((gen_was_active) && + ((g->GFM != old_GFM) || (g->GMODE != old_GMODE)) && + (samples > last_GMODE_command)) + { + if (g->GFM != old_GFM) + fprintf(stderr, "sample %d (%.3f), command %d, stray input loc: g%d %d from %d (last mode sample: %d)\n", + samples, (double)samples / (double)srate, current_command, + gen, g->GFM, old_GFM, + last_GMODE_command); + else + { + fprintf(stderr, "sample %d (%.3f), command %d, stray mode: g%d ", + samples, (double)samples / (double)srate, current_command, gen); + print_gmode_name(g->GMODE); + fprintf(stderr, " from "); + print_gmode_name(old_GMODE); + fprintf(stderr, " (last mode sample: %d)\n", last_GMODE_command); + } + } } } @@ -2117,9 +2126,9 @@ static void go_command(int cmd) if (describe_commands) { if (osc_run(g->GMODE) == 2) - fprintf(stderr, "g%d DAC out: %d\n", gen, data); - else fprintf(stderr, "g%d freq change: %d %.4f (%.4f Hz/sec), freq: %.4f\n", - gen, g->GO, g->f_GO, g->f_GO * 0.5 * srate * srate / 256.0, g->f_GJ * srate * 0.5); + fprintf(stderr, "g%d DAC out: %d\n", gen, data); + else fprintf(stderr, "g%d freq change: %d %.4f (%.4f Hz/sec), freq: %.4f\n", + gen, g->GO, g->f_GO, g->f_GO * 0.5 * srate * srate / 256.0, g->f_GJ * srate * 0.5); } } @@ -2130,10 +2139,10 @@ static void go_command(int cmd) * MM : (20) data : 1 1 0: V V: (7) mod # : * ----------------------------------------------------------------- * - * VV: 00 M0 right-adjusted, sign extended - * 01 M1 right-adjusted, sign extended - * 10 M0 left-adjusted, low bits from left of DX; clear DX - * 11 M1 left-adjusted, low bits from left of DX; clear DX + * VV: 00 M0 right-adjusted, sign extended + * 01 M1 right-adjusted, sign extended + * 10 M0 left-adjusted, low bits from left of DX; clear DX + * 11 M1 left-adjusted, low bits from left of DX; clear DX */ /* To avoid endless repetition in the modifier processing, I'll incorporate the scalers @@ -2199,22 +2208,22 @@ static void mm_command(int cmd) if (describe_commands) { switch (VV) - { - case 0: - fprintf(stderr, "m%d M0: %d: %d %.6f\n", mod, data, m->M0, m->f_M0); - break; - case 1: - fprintf(stderr, "m%d M1: %d: %d %.6f\n", mod, data, m->M1, m->f_M1); - break; - case 2: - fprintf(stderr, "m%d M0+DX: data: %d + DX: %d (scl: %d), %d -> %d, %.6f -> %.6f\n", - mod, data, old_DX, m->mult_scl_0, m->o_M0, m->M0, m->o_f_M0, m->f_M0); - break; - case 3: - fprintf(stderr, "m%d M1+DX: data: %d + DX: %d (scl: %d), %d -> %d, %.6f -> %.6f\n", - mod, data, old_DX, m->mult_scl_1, m->o_M1, m->M1, m->o_f_M1, m->f_M1); - break; - } + { + case 0: + fprintf(stderr, "m%d M0: %d: %d %.6f\n", mod, data, m->M0, m->f_M0); + break; + case 1: + fprintf(stderr, "m%d M1: %d: %d %.6f\n", mod, data, m->M1, m->f_M1); + break; + case 2: + fprintf(stderr, "m%d M0+DX: data: %d + DX: %d (scl: %d), %d -> %d, %.6f -> %.6f\n", + mod, data, old_DX, m->mult_scl_0, m->o_M0, m->M0, m->o_f_M0, m->f_M0); + break; + case 3: + fprintf(stderr, "m%d M1+DX: data: %d + DX: %d (scl: %d), %d -> %d, %.6f -> %.6f\n", + mod, data, old_DX, m->mult_scl_1, m->o_M1, m->M1, m->o_f_M1, m->f_M1); + break; + } } } @@ -2225,8 +2234,8 @@ static void mm_command(int cmd) * ML : (20) data : 1 1 1 0: N: (7) mod # : * ----------------------------------------------------------------- * - * N: 0 L0 - * 1 L1 + * N: 0 L0 + * 1 L1 */ static void ml_command(int cmd) @@ -2244,7 +2253,7 @@ static void ml_command(int cmd) m->L0 = TWOS_20(data); m->f_L0 = DOUBLE_20(m->L0); } - else + else { m->L1 = TWOS_20(data); m->f_L1 = DOUBLE_20(m->L1); @@ -2253,7 +2262,7 @@ static void ml_command(int cmd) if (describe_commands) { if (N == 0) - fprintf(stderr, "m%d L0: %d: %d %.6f\n", mod, data, m->L0, m->f_L0); + fprintf(stderr, "m%d L0: %d: %d %.6f\n", mod, data, m->L0, m->f_L0); else fprintf(stderr, "m%d L1: %d: %d %.6f\n", mod, data, m->L1, m->f_L1); } } @@ -2266,10 +2275,10 @@ static void ml_command(int cmd) * ----------------------------------------------------------------- * * MMODE, - * MSUM M: if 1, disable loading MMMMM bits of MMODE - * S: if 1, disable loading MSUM - * C: if 1, clear L0 - * H: if 1, disable loading AABB bits of MMODE + * MSUM M: if 1, disable loading MMMMM bits of MMODE + * S: if 1, disable loading MSUM + * C: if 1, clear L0 + * H: if 1, disable loading AABB bits of MMODE */ static const char *mode_name(int m) @@ -2340,48 +2349,48 @@ static void mmode_command(int cmd) m->f_M1 = m->o_f_M1 * m->mult_scl_1; if (M == 0) - m->MMODE = MMODE; /* set both */ + m->MMODE = MMODE; /* set both */ else m->MMODE = (MMODE & 0xf) + (m->MMODE & 0x1f0); /* H is 0, so set AABB */ } else { if (M == 0) - m->MMODE = (MMODE & 0x1f0) + (m->MMODE & 0xf); /* M is 0, so set MMMMM */ + m->MMODE = (MMODE & 0x1f0) + (m->MMODE & 0xf); /* M is 0, so set MMMMM */ } if (describe_commands) { fprintf(stderr, "m%d ", mod); if (M == 0) - fprintf(stderr, "mode: %s", mode_name(MMODE >> 4)); + fprintf(stderr, "mode: %s", mode_name(MMODE >> 4)); if (H == 0) - { - if (M == 0) - fprintf(stderr, ", "); - fprintf(stderr, "AA: %d, BB: %d (M0: %d, %.3f, M1: %d, %.3f)", (MMODE >> 2) & 0x3, MMODE & 0x3, m->M0, m->f_M0, m->M1, m->f_M1); - } + { + if (M == 0) + fprintf(stderr, ", "); + fprintf(stderr, "AA: %d, BB: %d (M0: %d, %.3f, M1: %d, %.3f)", (MMODE >> 2) & 0x3, MMODE & 0x3, m->M0, m->f_M0, m->M1, m->f_M1); + } if (S == 0) - { - if ((H == 0) || (M == 0)) - fprintf(stderr, ", "); - fprintf(stderr, "outloc(%s): mod-outs[%d]", ((MSUM >> 6) == 0) ? "+" : "=", MSUM & 0x3f); - } + { + if ((H == 0) || (M == 0)) + fprintf(stderr, ", "); + fprintf(stderr, "outloc(%s): mod-outs[%d]", ((MSUM >> 6) == 0) ? "+" : "=", MSUM & 0x3f); + } if (C == 1) - { - if ((S == 0) || (H == 0) || (M == 0)) - fprintf(stderr, ", "); - fprintf(stderr, "L0=0"); - } + { + if ((S == 0) || (H == 0) || (M == 0)) + fprintf(stderr, ", "); + fprintf(stderr, "L0=0"); + } fprintf(stderr, "\n"); } if (REPORT_BAD_COMMANDS) { if (((MMODE >> 4) != M_INACTIVE) && - ((mod * 2) >= processing_ticks)) - fprintf(stderr, "sample %d (%.3f), command %d, m%d cannot actually run (procticks: %d)\n", - samples, (double)samples / (double)srate, current_command, - mod, processing_ticks); + ((mod * 2) >= processing_ticks)) + fprintf(stderr, "sample %d (%.3f), command %d, m%d cannot actually run (procticks: %d)\n", + samples, (double)samples / (double)srate, current_command, + mod, processing_ticks); } } @@ -2393,12 +2402,12 @@ static void mmode_command(int cmd) * ----------------------------------------------------------------- * * MRM, - * MIN, R: if 1, disable loading MRM - * MT I: if 1, disable loading MIN - * CC: 00 turn off truncation - * 01 turn on truncation - * 10 clear L1 - * 11 no effect + * MIN, R: if 1, disable loading MRM + * MT I: if 1, disable loading MIN + * CC: 00 turn off truncation + * 01 turn on truncation + * 10 clear L1 + * 11 no effect */ static void mrm_command(int cmd) @@ -2421,7 +2430,7 @@ static void mrm_command(int cmd) switch (CC) { - case 0: + case 0: m->T = 0; break; @@ -2439,20 +2448,20 @@ static void mrm_command(int cmd) { fprintf(stderr, "m%d inlocs:", mod); if (R == 0) - { - if (mod_mode(m->MMODE) == M_DELAY) - fprintf(stderr, ", delay: %d", MRM & 0x1f); - else - { - fprintf(stderr, ", MRM: "); - print_mod_read_name(MRM); - } - } + { + if (mod_mode(m->MMODE) == M_DELAY) + fprintf(stderr, ", delay: %d", MRM & 0x1f); + else + { + fprintf(stderr, ", MRM: "); + print_mod_read_name(MRM); + } + } if (I == 0) - { - fprintf(stderr, ", MIN: "); - print_mod_read_name(MIN); - } + { + fprintf(stderr, ", MIN: "); + print_mod_read_name(MIN); + } if (CC == 0) fprintf(stderr, ", trunc off"); if (CC == 1) fprintf(stderr, ", trunc on"); if (CC == 2) fprintf(stderr, ", L1=0"); @@ -2472,69 +2481,69 @@ static void handle_command(int cmd) else describe_commands = DEFAULT_DESCRIBE_COMMANDS; op = LDB(cmd, 4, 8); - + switch (op) { - case 0: + case 0: if (BIT(cmd, 7) == 1) - dly_command(cmd); + dly_command(cmd); else misc_command(cmd); break; case 1: if (BIT(cmd, 7) == 1) - ticks_command(cmd); + ticks_command(cmd); else timer_command(cmd); break; - case 2: case 3: - gq_command(cmd); + case 2: case 3: + gq_command(cmd); break; - case 4: case 5: - gj_command(cmd); + case 4: case 5: + gj_command(cmd); break; - case 6: - gp_command(cmd); + case 6: + gp_command(cmd); break; - case 7: - gn_command(cmd); + case 7: + gn_command(cmd); break; case 8: gl_command(cmd); break; - case 9: - gk_command(cmd); + case 9: + gk_command(cmd); break; - case 10: + case 10: gmode_command(cmd); break; - case 11: + case 11: go_command(cmd); break; - case 12: case 13: + case 12: case 13: mm_command(cmd); break; - case 14: + case 14: ml_command(cmd); break; - case 15: + case 15: if (BIT(cmd, 7) == 0) - mmode_command(cmd); + mmode_command(cmd); else mrm_command(cmd); break; - default: - fprintf(stderr, "impossible command\n"); + default: + fprintf(stderr, "impossible command\n"); break; } @@ -2551,12 +2560,12 @@ static void dump_gens(void) for (i = 0; i < GENERATORS; i++) if (gens[i]->GMODE != 0) fprintf(stderr, "g%d GMODE: %d, %d [%.3f] -> %d [%.3f], GQ: %.3f, GP: %.3f, GL: %.3f, GJ: %.3f, GO: %.3f, GN: %d, GS: %d\n", - i, - gens[i]->GMODE, - gens[i]->GFM, ((gens[i]->GFM >> 6) == 0) ? gen_ins[gens[i]->GFM & 0x3f] : mod_ins[gens[i]->GFM & 0x3f], - gens[i]->GSUM, gen_outs[gens[i]->GSUM], - gens[i]->f_GQ, gens[i]->f_GP, gens[i]->f_GL, gens[i]->f_GJ, gens[i]->f_GO, - gens[i]->GN, gens[i]->GS); + i, + gens[i]->GMODE, + gens[i]->GFM, ((gens[i]->GFM >> 6) == 0) ? gen_ins[gens[i]->GFM & 0x3f] : mod_ins[gens[i]->GFM & 0x3f], + gens[i]->GSUM, gen_outs[gens[i]->GSUM], + gens[i]->f_GQ, gens[i]->f_GP, gens[i]->f_GL, gens[i]->f_GJ, gens[i]->f_GO, + gens[i]->GN, gens[i]->GS); } @@ -2566,12 +2575,12 @@ static void dump_mods(void) for (i = 0; i < MODIFIERS; i++) if (mods[i]->MMODE != 0) fprintf(stderr, "m%d MMODE: %d, (%d [%.3f] %d [%.3f]) -> %d [%.3f], M0: %.3f, M1: %.3f, L0: %.3f, L1: %.3f\n", - i, - mods[i]->MMODE, - mods[i]->MIN, mod_read(mods[i]->MIN), - mods[i]->MRM, mod_read(mods[i]->MRM), - mods[i]->MSUM, mod_outs[mods[i]->MSUM], - mods[i]->f_M0, mods[i]->f_M1, mods[i]->f_L0, mods[i]->f_L1); + i, + mods[i]->MMODE, + mods[i]->MIN, mod_read(mods[i]->MIN), + mods[i]->MRM, mod_read(mods[i]->MRM), + mods[i]->MSUM, mod_outs[mods[i]->MSUM], + mods[i]->f_M0, mods[i]->f_M1, mods[i]->f_L0, mods[i]->f_L1); } #endif @@ -2582,8 +2591,8 @@ static void dump_gen_sum(int addr) fprintf(stderr, "g-sum%d: %.3f %.3f %.3f [max: %.3f]", addr, prev_gen_ins[addr], gen_ins[addr], gen_outs[addr], peak_gen_ins[addr]); for (i = 0; i < GENERATORS; i++) - if ((gens[i]->GMODE != 0) && - (gens[i]->GSUM == addr)) + if ((gens[i]->GMODE != 0) && + (gens[i]->GSUM == addr)) fprintf(stderr, " g%d", i); } @@ -2595,8 +2604,8 @@ static void dump_mod_sum(int addr) fprintf(stderr, "m-sum%d: %.3f %.3f %.3f [max: %.3f]", addr, prev_mod_ins[addr], mod_ins[addr], mod_outs[addr], peak_mod_ins[addr]); for (i = 0; i < MODIFIERS; i++) - if ((mod_mode(mods[i]->MMODE) != M_INACTIVE) && - ((mods[i]->MSUM &0x3f) == addr)) + if ((mod_mode(mods[i]->MMODE) != M_INACTIVE) && + ((mods[i]->MSUM &0x3f) == addr)) fprintf(stderr, " m%d", i); } @@ -2607,28 +2616,28 @@ static void print_mod_sum(int addr) loc = addr & 0x3f; switch ((addr >> 6) & 0x3) { - case 0: + case 0: fprintf(stderr, "["); dump_gen_sum(loc); break; case 1: fprintf(stderr, "["); if (loc == 0) - { - if ((prev_mod_ins[0] != 0.0) || (mod_ins[0] != 0.0) || (mod_outs[0] != 0.0) || (peak_mod_ins[0] != 0)) - dump_mod_sum(0); - else fprintf(stderr, "zero"); - } + { + if ((prev_mod_ins[0] != 0.0) || (mod_ins[0] != 0.0) || (mod_outs[0] != 0.0) || (peak_mod_ins[0] != 0)) + dump_mod_sum(0); + else fprintf(stderr, "zero"); + } else dump_mod_sum(loc); break; case 2: fprintf(stderr, "-out["); if (loc == 0) - { - if ((prev_mod_ins[0] != 0.0) || (mod_ins[0] != 0.0) || (mod_outs[0] != 0.0) || (peak_mod_ins[0] != 0)) - dump_mod_sum(0); - else fprintf(stderr, "zero"); - } + { + if ((prev_mod_ins[0] != 0.0) || (mod_ins[0] != 0.0) || (mod_outs[0] != 0.0) || (peak_mod_ins[0] != 0)) + dump_mod_sum(0); + else fprintf(stderr, "zero"); + } else dump_mod_sum(loc); break; case 3: @@ -2643,16 +2652,16 @@ static int gen_mem_readers(int addr) int i, rds = 0; for (i = 0; i < GENERATORS; i++) if ((gens[i]->GMODE != 0) && - (gens[i]->GFM == addr)) /* Q bit 0 = gen */ + (gens[i]->GFM == addr)) /* Q bit 0 = gen */ rds++; for (i = 0; i < MODIFIERS; i++) if (mod_mode(mods[i]->MMODE) != M_INACTIVE) { if (mods[i]->MIN == addr) /* QQ bits = 0 = gen */ - rds++; + rds++; if ((mod_mode(mods[i]->MMODE) != M_DELAY) && - (mods[i]->MRM == addr)) - rds++; + (mods[i]->MRM == addr)) + rds++; } return(rds); } @@ -2663,18 +2672,18 @@ static int mod_mem_readers(int addr) int i, rds = 0; for (i = 0; i < GENERATORS; i++) if ((gens[i]->GMODE != 0) && - (gens[i]->GFM == 64 + addr)) /* Q bit 1 = mod */ + (gens[i]->GFM == 64 + addr)) /* Q bit 1 = mod */ rds++; for (i = 0; i < MODIFIERS; i++) if (mod_mode(mods[i]->MMODE) != M_INACTIVE) { if ((mods[i]->MIN == 64 + addr) || - (mods[i]->MIN == 128 + addr)) - rds++; + (mods[i]->MIN == 128 + addr)) + rds++; if ((mod_mode(mods[i]->MMODE) != M_DELAY) && - ((mods[i]->MRM == 64 + addr) || - (mods[i]->MRM == 128 + addr))) - rds++; + ((mods[i]->MRM == 64 + addr) || + (mods[i]->MRM == 128 + addr))) + rds++; } return(rds); } @@ -2696,7 +2705,7 @@ static void dump_patch(void) if (mod_mode(mods[i]->MMODE) != M_INACTIVE) p++; fprintf(stderr, "active mods: %d, ", p); - + for (i = 0, p = 0; i < DELAYS; i++) if (dlys[i]->P != 0) p++; @@ -2705,82 +2714,82 @@ static void dump_patch(void) for (i = 0; i < GENERATORS; i++) if (gens[i]->GMODE != 0) { - generator *g; - g = gens[i]; - fprintf(stderr, "g%d ", i); - print_gmode_name(g->GMODE); - - fprintf(stderr, " ["); - if ((g->GFM >> 6) == 0) - dump_gen_sum(g->GFM & 0x3f); - else print_mod_sum(g->GFM); - - fprintf(stderr, "]->["); - if (osc_run(g->GMODE) == 2) - fprintf(stderr, "OUT%d", g->GO & 0xf); - else dump_gen_sum(g->GSUM); - - fprintf(stderr, " (%d)], (amp: %.3f, freq: %.3f", - gen_mem_readers(g->GSUM), - gen_amp(g), - g->f_GJ * 0.5 * srate); - if (g->f_GJ == 0.0) - fprintf(stderr, ", phase: %.3f", g->f_GK); - - fprintf(stderr, ")\n"); + generator *g; + g = gens[i]; + fprintf(stderr, "g%d ", i); + print_gmode_name(g->GMODE); + + fprintf(stderr, " ["); + if ((g->GFM >> 6) == 0) + dump_gen_sum(g->GFM & 0x3f); + else print_mod_sum(g->GFM); + + fprintf(stderr, "]->["); + if (osc_run(g->GMODE) == 2) + fprintf(stderr, "OUT%d", g->GO & 0xf); + else dump_gen_sum(g->GSUM); + + fprintf(stderr, " (%d)], (amp: %.3f, freq: %.3f", + gen_mem_readers(g->GSUM), + gen_amp(g), + g->f_GJ * 0.5 * srate); + if (g->f_GJ == 0.0) + fprintf(stderr, ", phase: %.3f", g->f_GK); + + fprintf(stderr, ")\n"); } fprintf(stderr, "\n"); for (i = 0; i < MODIFIERS; i++) if (mod_mode(mods[i]->MMODE) != M_INACTIVE) { - modifier *m; - m = mods[i]; - fprintf(stderr, "m%d %s ", i, mode_name(mod_mode(m->MMODE))); - - if (mod_mode(m->MMODE) == M_MIXING) - fprintf(stderr, "%.4f * ", m->f_M0); - fprintf(stderr, "A"); - print_mod_sum(m->MIN); - fprintf(stderr, "], "); - - if (mod_mode(m->MMODE) == M_MIXING) - fprintf(stderr, "%.4f * ", m->f_M1); - fprintf(stderr, "B"); - if (mod_mode(m->MMODE) == M_DELAY) - { - delay *d; - d = dlys[m->MRM & 0x1f]; - fprintf(stderr, "[delay: %d (%.4f)", m->MRM & 0x1f, delay_memory[d->X + d->Y]); - fprintf(stderr, ", M0: %.4f, M1: %.4f, L0: %.4f, L1: %.4f", m->f_M0, m->f_M1, m->f_L0, m->f_L1); - } - else print_mod_sum(m->MRM); - - fprintf(stderr, "]->["); - if ((m->MSUM >> 6) != 0) - fprintf(stderr, "-replace"); - dump_mod_sum(m->MSUM & 0x3f); - - fprintf(stderr, " (%d)]\n", mod_mem_readers(m->MSUM)); + modifier *m; + m = mods[i]; + fprintf(stderr, "m%d %s ", i, mode_name(mod_mode(m->MMODE))); + + if (mod_mode(m->MMODE) == M_MIXING) + fprintf(stderr, "%.4f * ", m->f_M0); + fprintf(stderr, "A"); + print_mod_sum(m->MIN); + fprintf(stderr, "], "); + + if (mod_mode(m->MMODE) == M_MIXING) + fprintf(stderr, "%.4f * ", m->f_M1); + fprintf(stderr, "B"); + if (mod_mode(m->MMODE) == M_DELAY) + { + delay *d; + d = dlys[m->MRM & 0x1f]; + fprintf(stderr, "[delay: %d (%.4f)", m->MRM & 0x1f, delay_memory[d->X + d->Y]); + fprintf(stderr, ", M0: %.4f, M1: %.4f, L0: %.4f, L1: %.4f", m->f_M0, m->f_M1, m->f_L0, m->f_L1); + } + else print_mod_sum(m->MRM); + + fprintf(stderr, "]->["); + if ((m->MSUM >> 6) != 0) + fprintf(stderr, "-replace"); + dump_mod_sum(m->MSUM & 0x3f); + + fprintf(stderr, " (%d)]\n", mod_mem_readers(m->MSUM)); } fprintf(stderr, "\n"); for (i = 0; i < DELAYS; i++) if (dlys[i]->P != D_INACTIVE) { - delay *d; - d = dlys[i]; - fprintf(stderr, "d%d %s %.3f (%d + %d of %d)\n", - i, P_name(d->P), - delay_memory[d->X + d->Y], - d->X, d->Y, d->Z); + delay *d; + d = dlys[i]; + fprintf(stderr, "d%d %s %.3f (%d + %d of %d)\n", + i, P_name(d->P), + delay_memory[d->X + d->Y], + d->X, d->Y, d->Z); } { double dmax; dmax = fabs(delay_memory[0]); for (i = 1; i < DELAY_MEMORY_SIZE; i++) if (fabs(delay_memory[i]) > dmax) - dmax = fabs(delay_memory[i]); + dmax = fabs(delay_memory[i]); fprintf(stderr, "delay memory peak: %.4f\n\n", dmax); } } @@ -2800,115 +2809,115 @@ int main(int argc, char **argv) sam_file = fopen(filename, "r"); if (!sam_file) - fprintf(stderr, "can't find %s\n", filename); + fprintf(stderr, "can't find %s\n", filename); else - { - long size; - fseek(sam_file, 0, SEEK_END); - size = ftell(sam_file); - rewind(sam_file); - - if (size <= 0) - { - fprintf(stderr, "%s is empty\n", filename); - fclose(sam_file); - } - else - { - size_t bytes; - unsigned char *command; - int i; - - if (argc > 2) - { - read_data_file = fopen(argv[2], "r"); - if (argc > 3) - { - /* mmm - set srate explicitly. I had an inexplicably high max tick setting in one sam file with read data input. */ - sscanf(argv[3], "%d", &srate); - } - } - - start_clean(); - - command = (unsigned char *)calloc(size + 1, sizeof(unsigned char)); - bytes = fread(command, sizeof(unsigned char), size, sam_file); - fclose(sam_file); - - /* these were stored in at least 2 different formats - * - * FASTF.SAM: "Type: 32BITR BADSAM ;Looks like a SAM command file but has questionable data" - * MACDON.SAM: "Type: SAM SIMPLE ;Simple SAM command file (corresponding sound file possible)" - * - * FASTF was written as 32 bits (using the 1st case below), and MACDON as 36 (using the 2nd case). - * it looks like someone got a flag backwards, and wrote the known-good 32-bit files as 36, - * and the possibly not-32 bit files as 32. I can't find the corresponding code in the writers - * that Nando found on the exabyte tapes. - * - * The *.SAM.snd files are raw big-endian 24-bit int data (stereo?) - * with many (6?) renditions? - */ + { + long size; + fseek(sam_file, 0, SEEK_END); + size = ftell(sam_file); + rewind(sam_file); + + if (size <= 0) + { + fprintf(stderr, "%s is empty\n", filename); + fclose(sam_file); + } + else + { + size_t bytes; + unsigned char *command; + int i; + + if (argc > 2) + { + read_data_file = fopen(argv[2], "r"); + if (argc > 3) + { + /* mmm - set srate explicitly. I had an inexplicably high max tick setting in one sam file with read data input. */ + sscanf(argv[3], "%d", &srate); + } + } + + start_clean(); + + command = (unsigned char *)calloc(size + 1, sizeof(unsigned char)); + bytes = fread(command, sizeof(unsigned char), size, sam_file); + fclose(sam_file); + + /* these were stored in at least 2 different formats + * + * FASTF.SAM: "Type: 32BITR BADSAM ;Looks like a SAM command file but has questionable data" + * MACDON.SAM: "Type: SAM SIMPLE ;Simple SAM command file (corresponding sound file possible)" + * + * FASTF was written as 32 bits (using the 1st case below), and MACDON as 36 (using the 2nd case). + * it looks like someone got a flag backwards, and wrote the known-good 32-bit files as 36, + * and the possibly not-32 bit files as 32. I can't find the corresponding code in the writers + * that Nando found on the exabyte tapes. + * + * The *.SAM.snd files are raw big-endian 24-bit int data (stereo?) + * with many (6?) renditions? + */ #if 1 - if ((command[0] != 0) || /* just a first guess */ - (command[1] != 0)) - { - fprintf(stderr, "32\n"); - total_commands = bytes / 4; - current_command = 0; - for (i = 0; i < bytes; i += 4) - { - int cmd; - int b1, b2, b3, b4; - b1 = command[i + 0]; - b2 = command[i + 1]; - b3 = command[i + 2]; - b4 = command[i + 3]; - cmd = b4 + (b3 << 8) + (b2 << 16) + (b1 << 24); - handle_command(cmd); - } - } - else - { - fprintf(stderr, "36\n"); - total_commands = bytes / 5; - current_command = 0; - for (i = 0; i < bytes; i += 5) - { - int cmd; - int b1, b2, b3, b4, b5; - b1 = command[i + 0]; - b2 = command[i + 1]; - b3 = command[i + 2]; - b4 = command[i + 3]; - b5 = command[i + 4]; - cmd = ((b5 >> 4) & 0xff) + (b4 << 4) + (b3 << 12) + (b2 << 20) + ((b1 & 0xff) << 28); - handle_command(cmd); - } - } + if ((command[0] != 0) || /* just a first guess */ + (command[1] != 0)) + { + fprintf(stderr, "32\n"); + total_commands = (int)(bytes / 4); + current_command = 0; + for (i = 0; i < bytes; i += 4) + { + int cmd; + int b1, b2, b3, b4; + b1 = command[i + 0]; + b2 = command[i + 1]; + b3 = command[i + 2]; + b4 = command[i + 3]; + cmd = b4 + (b3 << 8) + (b2 << 16) + (b1 << 24); + handle_command(cmd); + } + } + else + { + fprintf(stderr, "36\n"); + total_commands = (int)(bytes / 5); + current_command = 0; + for (i = 0; i < bytes; i += 5) + { + int cmd; + int b1, b2, b3, b4, b5; + b1 = command[i + 0]; + b2 = command[i + 1]; + b3 = command[i + 2]; + b4 = command[i + 3]; + b5 = command[i + 4]; + cmd = ((b5 >> 4) & 0xff) + (b4 << 4) + (b3 << 12) + (b2 << 20) + ((b1 & 0xff) << 28); + handle_command(cmd); + } + } #else - /* another format that Mike used: - * cmd = (b1 << 28) | (b2 << 24) | (b3 << 16) | (b4 << 8) | b5; - */ - total_commands = bytes / 5; - current_command = 0; - for (i = 0; i < bytes; i += 5) - { - int cmd; - int b1, b2, b3, b4, b5; - b1 = command[i + 0]; - b2 = command[i + 1]; - b3 = command[i + 2]; - b4 = command[i + 3]; - b5 = command[i + 4]; - cmd = (b1 << 28) | (b2 << 24) | (b3 << 16) | (b4 << 8) | b5; - handle_command(cmd); - } + /* another format that Mike used: + * cmd = (b1 << 28) | (b2 << 24) | (b3 << 16) | (b4 << 8) | b5; + */ + total_commands = (int)(bytes / 5); + current_command = 0; + for (i = 0; i < bytes; i += 5) + { + int cmd; + int b1, b2, b3, b4, b5; + b1 = command[i + 0]; + b2 = command[i + 1]; + b3 = command[i + 2]; + b4 = command[i + 3]; + b5 = command[i + 4]; + cmd = (b1 << 28) | (b2 << 24) | (b3 << 16) | (b4 << 8) | b5; + handle_command(cmd); + } #endif - } - - all_done(); - } + } + + all_done(); + } } return(0); } diff --git a/tools/t101.scm b/tools/t101.scm index 26a565b..f041688 100644 --- a/tools/t101.scm +++ b/tools/t101.scm @@ -3,7 +3,7 @@ (define aux-counter 0) (system "make-repl") -(let ((aux-file (format #f "t101-aux-~D.scm" (set! aux-counter (+ aux-counter 1))))) +(let ((aux-file (format #f "t101-~D.scm" (set! aux-counter (+ aux-counter 1))))) (call-with-output-file aux-file (lambda (p) (format p "(define aux-counter ~D)\n" aux-counter) @@ -12,7 +12,7 @@ (format *stderr* "~%~NC~%test: safety=1~%" 80 #\-) (system (string-append "./repl " aux-file))) -(let ((aux-file (format #f "t101-aux-~D.scm" (set! aux-counter (+ aux-counter 1))))) +(let ((aux-file (format #f "t101-~D.scm" (set! aux-counter (+ aux-counter 1))))) (call-with-output-file aux-file (lambda (p) (format p "(define aux-counter ~D)\n" aux-counter) @@ -23,7 +23,7 @@ (for-each (lambda (test-case) - (let ((aux-file (format #f "t101-aux-~D.scm" (set! aux-counter (+ aux-counter 1))))) + (let ((aux-file (format #f "t101-~D.scm" (set! aux-counter (+ aux-counter 1))))) (call-with-output-file aux-file (lambda (p) (format p "(define aux-counter ~D)\n" aux-counter) @@ -32,7 +32,7 @@ (format p "(load \"s7test.scm\")~%(exit)~%"))) (format *stderr* "~%~NC~%test: ~S~%" 80 #\- test-case) (system (string-append "./repl " aux-file)))) - (list + (list "`(ok? ',tst (lambda () (eval ',tst)) ,expected)" "`(ok? ',tst (lambda () ,tst) ,expected)" "`(ok? ',tst (#_let () (define (_s7_) ,tst)) ,expected)" @@ -48,7 +48,7 @@ ;; "`(ok? ',tst (lambda () (#_let ((__x__ #f)) (define (__f__) (do ((__i__ 0 (+ __i__ 1))) ((= __i__ 2) __x__) (set! __x__ ,tst))) (__f__))) ,expected)" "`(ok? ',tst (lambda () (define (!f!) (#_let ((!v! (vector #f))) (do ((!i! 0 (+ !i! 1))) ((= !i! 1) (!v! 0)) (vector-set! !v! 0 ,tst)))) (!f!)) ,expected)" "`(ok? ',tst (lambda () (define (!f!) (#_let ((!v! #f)) (do ((!i! 0 (+ !i! 1))) ((= !i! 1) !v!) (set! !v! ,tst)))) (!f!)) ,expected)" - "`(ok? ',tst (lambda () (define (!f!) (#_let ((!x! (map (lambda (!a!) ,tst) '(0)))) (if (pair? !x!) (car !x!) :no-value))) (!f!)) ,expected)" + "`(ok? ',tst (lambda () (define (!f!) (#_let ((!x! (map (lambda (!a!) ,tst) '(0)))) (if (pair? !x!) (car !x!) #<no-value>))) (!f!)) ,expected)" "`(ok? ',tst (lambda () (define (!f!) (#_let ((!x! #f)) (for-each (lambda (!a!) (set! !x! ,tst)) '(0)) !x!)) (!f!)) ,expected)" "`(ok? ',tst (lambda () (call-with-exit (lambda (!a!) (!a! ,tst)))) ,expected)" "`(ok? ',tst (lambda () (call/cc (lambda (!a!) (!a! ,tst)))) ,expected)" @@ -79,7 +79,7 @@ ;; "`(ok? ',tst (lambda () (let ((!x 0)) (let-temporarily ((!x ,tst)) !x))) ,expected)" )) -(let ((aux-file (format #f "t101-aux-~D.scm" (set! aux-counter (+ aux-counter 1))))) +(let ((aux-file (format #f "t101-~D.scm" (set! aux-counter (+ aux-counter 1))))) (call-with-output-file aux-file (lambda (p) (format p "(define aux-counter ~D)\n" aux-counter) @@ -88,7 +88,7 @@ (format *stderr* "~%~NC~%test: debug=1~%" 80 #\-) (system (string-append "./repl " aux-file))) -(let ((aux-file (format #f "t101-aux-~D.scm" (set! aux-counter (+ aux-counter 1))))) +(let ((aux-file (format #f "t101-~D.scm" (set! aux-counter (+ aux-counter 1))))) (call-with-output-file aux-file (lambda (p) (format p "(define aux-counter ~D)\n" aux-counter) @@ -97,7 +97,7 @@ (format *stderr* "~%~NC~%test: debug=2~%" 80 #\-) (system (string-append "./repl " aux-file))) -(let ((aux-file (format #f "t101-aux-~D.scm" (set! aux-counter (+ aux-counter 1))))) +(let ((aux-file (format #f "t101-~D.scm" (set! aux-counter (+ aux-counter 1))))) (call-with-output-file aux-file (lambda (p) (format p "(define aux-counter ~D)\n" aux-counter) @@ -113,7 +113,7 @@ (define-macro (test tst expected) (let ((_call_ (gensym)) (_caller_ (gensym))) - `(ok? ',tst + `(ok? ',tst (lambda () (define (,_caller_) (,_call_ ,tst)) (define (,_call_ x) x) @@ -124,14 +124,14 @@ (define-macro (num-test tst expected) (let ((_call_ (gensym)) (_caller_ (gensym))) - `(nok? ',tst + `(nok? ',tst (lambda () (define (,_caller_) (,_call_ ,tst)) (define (,_call_ x) x) (,_caller_) (,_caller_)) ,expected))) - + (load "s7test.scm") |# @@ -149,7 +149,7 @@ (system "gcc -o ffitest ffitest.c -g -Wall s7.o -lm -I.") (system "ffitest")) ))) - + ;(format *stderr* "~%~NC lint ~NC~%" 20 #\- 20 #\-) ;(catch #t (lambda () (lint "snd-test.scm" #f)) (lambda (type info) (apply format #t info))) diff --git a/tools/tform.scm b/tools/tform.scm index 9107ffe..6ae67c3 100644 --- a/tools/tform.scm +++ b/tools/tform.scm @@ -146,6 +146,435 @@ )) (f) +(exit) + +;;; -------------------------------------------------------------------------------- +;;; these tests are not currently used + +(define size 1000000) + +(define (f1) ; [116] -> [78] (fixed c_function_chooser) -> [54] opt_p_call_cc + (let ((str "")) + (do ((i 0 (+ i 1))) + ((= i size) str) + (set! str (format #f "just a bare string!"))))) ; ~% is turned into \n so that doesn't cost anything + +;(unless (string=? (f1) "just a bare string!") (format *stderr* "f1: ~S~%" (f1))) + +#| +15,951,020 s7.c:opt_dotimes [/home/bil/motif-snd/repl] +11,000,000 s7.c:opt_p_call_cc [/home/bil/motif-snd/repl] + 9,000,000 s7.c:g_format_just_control_string [/home/bil/motif-snd/repl] + 9,000,000 s7.c:opt_set_p_p_f [/home/bil/motif-snd/repl] + 6,895,119 s7.c:gc.isra.0 [/home/bil/motif-snd/repl] +|# + + +(define (f2) ; [309] -> [277 opt_p_call_ccs] + (let ((str "asdf") + (res "")) + (do ((i 0 (+ i 1))) + ((= i size) res) + (set! res (format #f "~a" str))))) ; isn't this just copy? (for a string) and opt_p_call_ccs + +;(unless (string=? (f2) "asdf") (format *stderr* "f2: ~S~%" (f2))) + +#| +67,538,352 s7.c:s7_object_to_string [/home/bil/motif-snd/repl] +46,000,000 s7.c:string_to_port [/home/bil/motif-snd/repl] +36,000,164 s7.c:block_to_string [/home/bil/motif-snd/repl] +29,103,257 s7.c:gc.isra.0 [/home/bil/motif-snd/repl] +24,000,000 s7.c:string_write_string [/home/bil/motif-snd/repl] +15,951,020 s7.c:opt_dotimes [/home/bil/motif-snd/repl] +15,149,728 memcpy +15,000,000 s7.c:g_format_as_objstr [/home/bil/motif-snd/repl] +15,000,000 s7.c:opt_p_call_ccs [/home/bil/motif-snd/repl] + 9,000,000 s7.c:opt_set_p_p_f [/home/bil/motif-snd/repl] +|# + + +(define (f3) ; [469] + (let ((str "asdf") + (res "")) + (do ((i 0 (+ i 1))) + ((= i size) res) + (set! res (format #f "str: ~A" str))))) ; maybe extend g_format_as_objstr to include prestring? + +;(unless (string=? (f3) "str: asdf") (format *stderr* "f3: ~S~%" (f3))) + +#| +237,610,187 s7.c:format_to_port_1 [/home/bil/motif-snd/repl] + 46,000,000 s7.c:string_to_port [/home/bil/motif-snd/repl] + 30,149,775 memcpy + 29,103,615 s7.c:gc.isra.0 [/home/bil/motif-snd/repl] + 29,000,000 s7.c:g_format_no_column [/home/bil/motif-snd/repl] + 24,000,000 s7.c:string_write_string [/home/bil/motif-snd/repl] + 21,001,261 strchr + 15,951,020 s7.c:opt_dotimes [/home/bil/motif-snd/repl] + 15,000,000 s7.c:opt_p_call_ccs [/home/bil/motif-snd/repl] + 9,000,000 s7.c:opt_set_p_p_f [/home/bil/motif-snd/repl] +|# + + +(define (f4) ; [717] + (let ((str "asdf") + (res "")) + (do ((i 0 (+ i 1))) + ((= i size) res) + (set! res (format #f "str: ~A ~C" str (string-ref str 0)))))) + +;(unless (string=? (f4) "str: asdf a") (format *stderr* "f4: ~S~%" (f4))) + +#| +333,610,119 s7.c:format_to_port_1 [/home/bil/motif-snd/repl] + 71,000,000 s7.c:opt_p_call_any [/home/bil/motif-snd/repl] ; ccsc ideally + 46,149,893 memcpy + 46,000,000 s7.c:string_to_port [/home/bil/motif-snd/repl] + 42,001,811 strchr + 29,104,716 s7.c:gc.isra.0 [/home/bil/motif-snd/repl] + 29,000,000 s7.c:g_format_no_column [/home/bil/motif-snd/repl] + 24,000,000 s7.c:string_write_string [/home/bil/motif-snd/repl] + 18,000,000 s7.c:string_write_char [/home/bil/motif-snd/repl] + 15,951,020 s7.c:opt_dotimes [/home/bil/motif-snd/repl] + 10,000,000 s7.c:string_ref_p_pi_unchecked [/home/bil/motif-snd/repl] ; str not set so string-ref is constant + 9,000,000 s7.c:opt_set_p_p_f [/home/bil/motif-snd/repl] + 8,000,000 s7.c:opt_p_pi_sc [/home/bil/motif-snd/repl] ; calls string_ref_p_pi_unchecked + 6,002,360 ? + 6,000,000 format_to_port_1? + 6,000,000 s7.c:opt_p_c [/home/bil/motif-snd/repl] ; for opt_p_pi_sc! why not just embed it? + 4,000,098 ? + 4,000,004 ./ctype/../include/ctype.h:__ctype_b_loc [/usr/lib/x86_64-linux-gnu/libc.so.6] + 4,000,000 s7.c:opt_p_s [/home/bil/motif-snd/repl] +|# + + +(define (f5) ; [666] + (let ((str (list 1 2 3)) + (res "") + (size2 (/ size 2))) + (do ((i 0 (+ i 1))) + ((= i size2) res) + (set! res (format #f "(~{~A~^ ~})" str))))) + +;(unless (string=? (f5) "(1 2 3)") (format *stderr* "f5: ~S~%" (f5))) + +#| +256,000,000 s7.c:format_to_port_1'2 [/home/bil/motif-snd/repl] +204,109,962 s7.c:format_to_port_1 [/home/bil/motif-snd/repl] + 58,500,000 s7.c:integer_to_port [/home/bil/motif-snd/repl] + 27,000,000 s7.c:string_write_char [/home/bil/motif-snd/repl] + 15,650,121 ./string/../sysdeps/x86_64/multiarch/memmove-vec-unaligned-erms.S:__memcpy_avx_unaligned_erms [/usr/lib/x86_64-linux-gnu/libc.so.6] + 15,000,000 /usr/include/x86_64-linux-gnu/bits/string_fortified.h:integer_to_port + 14,500,000 s7.c:g_format_no_column [/home/bil/motif-snd/repl] + 14,113,341 s7.c:gc.isra.0 [/home/bil/motif-snd/repl] + 12,000,584 s7.c:s7_list_length [/home/bil/motif-snd/repl] + 11,000,000 s7.c:object_to_list [/home/bil/motif-snd/repl] + 10,502,830 ./string/../sysdeps/x86_64/multiarch/strchr-avx2.S:__strchr_avx2 [/usr/lib/x86_64-linux-gnu/libc.so.6] + 7,950,972 s7.c:opt_dotimes [/home/bil/motif-snd/repl] + 7,500,000 s7.c:opt_p_call_ccs [/home/bil/motif-snd/repl] + 4,500,000 s7.c:opt_set_p_p_f [/home/bil/motif-snd/repl] +|# + + +(define (f6) ; [943] + (let ((res "") + (size2 (/ size 2))) + (do ((i 0 (+ i 1))) + ((= i size2) res) + (set! res (format #f "~1,4F" pi))))) + +;(unless (string=? (f6) "3.1416") (format *stderr* "f6: ~S~%" (f6))) + +#| +225,500,000 ./stdio-common/./stdio-common/printf_fp.c:__printf_fp_buffer_1.constprop.0.isra.0 [/usr/lib/x86_64-linux-gnu/libc.so.6] +122,109,960 s7.c:format_to_port_1 [/home/bil/motif-snd/repl] +114,524,056 ./stdio-common/./stdio-common/vfprintf-internal.c:__printf_buffer [/usr/lib/x86_64-linux-gnu/libc.so.6] + 63,000,000 ./stdlib/../sysdeps/x86_64/mul_1.S:__mpn_mul_1 [/usr/lib/x86_64-linux-gnu/libc.so.6] + 40,000,000 s7.c:format_numeric_arg [/home/bil/motif-snd/repl] + 36,519,357 ./stdio-common/./stdio-common/Xprintf_buffer_write.c:__printf_buffer_write [/usr/lib/x86_64-linux-gnu/libc.so.6] + 32,500,012 s7.c:number_to_string_base_10.isra.0 [/home/bil/motif-snd/repl] + 30,500,000 s7.c:format_number [/home/bil/motif-snd/repl] + 27,500,000 ./stdio-common/./stdio-common/printf_fp.c:__printf_fp_l_buffer [/usr/lib/x86_64-linux-gnu/libc.so.6] + 25,000,000 ./stdio-common/./stdio-common/printf_fp.c:hack_digit [/usr/lib/x86_64-linux-gnu/libc.so.6] + 19,507,657 ./debug/./debug/snprintf_chk.c:__snprintf_chk [/usr/lib/x86_64-linux-gnu/libc.so.6] + 19,009,424 ./string/../sysdeps/x86_64/multiarch/strchr-avx2.S:__strchrnul_avx2 [/usr/lib/x86_64-linux-gnu/libc.so.6] + 15,149,924 ./string/../sysdeps/x86_64/multiarch/memmove-vec-unaligned-erms.S:__memcpy_avx_unaligned_erms [/usr/lib/x86_64-linux-gnu/libc.so.6] + 14,500,000 s7.c:g_format_no_column [/home/bil/motif-snd/repl] + 14,113,761 s7.c:gc.isra.0 [/home/bil/motif-snd/repl] + 14,006,916 ./libio/./libio/vsnprintf.c:__vsnprintf_internal [/usr/lib/x86_64-linux-gnu/libc.so.6] + 12,000,000 s7.c:string_write_string [/home/bil/motif-snd/repl] + 11,000,000 ./stdlib/../sysdeps/ieee754/dbl-64/dbl2mpn.c:__mpn_extract_double [/usr/lib/x86_64-linux-gnu/libc.so.6] + 10,503,772 ./string/../sysdeps/x86_64/multiarch/strchr-avx2.S:__strchr_avx2 [/usr/lib/x86_64-linux-gnu/libc. +|# + + +(define (f7) ; [362] + (let ((res "") + (size2 (/ size 2))) + (do ((i 0 (+ i 1))) + ((= i size2) res) + (set! res (format #f "~D is ~:D" 3 3))))) + +;(unless (string=? (f7) "3 is third") (format *stderr* "f7: ~S~%" (f7))) + +#| +151,609,892 s7.c:format_to_port_1 [/home/bil/motif-snd/repl] + 35,500,000 s7.c:format_number [/home/bil/motif-snd/repl] + 35,500,000 s7.c:opt_p_call_any [/home/bil/motif-snd/repl] + 24,000,000 s7.c:string_write_string [/home/bil/motif-snd/repl] + 23,500,012 s7.c:number_to_string_base_10.isra.0 [/home/bil/motif-snd/repl] + 23,149,965 ./string/../sysdeps/x86_64/multiarch/memmove-vec-unaligned-erms.S:__memcpy_avx_unaligned_erms [/usr/lib/x86_64-linux-gnu/libc.so.6] + 14,500,000 s7.c:g_format_no_column [/home/bil/motif-snd/repl] + 14,114,301 s7.c:gc.isra.0 [/home/bil/motif-snd/repl] + 10,503,830 ./string/../sysdeps/x86_64/multiarch/strchr-avx2.S:__strchr_avx2 [/usr/lib/x86_64-linux-gnu/libc.so.6] + 7,950,930 s7.c:opt_dotimes [/home/bil/motif-snd/repl] + 6,000,000 s7.c:opt_p_c [/home/bil/motif-snd/repl] + 4,500,000 s7.c:opt_set_p_p_f [/home/bil/motif-snd/repl] +|# + + +(define (f8) ; [375] + (let ((res "") + (size2 (/ size 2))) + (do ((i 0 (+ i 1))) + ((= i size2) res) + (set! res (format #f "~ND" 20 1234))))) ; "width field so string is 20 wide + +;(unless (string=? (f8) " 1234") (format *stderr* "f8: ~S~%" (f8))) + +#| +114,109,824 s7.c:format_to_port_1 [/home/bil/motif-snd/repl] + 37,500,000 s7.c:integer_to_string [/home/bil/motif-snd/repl] + 35,500,000 s7.c:format_number [/home/bil/motif-snd/repl] + 35,500,000 s7.c:opt_p_call_any [/home/bil/motif-snd/repl] + 27,500,012 s7.c:number_to_string_base_10.isra.0 [/home/bil/motif-snd/repl] + 21,000,000 s7.c:local_memset [/home/bil/motif-snd/repl] + 14,500,000 s7.c:g_format_no_column [/home/bil/motif-snd/repl] + 14,114,316 s7.c:gc.isra.0 [/home/bil/motif-snd/repl] + 13,500,000 s7.c:insert_spaces [/home/bil/motif-snd/repl] + 13,149,880 ./string/../sysdeps/x86_64/multiarch/memmove-vec-unaligned-erms.S:__memcpy_avx_unaligned_erms [/usr/lib/x86_64-linux-gnu/libc.so.6] + 12,000,000 s7.c:string_write_string [/home/bil/motif-snd/repl] + 8,500,000 s7.c:format_n_arg [/home/bil/motif-snd/repl] + 7,950,930 s7.c:opt_dotimes [/home/bil/motif-snd/repl] + 6,000,000 s7.c:opt_p_c [/home/bil/motif-snd/repl] + 4,500,000 s7.c:opt_set_p_p_f [/home/bil/motif-snd/repl] +|# + + +(define (f9) ; [424] + (let ((res "") + (size2 (/ size 2))) + (do ((i 0 (+ i 1))) + ((= i size2) res) + (set! res (format #f "~NC~D" 20 #\space 1234))))) ; 20 spaces then 1234 + +;(unless (string=? (f9) " 1234") (format *stderr* "f9: ~S~%" (f9))) + +#| +146,609,756 s7.c:format_to_port_1 [/home/bil/motif-snd/repl] + 39,500,000 s7.c:opt_p_call_any [/home/bil/motif-snd/repl] + 37,500,000 s7.c:integer_to_string [/home/bil/motif-snd/repl] + 35,500,000 s7.c:format_number [/home/bil/motif-snd/repl] + 35,500,000 s7.c:local_memset [/home/bil/motif-snd/repl] + 24,000,012 s7.c:number_to_string_base_10.isra.0 [/home/bil/motif-snd/repl] + 18,500,000 s7.c:format_append_chars [/home/bil/motif-snd/repl] + 14,500,000 s7.c:g_format_no_column [/home/bil/motif-snd/repl] + 14,114,451 s7.c:gc.isra.0 [/home/bil/motif-snd/repl] + 12,000,000 s7.c:string_write_string [/home/bil/motif-snd/repl] + 8,500,000 s7.c:format_n_arg [/home/bil/motif-snd/repl] + 7,950,930 s7.c:opt_dotimes [/home/bil/motif-snd/repl] + 7,650,071 ./string/../sysdeps/x86_64/multiarch/memmove-vec-unaligned-erms.S:__memcpy_avx_unaligned_erms [/usr/lib/x86_64-linux-gnu/libc.so.6] + 7,500,000 s7.c:opt_p_c [/home/bil/motif-snd/repl] + 4,500,000 s7.c:opt_set_p_p_f [/home/bil/motif-snd/repl] +|# + + +(define (f10) ; [768] + (let ((res "") + (size2 (/ size 2))) + (do ((i 0 (+ i 1))) + ((= i size2) res) + (set! res (format #f "~{~C~^ ~}" "hiho"))))) + +;(unless (string=? (f10) "h i h o") (format *stderr* "f10: ~S~%" (f10))) + +#| +367,000,000 s7.c:format_to_port_1'2 [/home/bil/motif-snd/repl] +189,703,539 s7.c:format_to_port_1 [/home/bil/motif-snd/repl] + 63,000,000 s7.c:string_write_char [/home/bil/motif-snd/repl] + 42,500,000 s7.c:object_to_list [/home/bil/motif-snd/repl] + 29,094,117 s7.c:gc.isra.0 [/home/bil/motif-snd/repl] + 18,000,000 s7.c:opt_p_call_ppp [/home/bil/motif-snd/repl] + 14,500,000 s7.c:g_format_no_column [/home/bil/motif-snd/repl] + 8,000,004 ./ctype/../include/ctype.h:__ctype_b_loc [/usr/lib/x86_64-linux-gnu/libc.so.6] + 7,950,930 s7.c:opt_dotimes [/home/bil/motif-snd/repl] + 7,650,227 ./string/../sysdeps/x86_64/multiarch/memmove-vec-unaligned-erms.S:__memcpy_avx_unaligned_erms [/usr/lib/x86_64-linux-gnu/libc.so.6] + 4,500,000 s7.c:opt_p_c [/home/bil/motif-snd/repl] + 4,500,000 s7.c:opt_set_p_p_f [/home/bil/motif-snd/repl] + 4,000,002 ???:0x0000000000116e20 [???] + 3,000,000 s7.c:check_free_heap_size [/home/bil/motif-snd/repl] +|# + + +(define (f11) ; [345] + (let ((res "") + (size10 (/ size 10))) + (do ((i 0 (+ i 1))) + ((= i size10) res) + (set! res (format #f "~{~{~C~^ ~}~^...~}" (list "hiho" "test")))))) + +;(unless (string=? (f11) "h i h o...t e s t") (format *stderr* "f11: ~S~%" (f11))) + +#| +217,500,010 s7.c:format_to_port_1'2 [/home/bil/motif-snd/repl] + 39,898,225 s7.c:format_to_port_1 [/home/bil/motif-snd/repl] + 25,200,000 s7.c:string_write_char [/home/bil/motif-snd/repl] + 19,200,000 s7.c:object_to_list [/home/bil/motif-snd/repl] + 9,714,210 s7.c:gc.isra.0 [/home/bil/motif-snd/repl] + 6,184,807 ./string/../sysdeps/x86_64/multiarch/memmove-vec-unaligned-erms.S:__memcpy_avx_unaligned_erms [/usr/lib/x86_64-linux-gnu/libc.so.6] + 3,600,000 s7.c:opt_p_call_ppp [/home/bil/motif-snd/repl] + 3,200,004 ./ctype/../include/ctype.h:__ctype_b_loc [/usr/lib/x86_64-linux-gnu/libc.so.6] + 2,900,085 s7.c:list_p_pp [/home/bil/motif-snd/repl] + 2,900,000 s7.c:g_format_no_column [/home/bil/motif-snd/repl] + 2,108,641 ./string/../sysdeps/x86_64/multiarch/strchr-avx2.S:__strchr_avx2 [/usr/lib/x86_64-linux-gnu/libc.so.6] + 1,900,692 s7.c:s7_list_length [/home/bil/motif-snd/repl] + 1,600,002 ???:0x0000000000116e20 [???] + 1,550,930 s7.c:opt_dotimes [/home/bil/motif-snd/repl] + 1,200,000 s7.c:check_free_heap_size [/home/bil/motif-snd/repl] + 900,000 s7.c:opt_set_p_p_f [/home/bil/motif-snd/repl] + 802,400 ???:0x0000000000116b00 [???] + 700,000 /usr/include/x86_64-linux-gnu/bits/string_fortified.h:format_to_port_1'2 + 700,000 s7.c:opt_p_pp_cc [/home/bil/motif-snd/repl] + 600,000 s7.c:opt_p_c [/home/bil/motif-snd/repl] +|# + + +(define (f12) ; [443] + (let-temporarily (((*s7* 'print-length) 4)) + (let ((res "") + (size4 (/ size 4))) + (do ((i 0 (+ i 1))) + ((= i size4) res) + (set! res (format #f "~{~A~| ~}" #(0 1 2 3 4 5 6 7 8))))))) + +;(unless (string=? (f12) "0 1 2 3 ...") (format *stderr* "f12: ~S~%" (f12))) + +#| +178,750,000 s7.c:format_to_port_1'2 [/home/bil/motif-snd/repl] + 94,858,241 s7.c:format_to_port_1 [/home/bil/motif-snd/repl] + 39,000,000 s7.c:integer_to_port [/home/bil/motif-snd/repl] + 32,750,000 s7.c:s7_vector_to_list [/home/bil/motif-snd/repl] + 23,501,027 s7.c:gc.isra.0 [/home/bil/motif-snd/repl] + 13,500,000 s7.c:string_write_char [/home/bil/motif-snd/repl] + 10,000,000 /usr/include/x86_64-linux-gnu/bits/string_fortified.h:integer_to_port + 9,000,000 s7.c:opt_p_call_ppp [/home/bil/motif-snd/repl] + 7,584,709 ./string/../sysdeps/x86_64/multiarch/memmove-vec-unaligned-erms.S:__memcpy_avx_unaligned_erms [/usr/lib/x86_64-linux-gnu/libc.so.6] + 7,250,000 s7.c:g_format_no_column [/home/bil/motif-snd/repl] + 6,500,000 s7.c:object_to_list [/home/bil/motif-snd/repl] + 6,000,000 s7.c:string_write_string [/home/bil/motif-snd/repl] + 3,950,936 s7.c:opt_dotimes [/home/bil/motif-snd/repl] + 2,250,000 s7.c:opt_p_c [/home/bil/motif-snd/repl] + 2,250,000 s7.c:opt_set_p_p_f [/home/bil/motif-snd/repl] + 1,500,000 s7.c:check_free_heap_size [/home/bil/motif-snd/repl] +|# + + +(define (f13) ; [352] + (let ((res "") + (size2 (/ size 2))) + (do ((i 0 (+ i 1))) + ((= i size2) res) + (set! res (format #f "~B" 1234))))) + +;(unless (string=? (f13) "10011010010") (format *stderr* "f13: ~S~%" (f13))) + +#| +108,000,144 s7.c:format_to_port_1 [/home/bil/motif-snd/repl] + 78,500,000 s7.c:integer_to_string_any_base [/home/bil/motif-snd/repl] + 43,000,000 s7.c:format_number [/home/bil/motif-snd/repl] + 32,967,791 s7.c:number_to_string_with_radix [/home/bil/motif-snd/repl] + 18,000,000 s7.c:opt_p_call_ppp [/home/bil/motif-snd/repl] + 14,500,000 s7.c:g_format_no_column [/home/bil/motif-snd/repl] + 14,114,539 s7.c:gc.isra.0 [/home/bil/motif-snd/repl] + 12,000,000 s7.c:string_write_string [/home/bil/motif-snd/repl] + 7,950,972 s7.c:opt_dotimes [/home/bil/motif-snd/repl] + 6,781,191 ./string/../sysdeps/x86_64/multiarch/memmove-vec-unaligned-erms.S:__memcpy_avx_unaligned_erms [/usr/lib/x86_64-linux-gnu/libc.so.6] + 4,500,000 s7.c:opt_p_c [/home/bil/motif-snd/repl] + 4,500,000 s7.c:opt_set_p_p_f [/home/bil/motif-snd/repl] +|# + + +(define (f14) ; [357] + (let ((res "") + (size2 (/ size 2))) + (do ((i 0 (+ i 1))) + ((= i size2) res) + (set! res (format #f "~A ~* ~A" 1 2 3))))) + +;(unless (string=? (f14) "1 3") (format *stderr* "f14: ~S~%" (f14))) + +#| +173,609,289 s7.c:format_to_port_1 [/home/bil/motif-snd/repl] + 39,500,000 s7.c:opt_p_call_any [/home/bil/motif-snd/repl] + 39,000,000 s7.c:integer_to_port [/home/bil/motif-snd/repl] + 21,011,634 ./string/../sysdeps/x86_64/multiarch/strchr-avx2.S:__strchr_avx2 [/usr/lib/x86_64-linux-gnu/libc.so.6] + 16,281,614 ./string/../sysdeps/x86_64/multiarch/memmove-vec-unaligned-erms.S:__memcpy_avx_unaligned_erms [/usr/lib/x86_64-linux-gnu/libc.so.6] + 14,500,000 s7.c:g_format_no_column [/home/bil/motif-snd/repl] + 14,114,923 s7.c:gc.isra.0 [/home/bil/motif-snd/repl] + 10,000,000 /usr/include/x86_64-linux-gnu/bits/string_fortified.h:integer_to_port + 7,950,972 s7.c:opt_dotimes [/home/bil/motif-snd/repl] + 7,500,000 s7.c:opt_p_c [/home/bil/motif-snd/repl] + 4,500,000 s7.c:opt_set_p_p_f [/home/bil/motif-snd/repl] +|# + + +(define (f15) ; [478] + (let ((res "") + (size2 (/ size 2))) + (do ((i 0 (+ i 1))) + ((= i size2) res) + (set! res (format #f "~A:~8T~A" 100 'a))))) + +;(unless (string=? (f15) "100: a") (format *stderr* "f15: ~S~%" (f15))) + +#| +217,609,212 s7.c:format_to_port_1 [/home/bil/motif-snd/repl] + 35,500,000 s7.c:opt_p_call_any [/home/bil/motif-snd/repl] + 33,150,402 ./string/../sysdeps/x86_64/multiarch/memmove-vec-unaligned-erms.S:__memcpy_avx_unaligned_erms [/usr/lib/x86_64-linux-gnu/libc.so.6] + 24,000,024 s7.c:string_write_string [/home/bil/motif-snd/repl] + 21,000,000 s7.c:format_numeric_arg [/home/bil/motif-snd/repl] + 19,500,012 s7.c:integer_to_port [/home/bil/motif-snd/repl] + 18,500,000 s7.c:format_append_chars [/home/bil/motif-snd/repl] + 18,000,037 s7.c:symbol_to_port [/home/bil/motif-snd/repl] + 15,500,000 s7.c:local_memset [/home/bil/motif-snd/repl] + 14,114,921 s7.c:gc.isra.0 [/home/bil/motif-snd/repl] + 10,512,314 ./string/../sysdeps/x86_64/multiarch/strchr-avx2.S:__strchr_avx2 [/usr/lib/x86_64-linux-gnu/libc.so.6] + 9,500,000 s7.c:g_format_f [/home/bil/motif-snd/repl] + 7,950,972 s7.c:opt_dotimes [/home/bil/motif-snd/repl] + 6,500,001 /usr/include/x86_64-linux-gnu/bits/string_fortified.h:integer_to_port + 6,000,000 s7.c:opt_p_c [/home/bil/motif-snd/repl] + 4,500,000 s7.c:opt_set_p_p_f [/home/bil/motif-snd/repl] +|# + + +(define (test-all) + (unless (string=? (f1) "just a bare string!") (format *stderr* "f1: ~S~%" (f1))) + (unless (string=? (f2) "asdf") (format *stderr* "f2: ~S~%" (f2))) + (unless (string=? (f3) "str: asdf") (format *stderr* "f3: ~S~%" (f3))) + (unless (string=? (f4) "str: asdf a") (format *stderr* "f4: ~S~%" (f4))) + (unless (string=? (f5) "(1 2 3)") (format *stderr* "f5: ~S~%" (f5))) + (unless (string=? (f6) "3.1416") (format *stderr* "f6: ~S~%" (f6))) + (unless (string=? (f7) "3 is third") (format *stderr* "f7: ~S~%" (f7))) + (unless (string=? (f8) " 1234") (format *stderr* "f8: ~S~%" (f8))) + (unless (string=? (f9) " 1234") (format *stderr* "f9: ~S~%" (f9))) + (unless (string=? (f10) "h i h o") (format *stderr* "f10: ~S~%" (f10))) + (unless (string=? (f11) "h i h o...t e s t") (format *stderr* "f11: ~S~%" (f11))) + (unless (string=? (f13) "10011010010") (format *stderr* "f13: ~S~%" (f13))) + (unless (string=? (f14) "1 3") (format *stderr* "f14: ~S~%" (f14))) + (unless (string=? (f15) "100: a") (format *stderr* "f15: ~S~%" (f15))) + ) + +;(test-all) ; [6556] (when (> (*s7* 'profile) 0) (show-profile 200)) diff --git a/tools/timp.scm b/tools/timp.scm index 36b4a0f..24b2668 100644 --- a/tools/timp.scm +++ b/tools/timp.scm @@ -1,7 +1,6 @@ ;;; implicit ref/set -- tmisc.scm and tread.scm also have some (set! (*s7* 'heap-size) 1024000) - (load "s7test-block.so" (sublet (curlet) (cons 'init_func 'block_init))) (define size 50000) @@ -245,7 +244,7 @@ ((= i len) sum) (set! sum (+ sum (fabsH i)))))) -(f6) +;(f6) (define P (list + * -)) @@ -258,7 +257,7 @@ ((= i len) sum) (set! sum (+ sum (fabsP i)))))) -(f8) +;(f8) (define V (vector + * -)) @@ -271,7 +270,7 @@ ((= i len) sum) (set! sum (+ sum (fabsV i)))))) -(f9) +;(f9) (define C (make-cycle *)) @@ -284,7 +283,7 @@ ((= i len) sum) (set! sum (+ sum (fabsC i)))))) -(f10) +;(f10) ;;; implicit arg cases (also included elsewhere) @@ -298,7 +297,7 @@ ((= i len) sum) (set! sum (+ sum (fabsB i)))))) -(f11) +;(f11) (define P2 (list (list + * -) (list .001 .0001 .00001))) @@ -311,7 +310,7 @@ ((= i len) sum) (set! sum (+ sum (fabsP2 i)))))) -(f12) +;(f12) (define V2 #2d((#_+ #_* #_-) (.001 .0001 .00001))) @@ -324,7 +323,7 @@ ((= i len) sum) (set! sum (+ sum (fabsV2 i)))))) -(f13) +;(f13) (define (f14) ; [492] @@ -333,7 +332,7 @@ ((= i len) sum) (set! sum (+ sum (* i (P2 1 1))))))) -(f14) +;(f14) (define (f15) ; [185] -- [738] if (vector (vector ...)) @@ -342,7 +341,7 @@ ((= i len) sum) (set! sum (+ sum (* i (V2 1 1))))))) -(f15) +;(f15) (define H2 (hash-table 'a .0001)) @@ -352,17 +351,17 @@ ((= i len) sum) (set! sum (+ sum (* i (H2 'a))))))) -(f16) +;(f16) (define L2 (inlet 'a .0001)) -(define (f17) ; [173] (no lref) -> [167] lref +(define (f17) ; [173] (no lref) -> [167] lref -> [131 slot_ref] (let ((sum 0.0)) (do ((i 0 (+ i 1))) ((= i len) sum) (set! sum (+ sum (* i (L2 'a))))))) -(f17) +;(f17) (define V3 (vector .0001)) @@ -372,7 +371,7 @@ ((= i len) sum) (set! sum (+ sum (* i (V3 0))))))) -(f18) +;(f18) (define P3 (list .0001)) @@ -382,7 +381,7 @@ ((= i len) sum) (set! sum (+ sum (* i (P3 0))))))) -(f19) +;(f19) (define B3 (block .0001)) @@ -392,7 +391,7 @@ ((= i len) sum) (set! sum (+ sum (* i (B3 0))))))) -(f20) +;(f20) (define V4 #2d((.0001))) @@ -402,7 +401,7 @@ ((= i len) sum) (set! sum (+ sum (* i (V4 0 0))))))) -(f21) +;(f21) ;;; let cases @@ -426,7 +425,7 @@ ((= i len) sum) (set! sum (+ sum (fabs i)))))) -(f1) +;(f1) (define (f2) ; [298] @@ -435,7 +434,7 @@ ((= i len) sum) (set! sum (+ sum (fLabs i)))))) -(f2) +;(f2) (define (f3) ; [510] @@ -444,7 +443,7 @@ ((= i len) sum) (set! sum (+ sum (frefabs i)))))) -(f3) +;(f3) (define f4 ; [559] @@ -453,11 +452,11 @@ 'value 3)))) (lambda () (do ((i 0 (+ i 1))) - ((= i len)) + ((= i len) (+ 1 L 2)) (unless (= (+ 1 L 2) 6) (display "f4 oops\n")))))) -(f4) +;(f4) (define (fabsL x) @@ -469,7 +468,7 @@ ((= i len) sum) (set! sum (+ sum (fabsL i)))))) -(f5) +;(f5) (define (fabs:L x) @@ -481,7 +480,408 @@ ((= i len) sum) (set! sum (+ sum (fabs:L i)))))) -(f22) +;(f22) + + +(define size 1000000) + +(define (f23) ; [134] opt'd + (let ((sum 0.0) + (L (inlet 'multiply *))) + (do ((i 0 (+ i 1))) + ((= i size) sum) + (set! sum (+ sum ((let-ref L 'multiply) i 0.0001)))))) + +;(display "f23 ") (display (f23)) (newline) + + +(define (f24) ; [605] -> [134 opt'd] + (let ((sum 0.0) + (L (inlet 'multiply *))) + (do ((i 0 (+ i 1))) + ((= i size) sum) + (set! sum (+ sum ((L 'multiply) i 0.0001)))))) + +;(display "f24 ") (display (f24)) (newline) + + +; check if (L 'multiply) is changed opt process is not used (fx): + +(define (f24a) ; [690] + (let ((sum 0.0) + (L (inlet 'multiply *)) + (H (hash-table 'multiply +))) + (do ((i 0 (+ i 1))) + ((= i size) sum) + (set! sum (+ sum ((L 'multiply) i 0.0001))) + (set! L H)))) ; apparently this blocks the optimizer -> op_x_aa etc + +;(display "f24a ") (display (f24a)) (newline) + + +(define (f24b) ; [577] + (let ((sum 0.0) + (L (inlet 'multiply *)) + (L1 (inlet 'multiply +))) + (do ((i 0 (+ i 1))) + ((= i size) sum) + (set! sum (+ sum ((L 'multiply) i 0.0001))) + (set! L L1)))) ; same as above + +;(display "f24b ") (display (f24b)) (newline) + + +(define (setL L) + (set! (L 'multiply) floor)) + +(define (f24c-1) ; floor: too many arguments + (let ((sum 0.0) + (L (inlet 'multiply *))) + (do ((i 0 (+ i 1))) + ((= i 3) sum) + (set! sum (+ sum ((L 'multiply) i 0.0001))) + (setL L)))) + +(define (f24c) (catch #t f24c-1 (lambda args 'error))) +;(display "f24c ") (display (catch #t f24c-1 (lambda args 'error))) (newline) + + +(define (f24d-1) ; same error as above + (let ((sum 0.0) + (L (inlet 'multiply *))) + (do ((i 0 (+ i 1))) + ((= i 3) sum) + (set! sum (+ sum ((L 'multiply) i 0.0001))) + (let-set! L 'multiply floor)))) + +(define (f24d) (catch #t f24d-1 (lambda args 'error))) +;(display "f24d ") (display (catch #t f24d-1 (lambda args 'error))) (newline) + + +(define (f25) ; [638] + (let ((sum 0.0) + (L (inlet 'multiply *))) + (do ((i 0 (+ i 1))) + ((= i size) sum) + (set! sum (+ sum ((L 'multiply) i 0.0001))) + (let-set! L 'multiply +)))) + +;(display "f25 ") (display (f25)) (newline) + +#| +224,053,076 s7.c:eval.isra.0 [/home/bil/motif-snd/repl] fx_c_scs = 125, op_x_aa = 188 + 74,000,000 s7.c:fx_c_scs [/home/bil/motif-snd/repl] let_set 60 + 59,000,225 s7.c:add_p_pp [/home/bil/motif-snd/repl] + 47,999,952 s7.c:fx_implicit_let_ref_c [/home/bil/motif-snd/repl] + 46,999,953 s7.c:op_x_aa [/home/bil/motif-snd/repl] implicit_let_ref aa="i 0.0001" + 27,000,000 s7.c:let_set_1 [/home/bil/motif-snd/repl] + 24,950,959 s7.c:g_add_x1 [/home/bil/motif-snd/repl] + 21,606,113 s7.c:gc.isra.0 [/home/bil/motif-snd/repl] + 21,000,687 /usr/include/x86_64-linux-gnu/bits/string_fortified.h:eval.isra.0 + 19,999,980 s7.c:g_add [/home/bil/motif-snd/repl] + 16,000,016 s7.c:g_num_eq_2 [/home/bil/motif-snd/repl] + 13,000,000 s7.c:let_ref_p_pp [/home/bil/motif-snd/repl] +|# + + +(require libm.scm) + +(define (f26) ; if s7 sqrt via *libc**(!! sqrt_p_p) [195] sqrt=30 gc=30, via *libm*: [246] sqrt=43 (s7__sqrt)+21 overhead, gc=30 + (let ((sum 0.0)) + (do ((i 0 (+ i 1))) + ((= i size) sum) + (set! sum (+ sum ((*libm* 'sqrt) (* 1.0 i))))))) + +;(display "f26 ") (display (f26)) (newline) + + +(define (f27) ; [268] + (let ((sum 0.0) + (L3 (inlet 'x 1.0))) + (do ((i 0 (+ i 1))) + ((= i size) sum) + (set! sum (+ sum (L3 'x))) + (set! (L3 'x) (* (L3 'x) 0.9999))))) + +;(display "f27 ") (display (f27)) (newline) ; 9999.999999994685 + +;;; (- 3.701520785793392e-44 (expt 0.9999 1000000)) 4.978412222288913e-59 + +#| +38,942,875 s7.c:opt_dotimes [/home/bil/motif-snd/repl] +30,000,000 s7.c:opt_p_pp_sf_lref [/home/bil/motif-snd/repl] +29,000,000 s7.c:opt_p_ppp_sff [/home/bil/motif-snd/repl] +28,000,144 s7.c:add_p_pp [/home/bil/motif-snd/repl] +26,000,160 s7.c:multiply_p_pp [/home/bil/motif-snd/repl] +26,000,000 s7.c:let_set_1 [/home/bil/motif-snd/repl] this could be simpler (key check, rootlet/unlet, slot search (save), slot setter in checked_slot_set) +21,689,904 s7.c:gc.isra.0 [/home/bil/motif-snd/repl] +18,000,044 s7.c:let_ref_p_pp [/home/bil/motif-snd/repl] +17,000,000 s7.c:opt_p_pp_fc [/home/bil/motif-snd/repl] +11,000,000 s7.c:opt_p_pp_sf_add [/home/bil/motif-snd/repl] + 9,000,000 s7.c:opt_p_c [/home/bil/motif-snd/repl] 'x in the let-refs, opt_p_pp_sf_lref [build this in], save slot for let-ref too + 9,000,000 s7.c:opt_set_p_p_f [/home/bil/motif-snd/repl] +|# + +(define (f28) ; [86 via opt_p_pp_sc_slot_ref] + (let ((sum 0.0) + (L3 (inlet 'x 1.0))) + (do ((i 0 (+ i 1))) + ((= i size) sum) + (set! sum (+ sum (let-ref L3 'x)))))) + +;(display "f28 ") (display (f28)) (newline) + + +(define (f29) ; [267 unopt'd except for fx*] + (let ((sum 0.0) + (L5 (inlet 'x 0.1)) + (L3 (inlet 'x 1.0))) + (do ((i 0 (+ i 1)) + (L4 L3 L5)) + ((= i size) sum) + (set! sum (+ sum (let-ref L4 'x)))))) + +;(display "f29 ") (display (f29)) (newline) + + +(define (f30) ; [642 eval/inlet_p_pp, gc etc, let_set_1 and let_ref] + (let ((sum 0.0) + (L3 (inlet 'x 1.0))) + (do ((i 0 (+ i 1)) + (L4 L3 (inlet 'x 0.1))) + ((= i size) sum) + (set! (L4 'x) (* 2.0 (L4 'x))) ; make sure it's a new inlet on each iteration + (set! sum (+ sum (let-ref L4 'x)))))) + +;(display "f30 ") (display (f30)) (newline) + + +(define (f31) ; [105 opt_p_pp_ss_lref let_ref_p_pp] -> [86 opt_p_pp_sc_slot_ref] + (let ((sum 0.0) + (L3 (inlet 'x 1.0))) + (do ((i 0 (+ i 1))) + ((= i size) sum) + (set! sum (+ sum (let-ref L3 :x)))))) + +;(display "f31 ") (display (f31)) (newline) + + +(define (f32) ; [109 opt_p_pp_sf_lref let_ref_p_pp and opt_p_c for 'x (I assume)] -> [86 slot_ref] + (let ((sum 0.0) + (L3 (inlet 'x 1.0))) + (do ((i 0 (+ i 1))) + ((= i size) sum) + (set! sum (+ sum (L3 'x)))))) + +;(display "f32 ") (display (f32)) (newline) + + +(define (f32a) ; [105] -> [86 slot_ref] + (let ((sum 0.0) + (L3 (inlet 'x 1.0))) + (do ((i 0 (+ i 1))) + ((= i size) sum) + (set! sum (+ sum (L3 :x)))))) + +;(display "f32a ") (display (f32a)) (newline) + + +(define (f33) ; [410, 552 if varlet on every iteration, fx_implicit_let_ref_c] + (let ((sum 0.0) + (L3 (inlet 'x 1.0))) + (do ((i 0 (+ i 1))) + ((= i size) sum) + (set! sum (+ sum (L3 'x))) + (when (= i 0) (varlet L3 'x 0.5))))) + +;(display "f33 ") (display (f33)) (newline) + + +(define (f34) ; [123 let_set_1 from let_set] 64755 (let-set! L3 :x (+ (L3 'x) 1)) -> [82] slot_set and slot_ref + (let ((L3 (inlet 'x 0))) + (do ((i 0 (+ i 1))) + ((= i size) (L3 :x)) + (let-set! L3 :x (+ (L3 'x) 1))))) + +;(display "f34 ") (display (f34)) (newline) + +#| +29,000,026 s7.c:let_set_1 [/home/bil/motif-snd/repl] +24,950,959 s7.c:g_add_xi [/home/bil/motif-snd/repl] +19,000,000 s7.c:opt_p_ppp_ssf [/home/bil/motif-snd/repl] let_set 64750 p_ppp_ok +17,000,000 s7.c:opt_p_pi_fc [/home/bil/motif-snd/repl] + 8,000,008 s7.c:let_set [/home/bil/motif-snd/repl] + 7,000,094 s7.c:opt_dotimes [/home/bil/motif-snd/repl] + 6,924,479 s7.c:gc.isra.0 [/home/bil/motif-snd/repl] + 4,000,000 s7.c:opt_p_pp_sc_slot_ref [/home/bil/motif-snd/repl] let-refs + 3,000,000 s7.c:add_p_pi [/home/bil/motif-snd/repl] + + to: + +24,950,959 s7.c:g_add_xi [/home/bil/motif-snd/repl] +17,000,000 s7.c:opt_p_pi_fc [/home/bil/motif-snd/repl] +15,000,000 s7.c:opt_p_ppf_slot_set [/home/bil/motif-snd/repl] + 7,000,094 s7.c:opt_dotimes [/home/bil/motif-snd/repl] + 6,924,494 s7.c:gc.isra.0 [/home/bil/motif-snd/repl] + 4,000,000 s7.c:opt_p_pp_slot_ref [/home/bil/motif-snd/repl] + 3,000,000 s7.c:add_p_pi [/home/bil/motif-snd/repl] +|# + + +(define (f34a) ; [133] opt_p_ppp_sff -> let_set(_1) 64800 (let-set! L3 'x (+ (L3 'x) 1)) -> [82] as above + (let ((L3 (inlet 'x 1.0))) + (do ((i 0 (+ i 1))) + ((= i size) (L3 :x)) + (let-set! L3 'x (+ (L3 'x) 1))))) + +;(display "f34a ") (display (f34a)) (newline) + + +(define (f35) ; [141] -> [98] + (let ((L3 (inlet 'x 0))) + (do ((i 0 (+ i 1))) + ((= i size) (L3 :x)) + (set! (L3 'x) (+ (L3 'x) 1))))) + +;(display "f35 ") (display (f35)) (newline) + + +(define (f35a) ; [33] opt_p_pps_slot_set + (let ((L3 (inlet 'x 0))) + (do ((i 0 (+ i 1))) + ((= i size) (L3 :x)) + (set! (L3 :x) i)))) + +;(display "f35a ") (display (f35a)) (newline) + + +(define (f35b) ; [66] -> [32] opt_p_ppc_slot_set -- twice as slow as f35i due to make_integer in opt_dotimes (set! is op_safe_do, let-set! is op_safe_dotimes in check_do) + ; -> [14] if sequence allows op_safe_dotimes (set! (L :x) val) as opposed to (let-set! L :x val) + ; but set! lacks has_fn and op_simple_do (the fallback) expects has_fn, so we lose + (let ((L3 (inlet 'x 0))) + (do ((i 0 (+ i 1))) + ((= i size) (L3 :x)) + (set! (L3 :x) 0)))) + +;(display "f35b ") (display (f35b)) (newline) +(define (f35c) ; [98] opt_p_ppf_slot_set and opt_p_pp_slot_ref + (let ((L3 (inlet 'x 0))) + (do ((i 0 (+ i 1))) + ((= i size) (L3 :x)) + (set! (L3 :x) (+ (L3 'x) 1))))) + +;(display "f35c ") (display (f35c)) (newline) + + +(define (f35d) ; [61] 65890 -> [33] opt_p_pps_slot_set + (let ((L3 (inlet 'x 0))) + (do ((i 0 (+ i 1))) + ((= i size) (L3 :x)) + (set! (L3 'x) i)))) + +;(display "f35d ") (display (f35d)) (newline) + + +(define (f35e) ; [45] ppf_slot_set -> [32] opt_p_ppc_slot_set + (let ((L3 (inlet 'x 0))) + (do ((i 0 (+ i 1))) + ((= i size) (L3 :x)) + (set! (L3 'x) 0)))) + +;(display "f35e ") (display (f35e)) (newline) ; 0 + + +(define (f35f) ; [63] -> [35] opt_p_pps_slot_set + (let ((L3 (inlet 'x 0))) + (do ((i 0 (+ i 1))) + ((= i size) (L3 :x)) + (let-set! L3 'x i)))) + +;(display "f35f ") (display (f35f)) (newline) ; 999999 + + +(define (f35g) ; [29] opt_p_ppf_slot_set + opt_p_c -> [16] opt_p_ppc_slot_set + (let ((L3 (inlet 'x 0))) + (do ((i 0 (+ i 1))) + ((= i size) (L3 :x)) + (let-set! L3 'x 0)))) + +;(display "f35g ") (display (f35g)) (newline) ; 0 + + +(define (f35h) ; [72] 64738 -> [35] opt_p_pps_slot_set + (let ((L3 (inlet 'x 0))) + (do ((i 0 (+ i 1))) + ((= i size) (L3 :x)) + (let-set! L3 :x i)))) + +;(display "f35h ") (display (f35h)) (newline) ; 999999 + + +(define (f35i) ; [58] opt_p_ppp_ssc + let_set_1 -> [16] opt_ppc_slot_set + (let ((L3 (inlet 'x 0))) + (do ((i 0 (+ i 1))) + ((= i size) (L3 :x)) + (let-set! L3 :x 0)))) + +;(display "f35i ") (display (f35i)) (newline) + + +(define (test-all) + (unless (= (f1) 4.999994999999997e+7) (format *stderr* "f1 ~A\n" (f1))) + (unless (= (f2) 4.999994999999997e+7) (format *stderr* "f2 ~A\n" (f2))) + (unless (= (f3) 4.999994999999997e+7) (format *stderr* "f3 ~A\n" (f3))) + (unless (= (f4) 6) (format *stderr* "f4 ~A\n" (f4))) + (unless (= (f5) 4.999994999999997e+7) (format *stderr* "f5 ~A\n" (f5))) + (unless (= (f6) 4.999994999999997e+7) (format *stderr* "f6 ~A\n" (f6))) + (unless (= (f8) 4.999994999999997e+7) (format *stderr* "f8 ~A\n" (f8))) + (unless (= (f9) 4.999994999999997e+7) (format *stderr* "f9 ~A\n" (f9))) + (unless (= (f10) 4.999994999999997e+7) (format *stderr* "f10 ~A\n" (f10))) + (unless (= (f11) 4.999994999999997e+7) (format *stderr* "f11 ~A\n" (f11))) + (unless (= (f12) 4.999994999999997e+7) (format *stderr* "f12 ~A\n" (f12))) + (unless (= (f13) 4.999994999999997e+7) (format *stderr* "f13 ~A\n" (f13))) + (unless (= (f14) 4.999994999999997e+7) (format *stderr* "f14 ~A\n" (f14))) + (unless (= (f15) 4.999994999999997e+7) (format *stderr* "f15 ~A\n" (f15))) + (unless (= (f16) 4.999994999999997e+7) (format *stderr* "f16 ~A\n" (f16))) + (unless (= (f17) 4.999994999999997e+7) (format *stderr* "f17 ~A\n" (f17))) + (unless (= (f18) 4.999994999999997e+7) (format *stderr* "f18 ~A\n" (f18))) + (unless (= (f19) 4.999994999999997e+7) (format *stderr* "f19 ~A\n" (f19))) + (unless (= (f20) 4.999994999999997e+7) (format *stderr* "f20 ~A\n" (f20))) + (unless (= (f21) 4.999994999999997e+7) (format *stderr* "f21 ~A\n" (f21))) + (unless (= (f22) 4.999994999999997e+7) (format *stderr* "f22 ~A\n" (f22))) + + (unless (equal? (f23) 4.999994999999997e+7) (display "f23: ") (display (f23)) (newline)) + (unless (equal? (f24) 4.999994999999997e+7) (display "f24: ") (display (f24)) (newline)) + (unless (equal? (f24a) 499999500104.7288) (display "f24a: ") (display (f24a)) (newline)) + (unless (equal? (f24b) 499999500104.7288) (display "f24b: ") (display (f24b)) (newline)) + (unless (equal? (f24c) 'error) (display "f24c: ") (display (f24c)) (newline)) + (unless (equal? (f24d) 'error) (display "f24d: ") (display (f24d)) (newline)) + (unless (equal? (f25) 499999500104.7288) (display "f25: ") (display (f25)) (newline)) + (unless (equal? (f26) 6.666661664588418e+8) (display "f26: ") (display (f26)) (newline)) + (unless (equal? (f27) 9999.999999994685) (display "f27: ") (display (f27)) (newline)) + (unless (equal? (f28) 1000000.0) (display "f28: ") (display (f28)) (newline)) + (unless (equal? (f29) 1.0000090000133294e+5) (display "f29: ") (display (f29)) (newline)) + (unless (equal? (f30) 2.0000180000266587e+5) (display "f30: ") (display (f30)) (newline)) + (unless (equal? (f31) 1000000.0) (display "f31: ") (display (f31)) (newline)) + (unless (equal? (f32) 1000000.0) (display "f32: ") (display (f32)) (newline)) + (unless (equal? (f32a) 1000000.0) (display "f32a: ") (display (f32a)) (newline)) + (unless (equal? (f33) 500000.5) (display "f33: ") (display (f33)) (newline)) + (unless (equal? (f34) 1000000) (display "f34: ") (display (f34)) (newline)) + (unless (equal? (f34a) 1000001.0) (display "f34a: ") (display (f34a)) (newline)) + (unless (equal? (f35) 1000000) (display "f35: ") (display (f35)) (newline)) + (unless (equal? (f35a) 999999) (display "f35a: ") (display (f35a)) (newline)) + (unless (equal? (f35b) 0) (display "f35b: ") (display (f35b)) (newline)) + (unless (equal? (f35c) 1000000) (display "f35c: ") (display (f35c)) (newline)) + (unless (equal? (f35d) 999999) (display "f35d: ") (display (f35d)) (newline)) + (unless (equal? (f35e) 0) (display "f35e: ") (display (f35e)) (newline)) + (unless (equal? (f35f) 999999) (display "f35f: ") (display (f35f)) (newline)) + (unless (equal? (f35g) 0) (display "f35g: ") (display (f35g)) (newline)) + (unless (equal? (f35h) 999999) (display "f35h: ") (display (f35h)) (newline)) + (unless (equal? (f35i) 0) (display "f35i: ") (display (f35i)) (newline)) +) + +(test-all) + (exit) diff --git a/tools/utf8-tests.scm b/tools/utf8-tests.scm new file mode 100644 index 0000000..30f1a97 --- /dev/null +++ b/tools/utf8-tests.scm @@ -0,0 +1,135 @@ +;;; utf8proc->s7 tests + +(load "libutf8proc.scm") + +(when (defined? '*libutf8proc*) + + (with-let *libutf8proc* + + ;; -------------------------------- + ;; these are from the libutf8proc test directory + + (define (print-property c) + (format *stderr* " category = ~S~% charwidth = ~D~%~A~%" + (utf8proc_category_string c) + (utf8proc_charwidth c) + (utf8proc_get_property c))) + + (do ((c 1 (+ c 1))) + ((= c #x110000)) + (let ((l (utf8proc_tolower c)) + (u (utf8proc_toupper c))) + (unless (or (= l c) + (utf8proc_codepoint_valid l)) + (format *stderr* "~X: invalid tolower~%" c)) + (unless (or (= u c) + (utf8proc_codepoint_valid u)) + (format *stderr* "~X: invalid toupper~%" c)) + )) + + (do ((c 0 (+ c 1))) + ((or (= c #xd800) + (and (not (utf8proc_codepoint_valid c)) + (not (format *stderr* "~X: codepoint invalid~%" c)))))) + + (do ((c #xd800 (+ c 1))) + ((or (= c #xe000) + (and (utf8proc_codepoint_valid c) + (not (format *stderr* "~X: codepoint valid?~%" c)))))) + + (do ((c #xe000 (+ c 1))) + ((or (= c #x110000) + (and (not (utf8proc_codepoint_valid c)) + (not (format *stderr* "~X: codepoint invalid~%" c)))))) + + (do ((c #x110000 (+ c 1))) + ((or (= c #x110010) + (and (utf8proc_codepoint_valid c) + (not (format *stderr* "~X: codepoint valid?~%" c)))))) + + ;; (print-property #xbb) + + (do ((c 1 (+ c 1))) + ((= c #x110000)) + (let ((cat ((utf8proc_get_property c) 'category)) + (w (utf8proc_charwidth c))) + (if (and (or (= cat UTF8PROC_CATEGORY_MN) (= cat UTF8PROC_CATEGORY_ME)) + (positive? w)) + (format *stderr* "nonzero width ~D for combining char ~X~%" w c)) + (if (and (zero? w) + (or (and (>= cat UTF8PROC_CATEGORY_LU) (<= cat UTF8PROC_CATEGORY_LO)) + (and (>= cat UTF8PROC_CATEGORY_ND) (<= cat UTF8PROC_CATEGORY_SC)) + (and (>= cat UTF8PROC_CATEGORY_SO) (<= cat UTF8PROC_CATEGORY_ZS)))) + (format *stderr* "zero width for symbol-like char ~X~%" c)))) + ;; -------------------------------- + + (define s '("élan ‘quote’")) ; example from Norman Gray + (display s) ; ("élan â\x80;\x98;quoteâ\x80;\x99;") -- this is due to write's slashify_table choices: now displays ("élan ‘quote’") + (newline) + (display (car s)) ; élan ‘quote’ + (newline) + + (define b (string->byte-vector (car s))) + (format #t "~{~X ~}" b) ;c3 a9 6c 61 6e 20 e2 80 98 71 75 6f 74 65 e2 80 99 + (newline) + + + (define p (utf8proc_map (car s) UTF8PROC_NULLTERM)) ; is this doing anything useful (besides error checking)? + (display (car p)) ; élan ‘quote’ + (newline) + + (define p1 (utf8proc_map "(\"élan ‘quote’\")" UTF8PROC_NULLTERM)) + (display (car p1)) ; ("élan ‘quote’") + (newline) + + (define b1 (string->byte-vector (car p1))) + (format #t "~{~X ~}" b1) ;28 22 c3 a9 6c 61 6e 20 e2 80 98 71 75 6f 74 65 e2 80 99 22 29 + (newline) + + (define s1 (with-output-to-string (lambda () (display s)))) + (display s1) (newline) ; ("élan ‘quote’") + (define p2 (utf8proc_map s1 UTF8PROC_NULLTERM)) + (if (integer? (cdr p2)) + (display (utf8proc_errmsg (cdr p2))) ; "Invalid UTF-8 string" or "unknown error" -- what is the problem here? + (display (car p2))) + (newline) + + (let ((len (cdr p1)) + (p1c (copy (car p1)))) + (do ((n (utf8proc_iterate p1c len) (utf8proc_iterate p1c len))) + ((<= (car n) 0)) ; (cdr n) is the codepoint as an integer + (display (substring p1c 0 (car n))) (display #\space) ; ( " é l a n ‘ q u o t e ’ " ) + (set! p1c (substring p1c (car n))) + (set! len (- len (car n)))) + (newline)) + + (let ((e1 (utf8proc_encode_char #x00E9))) ; unicode code-point to utf-8 -> (cons utf-8-string length-thereof) + (format #t "#x~{~X~}" (string->byte-vector (car e1))) ; #xc3a9 + (newline) + (display (car e1)) ; é + (newline)) + + (let ((e1 (utf8proc_encode_char #x018b))) + (format #t "#x~{~X~}" (string->byte-vector (car e1))) + (newline) + (display (car e1)) ; latin cap D with top bar + (newline)) + + (let ((e1 (utf8proc_encode_char #x0238))) + (format #t "#x~{~X~}" (string->byte-vector (car e1))) + (newline) + (display (car e1)) ; latin small db digraph + (newline)) + + (let ((e1 (utf8proc_encode_char #x1e00))) + (format #t "#x~{~X~}" (string->byte-vector (car e1))) + (newline) + (display (car e1)) ; latin cap A ring below + (newline)) + + (display (string->symbol "élan ‘quote’")) + (newline) + (display (symbol->string (symbol "élan ‘quote’"))) + (newline) + + )) diff --git a/tools/valcall.scm b/tools/valcall.scm index e0c3a3c..0f8563b 100644 --- a/tools/valcall.scm +++ b/tools/valcall.scm @@ -112,8 +112,8 @@ (list "repl" "tcase.scm") (list "repl" "tlet.scm") (list "repl" "tfft.scm") - (list "repl" "tmap.scm") (list "repl" "tstar.scm") + (list "repl" "tmap.scm") (list "repl" "tshoot.scm") (list "repl" "tform.scm") (list "repl" "concordance.scm") @@ -130,10 +130,10 @@ (list "repl" "thash.scm") (list "repl" "cb.scm") (list "repl" "tmap-hash.scm") - (list "repl" "timp.scm") (list "repl" "tmv.scm") (list "snd -noinit" "tgen.scm") ; repl here + cload sndlib was slower (list "snd -noinit" "tall.scm") + (list "repl" "timp.scm") (list "snd -l" "snd-test.scm") (list "snd -l" "full-snd-test.scm") (list "repl" "tbig.scm") |