diff options
| -rw-r--r-- | case.scm | 29 | ||||
| -rw-r--r-- | cload.scm | 10 | ||||
| -rwxr-xr-x | configure | 44 | ||||
| -rw-r--r-- | configure.ac | 22 | ||||
| -rw-r--r-- | debian/changelog | 8 | ||||
| -rw-r--r-- | debian/patches/notcurses_repl.patch | 18 | ||||
| -rw-r--r-- | debian/patches/notcurses_wideasian.patch | 21 | ||||
| -rw-r--r-- | debian/patches/series | 2 | ||||
| -rw-r--r-- | lint.scm | 5457 | ||||
| -rw-r--r-- | notcurses_s7.c | 90 | ||||
| -rw-r--r-- | poly.rb | 5 | ||||
| -rw-r--r-- | r7rs.scm | 4 | ||||
| -rw-r--r-- | s7.c | 6177 | ||||
| -rw-r--r-- | s7.h | 4 | ||||
| -rw-r--r-- | s7.html | 2 | ||||
| -rw-r--r-- | s7test.scm | 485 | ||||
| -rw-r--r-- | snd-nogui.c | 6 | ||||
| -rw-r--r-- | snd-test.fs | 20 | ||||
| -rw-r--r-- | snd-xm.fs | 15 | ||||
| -rw-r--r-- | snd.h | 8 | ||||
| -rw-r--r-- | tools/auto-tester.scm | 157 | ||||
| -rw-r--r-- | tools/concordance.scm | 85 | ||||
| -rw-r--r-- | tools/fbench.scm | 23 | ||||
| -rw-r--r-- | tools/ffitest.c | 24 | ||||
| -rw-r--r-- | tools/t101.scm | 3 | ||||
| -rw-r--r-- | tools/tcase.scm | 595 | ||||
| -rw-r--r-- | tools/tgc.scm | 99 | ||||
| -rw-r--r-- | tools/tio.scm | 33 | ||||
| -rw-r--r-- | tools/tlet.scm | 16 | ||||
| -rwxr-xr-x | tools/tmat.scm | 16 | ||||
| -rw-r--r-- | tools/tmisc.scm | 118 | ||||
| -rw-r--r-- | tools/tmock.scm | 5 | ||||
| -rw-r--r-- | tools/tnum.scm | 5 | ||||
| -rw-r--r-- | tools/tread.scm | 2 | ||||
| -rw-r--r-- | tools/valcall.scm | 14 | ||||
| -rw-r--r-- | xen.c | 4 |
36 files changed, 7393 insertions, 6233 deletions
@@ -154,20 +154,21 @@ (or (not func) (cadr (func (labels ellipsis-label)))))))))))) - (define (handle-regex reg e) - (lambda (x) - (and (string? x) - (with-let (sublet (symbol->value '*libc* e) - :x x - :regexp (substring reg 1 (- (length reg) 1))) - (let* ((rg (regex.make)) - (res (regcomp rg regexp 0))) - (unless (zero? res) - (error 'regex-error "~S~%" (regerror res rg))) - (set! res (regexec rg x 0 0)) - (regfree rg) - (regex.free rg) - (zero? res)))))) + (define handle-regex + (let ((rg ((*libc* 'regex.make))) ; is this safe? + (local-regcomp (*libc* 'regcomp)) + (local-regerror (*libc* 'regerror)) + (local-regexec (*libc* 'regexec)) + (local-regfree (*libc* 'regfree))) + (lambda (reg e) + (lambda (x) + (and (string? x) + (let ((res (local-regcomp rg (substring reg 1 (- (length reg) 1)) 0))) + (unless (zero? res) + (error 'regex-error "~S~%" (local-regerror res rg))) + (set! res (local-regexec rg x 0 0)) + (local-regfree rg) + (zero? res))))))) (define (undefined->function undef e) ; handle the pattern descriptor ("undef") of the form #< whatever >, "e" = caller's curlet (let* ((str1 (object->string undef)) @@ -283,11 +283,11 @@ (format p "#include \"s7.h\"~%~%")) (define collides? - (let ((all-names ())) + (let ((all-names (hash-table))) (lambda (name) - (if (memq name all-names) + (if (hash-table-ref all-names name) (format *stderr* "~A twice?~%" name) - (set! all-names (cons name all-names))) + (hash-table-set! all-names name #t)) name))) (define (hyphen->space type) @@ -588,6 +588,10 @@ (format p "}~%") (close-output-port p) + + (unless (or (file-exists? "s7.h") + (not (pair? *load-path*))) + (set! *cload-cflags* (append *cload-cflags* (format #f " -I~A" (car *load-path*))))) ;; now we have the module .c file -- make it into a shared object, load it, delete the temp files @@ -1,6 +1,6 @@ #! /bin/sh # Guess values for system-dependent variables and create Makefiles. -# Generated by GNU Autoconf 2.69 for snd 20.9. +# Generated by GNU Autoconf 2.69 for snd 21.0. # # Report bugs to <bil@ccrma.stanford.edu>. # @@ -579,9 +579,9 @@ MAKEFLAGS= # Identity of this package. PACKAGE_NAME='snd' -PACKAGE_TARNAME='ftp://ccrma-ftp.stanford.edu/pub/Lisp/snd-20.tar.gz' -PACKAGE_VERSION='20.9' -PACKAGE_STRING='snd 20.9' +PACKAGE_TARNAME='ftp://ccrma-ftp.stanford.edu/pub/Lisp/snd-21.tar.gz' +PACKAGE_VERSION='21.0' +PACKAGE_STRING='snd 21.0' PACKAGE_BUGREPORT='bil@ccrma.stanford.edu' PACKAGE_URL='' @@ -1328,7 +1328,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 20.9 to adapt to many kinds of systems. +\`configure' configures snd 21.0 to adapt to many kinds of systems. Usage: $0 [OPTION]... [VAR=VALUE]... @@ -1378,7 +1378,7 @@ Fine tuning of the installation directories: --localedir=DIR locale-dependent data [DATAROOTDIR/locale] --mandir=DIR man documentation [DATAROOTDIR/man] --docdir=DIR documentation root - [DATAROOTDIR/doc/ftp://ccrma-ftp.stanford.edu/pub/Lisp/snd-20.tar.gz] + [DATAROOTDIR/doc/ftp://ccrma-ftp.stanford.edu/pub/Lisp/snd-21.tar.gz] --htmldir=DIR html documentation [DOCDIR] --dvidir=DIR dvi documentation [DOCDIR] --pdfdir=DIR pdf documentation [DOCDIR] @@ -1399,7 +1399,7 @@ fi if test -n "$ac_init_help"; then case $ac_init_help in - short | recursive ) echo "Configuration of snd 20.9:";; + short | recursive ) echo "Configuration of snd 21.0:";; esac cat <<\_ACEOF @@ -1523,7 +1523,7 @@ fi test -n "$ac_init_help" && exit $ac_status if $ac_init_version; then cat <<\_ACEOF -snd configure 20.9 +snd configure 21.0 generated by GNU Autoconf 2.69 Copyright (C) 2012 Free Software Foundation, Inc. @@ -1984,7 +1984,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 20.9, which was +It was created by snd $as_me 21.0, which was generated by GNU Autoconf 2.69. Invocation command line was $ $0 $@ @@ -3331,7 +3331,7 @@ LOCAL_LANGUAGE="None" GRAPHICS_TOOLKIT="None" PACKAGE=Snd -VERSION=20.9 +VERSION=21.0 #-------------------------------------------------------------------------------- # configuration options @@ -5190,6 +5190,8 @@ fi #-------------------------------------------------------------------------------- if test "$with_notcurses" = yes ; then + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for notcurses" >&5 +$as_echo_n "checking for notcurses... " >&6; } $as_echo "#define USE_NO_GUI 1" >>confdefs.h GX_FILES="NO_GUI_O_FILES" @@ -5202,9 +5204,18 @@ if test "$with_notcurses" = yes ; then if $PKG_CONFIG --exists 'notcurses < 2.0.0' ; then GRFX_CFLAGS="$GRFX_CFLAGS -DNOTCURSES_1=1" fi +# someone screwed up notcurses/version.h in FC version 2.0.7 -- it is missing the numeric version macros + if $PKG_CONFIG --exists 'notcurses >= 2.0.5' ; then + GRFX_CFLAGS="$GRFX_CFLAGS -DNOTCURSES_2_0_5=1" + fi $as_echo "#define USE_NOTCURSES 1" >>confdefs.h - fi + { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +$as_echo "yes" >&6; } + else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } + fi fi @@ -5252,6 +5263,8 @@ GL_FLAGS="" if test "$with_gl" = yes ; then if test x$PKG_CONFIG != xno ; then + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for opengl" >&5 +$as_echo_n "checking for opengl... " >&6; } if $PKG_CONFIG gl --exists ; then GL_CFLAGS="`$PKG_CONFIG gl --cflags`" @@ -5274,6 +5287,11 @@ if test "$with_gl" = yes ; then RANDOM_FEATURES="$RANDOM_FEATURES gl2ps" GL_FILES="$GL_FILES gl2ps.o" fi + { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +$as_echo "yes" >&6; } + else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } fi fi fi @@ -6958,7 +6976,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 20.9, which was +This file was extended by snd $as_me 21.0, which was generated by GNU Autoconf 2.69. Invocation command line was CONFIG_FILES = $CONFIG_FILES @@ -7020,7 +7038,7 @@ _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_cs_config="`$as_echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`" ac_cs_version="\\ -snd config.status 20.9 +snd config.status 21.0 configured by $0, generated by GNU Autoconf 2.69, with options \\"\$ac_cs_config\\" diff --git a/configure.ac b/configure.ac index 1a75263..8aad85a 100644 --- a/configure.ac +++ b/configure.ac @@ -5,7 +5,7 @@ # gmp, mpfr, and mpc deliberately have none! -AC_INIT(snd, 20.9, bil@ccrma.stanford.edu, ftp://ccrma-ftp.stanford.edu/pub/Lisp/snd-20.tar.gz) +AC_INIT(snd, 21.0, bil@ccrma.stanford.edu, ftp://ccrma-ftp.stanford.edu/pub/Lisp/snd-21.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=20.9 +VERSION=21.0 #-------------------------------------------------------------------------------- # configuration options @@ -299,19 +299,31 @@ fi #-------------------------------------------------------------------------------- if test "$with_notcurses" = yes ; then + AC_MSG_CHECKING(for notcurses) AC_DEFINE(USE_NO_GUI) GX_FILES="NO_GUI_O_FILES" GX_HEADERS="NO_GUI_HEADERS" ac_snd_gui_choice=notcurses + if $PKG_CONFIG notcurses --exists ; then GRFX_CFLAGS="`$PKG_CONFIG notcurses --cflags`" GRFX_LIBS="`$PKG_CONFIG notcurses --libs`" GRAPHICS_TOOLKIT=Notcurses-`$PKG_CONFIG notcurses --modversion` + if $PKG_CONFIG --exists 'notcurses < 2.0.0' ; then GRFX_CFLAGS="$GRFX_CFLAGS -DNOTCURSES_1=1" fi - AC_DEFINE(USE_NOTCURSES) + +# someone screwed up notcurses/version.h in FC version 2.0.7 -- it is missing the numeric version macros + if $PKG_CONFIG --exists 'notcurses >= 2.0.5' ; then + GRFX_CFLAGS="$GRFX_CFLAGS -DNOTCURSES_2_0_5=1" fi + + AC_DEFINE(USE_NOTCURSES) + AC_MSG_RESULT(yes) + else + AC_MSG_RESULT(no) + fi fi @@ -357,6 +369,7 @@ GL_FLAGS="" if test "$with_gl" = yes ; then if test x$PKG_CONFIG != xno ; then + AC_MSG_CHECKING(for opengl) if $PKG_CONFIG gl --exists ; then GL_CFLAGS="`$PKG_CONFIG gl --cflags`" @@ -376,6 +389,9 @@ if test "$with_gl" = yes ; then RANDOM_FEATURES="$RANDOM_FEATURES gl2ps" GL_FILES="$GL_FILES gl2ps.o" fi + AC_MSG_RESULT(yes) + else + AC_MSG_RESULT(no) fi fi fi diff --git a/debian/changelog b/debian/changelog index 9a48eb6..93e8b1e 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,11 @@ +snd (21.0-1) unstable; urgency=medium + + * New upstream version 21.0 + * Add patch to fix FTBFS with notcurses>=2.1.4 + * Backport fix for FTBFS when using notcurses + + -- IOhannes m zmölnig (Debian/GNU) <umlaeute@debian.org> Tue, 12 Jan 2021 00:00:03 +0100 + snd (20.9-1) unstable; urgency=medium * New upstream version 20.9 diff --git a/debian/patches/notcurses_repl.patch b/debian/patches/notcurses_repl.patch new file mode 100644 index 0000000..4504288 --- /dev/null +++ b/debian/patches/notcurses_repl.patch @@ -0,0 +1,18 @@ +Description: fixed syntax-error when using notcurses REPL +Author: Bill Schottstaedt <bil@ccrma.stanford.edu> +Origin: upstream +Applied-Upstream: https://sourceforge.net/p/snd/svn1/1043/ +--- +This patch header follows DEP-3: http://dep.debian.net/deps/dep3/ +--- snd.orig/snd-nogui.c ++++ snd/snd-nogui.c +@@ -737,8 +737,8 @@ + (set! prompt-length (length prompt-string)))))"); + s7_eval_c_string(s7, "((*repl* 'run))"); + } +-#endif + else ++#endif + { + DUMB_REPL: + while (true) diff --git a/debian/patches/notcurses_wideasian.patch b/debian/patches/notcurses_wideasian.patch new file mode 100644 index 0000000..2fc8e8d --- /dev/null +++ b/debian/patches/notcurses_wideasian.patch @@ -0,0 +1,21 @@ +Description: remove symbol dropped from notcurses + notcurses-2.1.4 has dropped CELL_WIDEASIAN_MASK +Author: IOhannes m zmölnig +Origin: Debian +Forwarded: yes +--- +This patch header follows DEP-3: http://dep.debian.net/deps/dep3/ +--- snd.orig/notcurses_s7.c ++++ snd/notcurses_s7.c +@@ -3809,7 +3809,11 @@ + nc_int(NCOPTION_NO_ALTERNATE_SCREEN); + nc_int(NCOPTION_NO_FONT_CHANGES); + ++#if (defined NOTCURSES_VERSION_COMPARABLE) && (NOTCURSES_VERSION_COMPARABLE(2,1,4) >= NOTCURSES_VERNUM_ORDERED) ++ /* notcurses-2.1.4 dropped CELL_WIDEASIAN_MASK */ ++#else + nc_int(CELL_WIDEASIAN_MASK); ++#endif + nc_int(CELL_BGDEFAULT_MASK); + nc_int(CELL_FGDEFAULT_MASK); + nc_int(CELL_BG_RGB_MASK); diff --git a/debian/patches/series b/debian/patches/series new file mode 100644 index 0000000..d25f8ba --- /dev/null +++ b/debian/patches/series @@ -0,0 +1,2 @@ +notcurses_repl.patch +notcurses_wideasian.patch @@ -2,7 +2,7 @@ ;;; ;;; (lint "file.scm") checks file.scm for infelicities ;;; to control the kinds of checks, set the variables below. -;;; for tests and examples, see lint-test in s7test.scm +;;; for tests and examples, see lint-test in s7test.scm (provide 'lint.scm) @@ -21,7 +21,7 @@ (define *report-combinable-lets* #t) ; report lets that can be combined (define *report-splittable-lets* #f) ; report let*'s that can be split into a few nested lets -(define *report-ridiculous-variable-names* 50) ; max length of var name +(define *report-ridiculous-variable-names* 50) ; max length of var name (define *report-bad-variable-names* '(l ll .. O ~ else)) ; bad names -- a list to check such as: ;;; '(l ll .. ~ else data datum new item info temp tmp temporary val vals value foo bar baz aux dummy O var res retval result count str) ;;; else is evaluated in cond @@ -57,19 +57,19 @@ (when (provided? 'pure-s7) (define (make-polar mag ang) (complex (* mag (cos ang)) (* mag (sin ang)))) - + (define (char-ci=? . chars) (apply char=? (map char-upcase chars))) (define (char-ci<=? . chars) (apply char<=? (map char-upcase chars))) (define (char-ci>=? . chars) (apply char>=? (map char-upcase chars))) (define (char-ci<? . chars) (apply char<? (map char-upcase chars))) (define (char-ci>? . chars) (apply char>? (map char-upcase chars))) - + (define (string-ci=? . strs) (apply string=? (map string-upcase strs))) (define (string-ci<=? . strs) (apply string<=? (map string-upcase strs))) (define (string-ci>=? . strs) (apply string>=? (map string-upcase strs))) (define (string-ci<? . strs) (apply string<? (map string-upcase strs))) (define (string-ci>? . strs) (apply string>? (map string-upcase strs))) - + (define (let->list e) (if (let? e) (reverse! (map values e)) @@ -95,29 +95,29 @@ ;;; -------------------------------------------------------------------------------- (define lint - (let ((no-side-effect-functions + (let ((no-side-effect-functions (let ((ht (make-hash-table))) (for-each - (lambda (op) + (lambda (op) (set! (ht op) #t)) - '(* + - / < <= = > >= - abs acos acosh and angle append aritable? arity ash asin asinh assoc assq assv atan atanh + '(* + - / < <= = > >= + abs acos acosh and angle append aritable? arity ash asin asinh assoc assq assv atan atanh begin boolean? byte-vector byte-vector-ref byte-vector? caaaar caaadr caaar caadar caaddr caadr caar cadaar cadadr cadar caddar cadddr caddr cadr call-with-input-string call-with-input-file - c-pointer c-pointer? c-object? c-object-type call-with-exit car case catch + c-pointer c-pointer? c-object? c-object-type call-with-exit car case catch cdaaar cdaadr cdaar cdadar cdaddr cdadr cdar cddaar cddadr cddar cdddar cddddr cdddr cddr cdr ceiling char->integer char-alphabetic? char-ci<=? - char-ci<? char-ci=? char-ci>=? char-ci>? char-downcase char-lower-case? char-numeric? + char-ci<? char-ci=? char-ci>=? char-ci>? char-downcase char-lower-case? char-numeric? char-position char-ready? char-upcase char-upper-case? char-whitespace? char<=? char<? char=? char>=? char>? char? complex complex? cond cons continuation? cos constant? cosh curlet current-error-port current-input-port current-output-port cyclic-sequences defined? denominator dilambda? do dynamic-wind eof-object? eq? equal? eqv? even? exact->inexact exact? exp expt - float? float-vector float-vector-ref float-vector? floor for-each funclet + float? float-vector float-vector-ref float-vector? floor for-each funclet gcd gensym gensym? hash-table hash-table-entries hash-table-ref hash-table? help hook-functions - if imag-part immutable? inexact->exact inexact? infinite? inlet input-port? + if imag-part immutable? inexact->exact inexact? infinite? inlet input-port? int-vector int-vector-ref int-vector? iterator-at-end? iterator-sequence integer->char integer-decode-float integer-length integer? iterator? keyword->symbol keyword? @@ -131,7 +131,7 @@ setter signature procedure-source procedure? proper-list? provided? quasiquote quote quotient random-state random-state->list random-state? rational? rationalize real-part real? remainder reverse rootlet round - sequence? sin sinh square sqrt stacktrace string string->list string->number string->symbol string->keyword string-append + sequence? sin sinh square sqrt stacktrace string string->list string->number string->symbol string->keyword string-append string-ci<=? string-ci<? string-ci=? string-ci>=? string-ci>? string-downcase string-length string-position string-ref string-upcase string<=? string<? string=? string>=? string>? string? sublet substring subvector? subvector-position subvector-vector @@ -147,46 +147,46 @@ (built-in-functions (let ((ht (make-hash-table))) (for-each - (lambda (op) + (lambda (op) (set! (ht op) #t)) '(symbol? gensym? keyword? let? openlet? iterator? macro? c-pointer? c-object? c-object-type constant? subvector? - input-port? output-port? eof-object? integer? number? real? complex? rational? random-state? - char? string? list? pair? vector? float-vector? int-vector? byte-vector? hash-table? - continuation? procedure? dilambda? boolean? float? proper-list? sequence? null? gensym - symbol->string string->symbol symbol symbol->value symbol->dynamic-value - string->keyword symbol->keyword keyword->symbol outlet rootlet curlet unlet sublet varlet + input-port? output-port? eof-object? integer? number? real? complex? rational? random-state? + char? string? list? pair? vector? float-vector? int-vector? byte-vector? hash-table? + continuation? procedure? dilambda? boolean? float? proper-list? sequence? null? gensym + symbol->string string->symbol symbol symbol->value symbol->dynamic-value + string->keyword symbol->keyword keyword->symbol outlet rootlet curlet unlet sublet varlet cutlet inlet owlet coverlet openlet let-ref let-set! make-iterator iterate iterator-sequence - iterator-at-end? provided? provide defined? c-pointer port-line-number port-filename - pair-line-number pair-filename port-closed? current-input-port current-output-port - current-error-port let->list char-ready? close-input-port close-output-port flush-output-port - open-input-file open-output-file open-input-string open-output-string get-output-string - newline write display read-char peek-char write-char write-string read-byte write-byte - read-line read-string read call-with-input-string call-with-input-file with-input-from-string - with-input-from-file call-with-output-string call-with-output-file with-output-to-string - with-output-to-file real-part imag-part numerator denominator even? odd? zero? positive? - negative? infinite? nan? complex magnitude angle rationalize abs exp log sin cos tan asin + iterator-at-end? provided? provide defined? c-pointer port-line-number port-filename + pair-line-number pair-filename port-closed? current-input-port current-output-port + current-error-port let->list char-ready? close-input-port close-output-port flush-output-port + open-input-file open-output-file open-input-string open-output-string get-output-string + newline write display read-char peek-char write-char write-string read-byte write-byte + read-line read-string read call-with-input-string call-with-input-file with-input-from-string + with-input-from-file call-with-output-string call-with-output-file with-output-to-string + with-output-to-file real-part imag-part numerator denominator even? odd? zero? positive? + negative? infinite? nan? complex magnitude angle rationalize abs exp log sin cos tan asin acos atan sinh cosh tanh asinh acosh atanh sqrt expt floor ceiling truncate round lcm gcd - + - * / max min quotient remainder modulo = < > <= >= logior logxor logand lognot ash - random-state random inexact->exact exact->inexact integer-length make-polar make-rectangular - logbit? integer-decode-float exact? inexact? random-state->list number->string string->number - char-upcase char-downcase char->integer integer->char char-upper-case? char-lower-case? - char-alphabetic? char-numeric? char-whitespace? char=? char<? char>? char<=? char>=? - char-position string-position make-string string-ref string-set! string=? string<? string>? - string<=? string>=? char-ci=? char-ci<? char-ci>? char-ci<=? char-ci>=? string-ci=? string-ci<? - string-ci>? string-ci<=? string-ci>=? string-copy string-fill! list->string string-length - string->list string-downcase string-upcase string-append substring string object->string - format cons car cdr set-car! set-cdr! caar cadr cdar cddr caaar caadr cadar cdaar caddr - cdddr cdadr cddar caaaar caaadr caadar cadaar caaddr cadddr cadadr caddar cdaaar cdaadr - cdadar cddaar cdaddr cddddr cddadr cdddar assoc member list list-ref list-set! list-tail - make-list length copy fill! reverse reverse! sort! append assq assv memq memv vector-append - list->vector vector-fill! vector-length vector->list vector-ref vector-set! vector-dimensions - make-vector subvector vector float-vector make-float-vector float-vector-set! - float-vector-ref int-vector make-int-vector int-vector-set! int-vector-ref string->byte-vector - byte-vector make-byte-vector hash-table make-hash-table hash-table-ref - hash-table-set! hash-table-entries cyclic-sequences call/cc call-with-current-continuation - call-with-exit load autoload eval eval-string apply for-each map dynamic-wind values - catch throw error documentation signature help procedure-source funclet - setter arity aritable? not eq? eqv? equal? equivalent? gc emergency-exit + + - * / max min quotient remainder modulo = < > <= >= logior logxor logand lognot ash + random-state random inexact->exact exact->inexact integer-length make-polar make-rectangular + logbit? integer-decode-float exact? inexact? random-state->list number->string string->number + char-upcase char-downcase char->integer integer->char char-upper-case? char-lower-case? + char-alphabetic? char-numeric? char-whitespace? char=? char<? char>? char<=? char>=? + char-position string-position make-string string-ref string-set! string=? string<? string>? + string<=? string>=? char-ci=? char-ci<? char-ci>? char-ci<=? char-ci>=? string-ci=? string-ci<? + string-ci>? string-ci<=? string-ci>=? string-copy string-fill! list->string string-length + string->list string-downcase string-upcase string-append substring string object->string + format cons car cdr set-car! set-cdr! caar cadr cdar cddr caaar caadr cadar cdaar caddr + cdddr cdadr cddar caaaar caaadr caadar cadaar caaddr cadddr cadadr caddar cdaaar cdaadr + cdadar cddaar cdaddr cddddr cddadr cdddar assoc member list list-ref list-set! list-tail + make-list length copy fill! reverse reverse! sort! append assq assv memq memv vector-append + list->vector vector-fill! vector-length vector->list vector-ref vector-set! vector-dimensions + make-vector subvector vector float-vector make-float-vector float-vector-set! + float-vector-ref int-vector make-int-vector int-vector-set! int-vector-ref string->byte-vector + byte-vector make-byte-vector hash-table make-hash-table hash-table-ref + hash-table-set! hash-table-entries cyclic-sequences call/cc call-with-current-continuation + call-with-exit load autoload eval eval-string apply for-each map dynamic-wind values + catch throw error documentation signature help procedure-source funclet + setter arity aritable? not eq? eqv? equal? equivalent? gc emergency-exit exit dilambda make-hook hook-functions stacktrace tree-leaves tree-memq object->let getenv directory? file-exists? type-of immutable! immutable? byte-vector-set! syntax? list-values apply-values unquote set-current-output-port unspecified? undefined? byte-vector-ref @@ -213,20 +213,20 @@ char->integer hash-table-entries write-byte char-position string-position pair-line-number port-line-number)) h)) - + (numeric-ops (let ((h (make-hash-table))) (for-each (lambda (op) (set! (h op) #t)) - '(+ * - / - sin cos tan asin acos atan sinh cosh tanh asinh acosh atanh + '(+ * - / + sin cos tan asin acos atan sinh cosh tanh asinh acosh atanh log exp expt sqrt make-polar complex make-rectangular imag-part real-part abs magnitude angle max min exact->inexact modulo remainder quotient lcm gcd rationalize inexact->exact random - logior lognot logxor logand integer-length numerator denominator + logior lognot logxor logand integer-length numerator denominator floor round truncate ceiling ash - + ;; r7rs exact inexact @@ -283,36 +283,36 @@ (eq? eq?) (eqv? eqv?) (equal? equal?) (equivalent? equivalent?) (logand logand) (logxor logxor) (logior logior) (max max) (min min) (lcm lcm) (gcd gcd) - (char<? char>?) (char>? char<?) (char<=? char>=?) (char>=? char<=?) - (string<? string>?) (string>? string<?) (string<=? string>=?) (string>=? string<=?) + (char<? char>?) (char>? char<?) (char<=? char>=?) (char>=? char<=?) + (string<? string>?) (string>? string<?) (string<=? string>=?) (string>=? string<=?) (char-ci<? char-ci>?) (char-ci>? char-ci<?) (char-ci<=? char-ci>=?) (char-ci>=? char-ci<=?) (string-ci<? string-ci>?) (string-ci>? string-ci<?) (string-ci<=? string-ci>=?) (string-ci>=? string-ci<=?))) h)) - + (syntaces (let ((h (make-hash-table))) (for-each (lambda (op) (set! (h op) #t)) '(quote if begin let let* letrec letrec* cond case or and do set! unless when with-let with-baffle - lambda lambda* define define* - define-macro define-macro* define-bacro define-bacro* + lambda lambda* define define* + define-macro define-macro* define-bacro define-bacro* define-constant define-expansion)) h)) (definers '(define define* define-constant lambda lambda* curlet require load eval eval-string - define-macro define-macro* define-bacro define-bacro* define-expansion - definstrument define-animal define-envelope + define-macro define-macro* define-bacro define-bacro* define-expansion + definstrument define-animal define-envelope define-values define-module define-method define-syntax define-public define-inlinable define-integrable define^)) (open-definers '(define define* define-constant require load eval eval-string - define-macro define-macro* define-bacro define-bacro* define-expansion + define-macro define-macro* define-bacro define-bacro* define-expansion definstrument define-animal define-envelope defgenerator define-values define-module define-method define-syntax define-public define-inlinable define-integrable define^)) - (cxars (hash-table 'car () 'caar 'car 'cdar 'cdr + (cxars (hash-table 'car () 'caar 'car 'cdar 'cdr 'caaar 'caar 'cdaar 'cdar 'cddar 'cddr 'cadar 'cadr 'caaaar 'caaar 'caadar 'caadr 'cadaar 'cadar 'caddar 'caddr 'cdaaar 'cdaar 'cdadar 'cdadr 'cddaar 'cddar 'cdddar 'cdddr)) @@ -358,14 +358,14 @@ (define denote define-constant) - (define definers-table + (define definers-table (let ((h (make-hash-table))) (for-each (lambda (d) (set! (h d) #t)) definers) h)) - (define open-definers-table + (define open-definers-table (let ((h (make-hash-table))) (for-each (lambda (d) (set! (h d) #t)) @@ -381,7 +381,7 @@ (do ((i (- target-line-length 6) (- i 1))) ((or (= i 40) (char-whitespace? (string-ref str i))) - (string-append (substring str 0 (if (<= i 40) + (string-append (substring str 0 (if (<= i 40) (- target-line-length 6) i)) "..."))))) @@ -389,7 +389,7 @@ (denote (truncated-list->string form) ;; return form -> string with limits on its length (lint-truncate-string (object->string form #t target-line-length))) - + (define lint-pp #f) ; avoid crosstalk with other schemes' definitions of pp and pretty-print (make-lint-var also collides) (define lint-pp-funclet #f) (let () @@ -397,7 +397,7 @@ (set! lint-pp pp) (set! lint-pp-funclet (funclet pretty-print)) (set! (lint-pp-funclet '*pretty-print-cycles*) #f)) - + (denote (lists->string f1 f2) (let ((str1 (lint-truncate-string (object->string f1 #t (+ target-line-length 2))))) (if (> (tree-leaves f2) 10) @@ -409,7 +409,7 @@ (if (< (+ (length str1) (length str2)) target-line-length) (format #f "~A -> ~A" str1 str2) (format #f "~%~NC~A ->~%~NC~A" pp-left-margin #\space str1 pp-left-margin #\space str2)))))) - + (define (truncated-lists->string f1 f2) ;; same but 2 strings that may need to be lined up vertically and both are truncated (let ((str1 (lint-truncate-string (object->string f1 #t (+ target-line-length 2)))) @@ -417,15 +417,15 @@ (if (< (+ (length str1) (length str2)) target-line-length) (format #f "~A -> ~A" str1 str2) (format #f "~%~NC~A ->~%~NC~A" pp-left-margin #\space str1 pp-left-margin #\space str2)))) - + (define made-suggestion 0) (denote (lint-format str caller . args) (let ((outstr (if *report-laconically* (apply format #f str args) - (apply format #f + (apply format #f (string-append (if (and line-number (> line-number 0)) - "~NC~A (line ~D): " + "~NC~A (line ~D): " "~NC~A: ") str "~%") lint-left-margin #\space @@ -447,8 +447,8 @@ (format #f " (line ~D)" tree-line) ""))) - - ;; -------- vars -------- + + ;; -------- vars -------- (denote (var? v) (and (pair? v) (let? (cdr v)))) (denote var-ref (dilambda (lambda (v) (let-ref (cdr v) 'ref)) (lambda (v x) (let-set! (cdr v) 'ref x)))) (denote var-set (dilambda (lambda (v) (let-ref (cdr v) 'set)) (lambda (v x) (let-set! (cdr v) 'set x)))) @@ -461,16 +461,16 @@ (denote var-scope (dilambda (lambda (v) (let-ref (cdr v) 'scope)) (lambda (v x) (let-set! (cdr v) 'scope x)))) (denote var-setters (dilambda (lambda (v) (let-ref (cdr v) 'setters)) (lambda (v x) (let-set! (cdr v) 'setters x)))) (denote var-env (dilambda (lambda (v) (let-ref (cdr v) 'env)) (lambda (v x) (let-set! (cdr v) 'env x)))) - (denote (var-arity v) + (denote (var-arity v) (let ((val (let-ref (cdr v) 'arit))) (and (not (eq? val #<undefined>)) val))) (denote var-match-list (dilambda (lambda (v) (let-ref (cdr v) 'match-list)) (lambda (v x) (let-set! (cdr v) 'match-list x)))) (denote (var-initial-value v) (let-ref (cdr v) 'initial-value)) ; not (easily) settable - (denote var-refenv - (dilambda (lambda (v) - (let-ref (cdr v) 'refenv)) + (denote var-refenv + (dilambda (lambda (v) + (let-ref (cdr v) 'refenv)) (lambda (v e) (let ((old-e (let-ref (cdr v) 'refenv))) (if (null? old-e) ; nil if unset @@ -479,26 +479,26 @@ (let-set! (cdr v) 'refenv #f)))) e))) - (denote var-side-effect - (dilambda (lambda (v) + (denote var-side-effect + (dilambda (lambda (v) (case (let-ref (cdr v) 'side-effect) ((()) (let-set! (cdr v) 'side-effect (get-side-effect v))) (else))) - (lambda (v x) + (lambda (v x) (let-set! (cdr v) 'side-effect x)))) - - (denote var-signature - (dilambda (lambda (v) + + (denote var-signature + (dilambda (lambda (v) (case (let-ref (cdr v) 'sig) ((()) (let-set! (cdr v) 'sig (get-signature v))) (else))) (lambda (v x) (if (defined? 'sig (cdr v) #t) (let-set! (cdr v) 'sig x))))) ; perhaps fallback on varlet here and in var-ftype above? - + (denote (make-lint-var name initial-value definer) (let ((old (or (hash-table-ref other-identifiers name) ()))) - (if (pair? old) + (if (pair? old) (hash-table-set! other-identifiers name #f) ; remove name ) #| @@ -509,17 +509,17 @@ |# (cons name (inlet 'env () 'setters () - 'definer definer - 'set 0 - 'initial-value initial-value + 'definer definer + 'set 0 + 'initial-value initial-value 'scope () 'refenv () 'ref (length old) - 'history (if initial-value + 'history (if initial-value (cons initial-value old) old))))) - - + + ;; -------- the usual list functions -------- (denote (len=1? x) @@ -551,7 +551,7 @@ (and (integer? len) (positive? len) (list-ref x (- len 1))))) - + (denote (proper-pair? x) (and (pair? x) (proper-list? (cdr x)))) @@ -563,31 +563,31 @@ (define (remove-one item sequence) (cond ((not (pair? sequence)) sequence) ((equal? item (car sequence)) (cdr sequence)) - (else (cons (car sequence) + (else (cons (car sequence) (remove-one item (cdr sequence)))))) - + (define (remq-set items sequence) - (cond ((not (pair? sequence)) + (cond ((not (pair? sequence)) sequence) - ((memq (car sequence) items) + ((memq (car sequence) items) (remq-set items (cdr sequence))) (else - (cons (car sequence) + (cons (car sequence) (remq-set items (cdr sequence)))))) - + (define (remove-all item sequence) (map (lambda (x) (if (equal? x item) (values) x)) sequence)) - + (define (remove-if p lst) (cond ((not (pair? lst)) lst) ((p (car lst)) (remove-if p (cdr lst))) (else (cons (car lst) (remove-if p (cdr lst)))))) - + (denote (lint-remove-duplicates lst env) (reverse (let rem-dup ((lst lst) (nlst ())) @@ -597,15 +597,15 @@ (side-effect? (car lst) env)))) (rem-dup (cdr lst) nlst)) (else (rem-dup (cdr lst) (cons (car lst) nlst))))))) - + (define applicable? arity) - + (denote (code-constant? x) (and (constant? x) (or (not (pair? x)) (eq? (car x) 'quote)))) - (denote lint-every? + (denote lint-every? (let ((+documentation+ "(lint-every? func sequence) returns #t if func approves of every member of the list sequence") (+signature+ '(boolean? procedure? list?))) (lambda (f sequence) @@ -623,12 +623,12 @@ (or (null? sequence) (and (symbol? (car sequence)) (just-symbols? (cdr sequence))))) - + (denote (just-keywords? sequence) (or (null? sequence) (and (keyword? (car sequence)) (just-keywords? (cdr sequence))))) - + (denote (just-integers? sequence) (or (null? sequence) (and (integer? (car sequence)) @@ -643,7 +643,7 @@ (or (null? sequence) (and (real? (car sequence)) (just-reals? (cdr sequence))))) - + (denote (just-len>1? sequence) (or (null? sequence) (and (len>1? (car sequence)) @@ -654,7 +654,7 @@ (and (code-constant? (car sequence)) (just-code-constants? (cdr sequence))))) - (denote lint-any? + (denote lint-any? (let ((+documentation+ "(lint-any? func sequence) returns #t if func approves of any member of the list sequence") (+signature+ '(boolean? procedure? list?))) (lambda (f sequence) @@ -671,13 +671,13 @@ (and (pair? sequence) (or (keyword? (car sequence)) (any-keywords? (cdr sequence))))) - + (denote (any-numbers? sequence) (and (pair? sequence) (or (number? (car sequence)) (any-numbers? (cdr sequence))))) - - (denote lint-find-if + + (denote lint-find-if (let ((+documentation+ "(lint-find-if func lst) applies func to each member of the list lst.\n\ If func approves of one, find-if returns that member of the sequence") (+signature+ '(#t procedure? list?))) @@ -692,17 +692,17 @@ (define (collect-if-rational lst) (map (lambda (x) (if (rational? x) x (values))) lst)) - + (define (collect-if-integer lst) (map (lambda (x) (if (integer? x) x (values))) lst)) (define (collect-if-real lst) (map (lambda (x) (if (real? x) x (values))) lst)) - + (define (collect-if-not-number lst) (map (lambda (x) (if (number? x) (values) x)) lst)) - - + + ;; -------- trees -------- (define (proper-tree? tree) @@ -748,7 +748,7 @@ (and (pair? b) (eq? a (car b))))))) (shadow? (cddr tree)))) - (else + (else (or (shadow? (car tree)) (shadow? (cdr tree)))))))))) @@ -771,7 +771,7 @@ (not (memq tree syms))) (set! syms (cons tree syms))))) syms)) - + (define (tree-arg-member sym tree) (and (proper-list? tree) (or (and (memq sym (cdr tree)) @@ -788,7 +788,7 @@ => return))) (cdr tree)) #f)))))) - + (define (tree-member sym tree1) ; tree-memq ignoring quote and no match if tree1 == bare sym -- nearly all of these "members" should be "memqs" (let tm ((tree tree1)) (and (pair? tree) @@ -805,7 +805,7 @@ (define (tree-unquoted-member sym tree) (and (pair? tree) (tree-memq sym tree))) - + (define (tree-car-member sym tree) (and (pair? tree) (or (eq? (car tree) sym) @@ -813,7 +813,7 @@ (tree-car-member sym (car tree))) (and (pair? (cdr tree)) (member sym (cdr tree) tree-car-member))))) - + (define (tree-sym-set-member sym set tree) ; sym as arg, set as car (and (pair? tree) (or (memq (car tree) set) @@ -848,7 +848,7 @@ ((or (not (pair? p)) (tree-set-car-member set (car p))) (pair? p))))))) - + (define (tree-table-car-member set tree) ; hash-table as car (and (pair? tree) (or (and (hash-table-ref set (car tree)) @@ -860,10 +860,10 @@ ((or (not (pair? p)) (tree-table-car-member set (car p))) (pair? p))))))) - + (define (maker? tree) (tree-table-car-member makers tree)) - + (define (tree-symbol-walk tree syms) (if (pair? tree) (case (car tree) @@ -882,15 +882,15 @@ (else (tree-symbol-walk (car tree) syms) (tree-symbol-walk (cdr tree) syms))))) - + (denote (unbegin x) ((if (and (pair? x) (list? (cdr x)) (eq? (car x) 'begin)) cdr list) x)) - - + + ;; -------- types -------- (denote (quoted-pair? x) @@ -902,7 +902,7 @@ (denote (quoted-undotted-pair? x) (and (quoted-pair? x) (positive? (length (cadr x))))) - + (denote (quoted-null? x) (and (len=2? x) (eq? (car x) 'quote) @@ -919,39 +919,39 @@ (null? (cdr x))) ;; no hits (in this context): (make-list 0 ...) (string->list "") (vector->list #()) (reverse ()) (copy ()) (append ()) (append) (else #f))))) - + (denote (quoted-not? x) (and (len=2? x) (eq? (car x) 'quote) (not (cadr x)))) - + (denote (quoted-symbol? x) (and (pair? x) (eq? (car x) 'quote) (pair? (cdr x)) (symbol? (cadr x)))) - + (define constant-expression? (let ((constant-functions (let ((ht (make-hash-table))) (for-each - (lambda (op) + (lambda (op) (set! (ht op) #t)) - '(* + - / < <= = > >= - abs acos acosh and angle append aritable? arity ash asin asinh assoc assq assv atan atanh + '(* + - / < <= = > >= + abs acos acosh and angle append aritable? arity ash asin asinh assoc assq assv atan atanh begin boolean? byte? byte-vector byte-vector? caaaar caaadr caaar caadar caaddr caadr caar cadaar cadadr cadar caddar cadddr caddr cadr c-pointer c-pointer? c-object? c-object-type car case cdaaar cdaadr cdaar cdadar cdaddr cdadr cdar cddaar cddadr cddar cdddar cddddr cdddr cddr cdr ceiling char->integer char-alphabetic? char-ci<=? - char-ci<? char-ci=? char-ci>=? char-ci>? char-downcase char-lower-case? char-numeric? + char-ci<? char-ci=? char-ci>=? char-ci>? char-downcase char-lower-case? char-numeric? char-position char-upcase char-upper-case? char-whitespace? char<=? char<? char=? char>=? char>? char? complex complex? cons continuation? cos constant? cosh cyclic-sequences - denominator dilambda? + denominator dilambda? eof-object? eq? equal? eqv? even? exact->inexact exact? exp expt - float? float-vector-ref float-vector? floor + float? float-vector-ref float-vector? floor gcd gensym? - hash-table-entries hash-table-ref hash-table? - imag-part immutable? inexact->exact inexact? infinite? inlet input-port? + hash-table-entries hash-table-ref hash-table? + imag-part immutable? inexact->exact inexact? infinite? inlet input-port? int-vector-ref int-vector? iterator-at-end? iterator-sequence integer->char integer-decode-float integer-length integer? iterator? keyword->symbol keyword? @@ -961,11 +961,11 @@ make-rectangular max member memq memv min modulo equivalent? nan? negative? not null? number->string number? numerator object->string odd? openlet? or output-port? - pair? port-closed? positive? + pair? port-closed? positive? setter signature procedure? proper-list? provided? quote quotient random-state? rational? rationalize real-part real? remainder reverse round - sequence? sin sinh square sqrt string->number string->symbol + sequence? sin sinh square sqrt string->number string->symbol string-ci<=? string-ci<? string-ci=? string-ci>=? string-ci>? string-downcase string-length string-position string-ref string-upcase string<=? string<? string=? string>=? string>? string? substring subvector? symbol symbol->keyword symbol->string symbol? syntax? @@ -981,7 +981,7 @@ (not (var-member (car val) env)) (just-code-constants? (cdr val))))))) - + ;; -------- func info -------- (define (arg-signature fnc e) (and (symbol? fnc) @@ -990,24 +990,24 @@ (and (symbol? (var-ftype fd)) (var-signature fd)) (signature (symbol->value fnc)))))) - + (define (arg-arity fnc env) (and (symbol? fnc) (cond ((var-member fnc env) => var-arity) - (else + (else (let ((f (symbol->value fnc (rootlet)))) (and (procedure? f) (arity f))))))) - + (define (dummy-func caller form f) - (catch #t + (catch #t (lambda () (eval f)) (lambda args (lint-format "in ~A, ~A" caller (truncated-list->string form) (apply format #f (cadr args)))))) - + (define (count-values body) (let ((mn #f) (mx #f)) @@ -1019,7 +1019,7 @@ (if (pair? (cdr tree)) (let ((args (- (length tree) 1))) (for-each (lambda (p) - (if (and (pair? p) + (if (and (pair? p) (eq? (car p) 'values)) (set! args (- (+ args (length p)) 2)))) (cdr tree)) @@ -1032,7 +1032,7 @@ (member #f (cdr tree) counter))))) #f)) ; return #f so member doesn't quit early (and mn (list mn mx)))) - + (define (get-signature v) (let ((ftype (var-ftype v)) @@ -1046,7 +1046,7 @@ (cond ((not (pair? endb)) (and (not (symbol? endb)) (list (->lint-type endb)))) - + ((side-effect? endb env) (list (case (car endb) ((display write) @@ -1059,10 +1059,10 @@ => ->lint-type) (else #t)))) - - ((arg-signature (car endb) env) + + ((arg-signature (car endb) env) => (lambda (a) - (and (pair? a) + (and (pair? a) (list (car a))))) (else (let ((len (length endb))) @@ -1072,25 +1072,25 @@ (let ((a1 (signer (caddr endb))) (a2 (signer (cadddr endb)))) (and (equal? a1 a2) a1)))) - + ((let let* letrec letrec* unless when with-let let-temporarily with-baffle) (and (> len 2) (signer (list-ref endb (- len 1))))) - + ((begin) (and (> len 1) (signer (list-ref endb (- len 1))))) - + ((do) (and (> len 2) (pair? (caddr endb)) (pair? (cdaddr endb)) ; if nil -> unspecified? (signer (last-ref (cdaddr endb))))) - + (else #f)))))))) (if (not (pair? sig)) (set! sig (list #t))) - + (when (and (proper-list? arglist) (not (any-keywords? arglist))) (for-each @@ -1106,8 +1106,8 @@ (if (pair? m) (let ((fsig (arg-signature f env))) (if (pair? fsig) - (let ((chk (catch #t - (lambda () + (let ((chk (catch #t + (lambda () (fsig (- (length p) (length m)))) (lambda args #f)))) (if (and (symbol? chk) ; it defaults to #t @@ -1118,27 +1118,27 @@ (reverse sig))))))) (denote (args->proper-list args) - (cond ((symbol? args) + (cond ((symbol? args) (list args)) ((not (pair? args)) ()) - ((pair? (car args)) + ((pair? (car args)) (cons (caar args) (args->proper-list (cdr args)))) ((keyword? (car args)) ; omit :rest et al (args->proper-list (cdr args))) - (else + (else (cons (car args) (args->proper-list (cdr args)))))) - + (define (out-vars func-name arglist body) (let ((ref ()) (set ())) - - (define (var-walk-body tree e) + + (define (var-walk-body tree e) (when (pair? tree) (for-each (lambda (p) (set! e (var-walk p e))) tree))) - (define (shadowed v e) - (if (and (or (memq v e) + (define (shadowed v e) + (if (and (or (memq v e) (memq v ref)) (not (memq v set))) (set! set (cons v set))) @@ -1146,8 +1146,8 @@ (define (var-walk tree e) (if (symbol? tree) - (if (not (or (memq tree e) - (memq tree ref) + (if (not (or (memq tree e) + (memq tree ref) (defined? tree (rootlet)))) (set! ref (cons tree ref))) (when (pair? tree) @@ -1158,8 +1158,8 @@ (var-walk (car tree) e) (var-walk (cadr tree) e)) (case (car tree) - ((set! vector-set! list-set! hash-table-set! float-vector-set! int-vector-set! - string-set! let-set! fill! string-fill! list-fill! vector-fill! + ((set! vector-set! list-set! hash-table-set! float-vector-set! int-vector-set! + string-set! let-set! fill! string-fill! list-fill! vector-fill! reverse! sort! set-car! set-cdr!) (let ((sym (if (symbol? (cadr tree)) (cadr tree) @@ -1167,7 +1167,7 @@ (if (not (or (memq sym e) (memq sym set))) (set! set (cons sym set))) (var-walk (cddr tree) e))) - + ((let letrec) (let* ((named (symbol? (cadr tree))) (vars (if named @@ -1181,7 +1181,7 @@ (set! vars (cons (shadowed (car v) e) vars)))) ((if named caddr cadr) tree))) (var-walk-body ((if named cdddr cddr) tree) (append vars e)))) - + ((let* letrec*) (let* ((named (symbol? (cadr tree))) (vars (if named (list (cadr tree)) ())) @@ -1193,21 +1193,21 @@ (set! vars (cons (shadowed (car v) e) vars)))) varlist)) (var-walk-body ((if named cdddr cddr) tree) (append vars e)))) - + ((case) (var-walk (cadr tree) e) - (for-each (lambda (c) - (when (pair? c) + (for-each (lambda (c) + (when (pair? c) (var-walk (cdr c) e))) (cddr tree))) - + ((quote) #f) - + ((do) (let ((vars ())) (when (pair? (cadr tree)) (for-each (lambda (v) - (when (len>1? v) + (when (len>1? v) (var-walk (cadr v) e) (set! vars (cons (shadowed (car v) e) vars)))) (cadr tree)) @@ -1217,15 +1217,15 @@ (cadr tree))) (var-walk (caddr tree) (append vars e)) (var-walk-body (cdddr tree) (append vars e)))) - + ((lambda lambda*) (var-walk-body (cddr tree) (append (args->proper-list (cadr tree)) e))) - + ((define* define-macro define-macro* define-bacro define-bacro*) (when (pair? (cadr tree)) (set! e (cons (caadr tree) e)) (var-walk-body (cddr tree) (append (args->proper-list (cdadr tree)) e)))) - + ((define define-constant) (cond ((symbol? (cadr tree)) (var-walk (caddr tree) e) @@ -1253,7 +1253,7 @@ (let ((fv (copy v))) (let-set! (cdr fv) 'side-effect #f) (set! env (cons fv env))) - (lint-any? (lambda (f) + (lint-any? (lambda (f) (side-effect-with-vars? f env outvars)) body)))))) @@ -1266,10 +1266,10 @@ ((eq? (car tree) 'quote) (copy tree)) - + (else (cons (tree-subst new old (car tree)) (tree-subst new old (cdr tree)))))) - + (define (do->make-list caller form original-form var1 var2) ; (var1: (... (+/-)) var2: (... (cons))) (when (and (len=2? (cdr var2)) @@ -1286,13 +1286,13 @@ ;; end: (= i 10), result: (lst) (end (and (pair? (caddr form)) (caaddr form))) (result (and (pair? (caddr form)) (cdaddr form)))) - + ;; the equivalent named let: ;; (let loop ((i 0) (lst ())) (if (= i 10) lst (loop (+ i 1) (cons 1 lst)))) - + (when (eq? (car end) 'negative?) (set! end `(< ,(cadr end) 0))) - + (when (and (len=1? result) (eq? name2 (caddr step2)) (eq? name1 (cadr end)) @@ -1306,19 +1306,19 @@ (and (eq? name1 (cadr step1)) ; (- i 1) (eqv? 1 (caddr step1)) (memq (car end) '(= <= <))))) - + (let ((fill (cadr step2))) (cond ((or (not (pair? fill)) (eq? (car fill) 'quote) (not (tree-memq name1 fill))) ; perhaps if (pair? fill) check somehow for changing fill values (unless (eq? name1 fill) ; "iota" in this case - (let ((len (cond + (let ((len (cond ((and (integer? init1) (integer? (caddr end))) (if (memq (car end) '(> <)) (+ (abs (- init1 (caddr end))) 1) (abs (- init1 (caddr end))))) - + ((eq? (car step1) '+) (if (eqv? init1 0) (if (eq? (car end) '>) @@ -1327,17 +1327,17 @@ (if (eq? (car end) '>) `(+ (- ,(caddr end) ,init1) 1) `(- ,(caddr end) ,init1)))) - + ;; else (car step1) is '- ((eqv? (caddr end) 0) (if (eq? (car end) '<) `(+ ,init1 1) init1)) - + ((eq? (car end) '<) `(+ (- ,init1 ,(caddr end)) 1)) (else `(- ,init1 ,(caddr end)))))) - + (lint-format "perhaps ~A~A" caller (if (and (pair? fill) (not (eq? (car fill) 'quote))) @@ -1345,27 +1345,27 @@ "") (lists->string original-form `(make-list ,len ,fill)))))) - + ((and (memq (car fill) '(string-ref vector-ref)) (len=3? fill) (or (eq? (caddr fill) name1) (equal? (caddr fill) `(- ,name1 1)))) (lint-format "perhaps ~A" caller - (format #f "~A -> ~A" original-form + (format #f "~A -> ~A" original-form (if (eq? (car fill) 'string-ref) 'string->list 'vector->list)))) - + ((and (len=2? fill) (len=3? (cadr fill)) (memq (caadr fill) '(vector-ref string-ref byte-vector-ref float-vector-ref int-vector-ref list-ref)) (eq? name1 (caddr (cadr fill)))) (lint-format "perhaps ~A" caller - (format #f "~A -> ~A" original-form + (format #f "~A -> ~A" original-form `(map ,(car fill) ,(cadadr fill))))))))))) - - (define recursion->iteration - (let ((rewrite-map + + (define recursion->iteration + (let ((rewrite-map (lambda (map? name iter sequence form outer-form) - (let* ((new-form (cons 'lambda + (let* ((new-form (cons 'lambda (cons (list '<1>) (let rem ((tree form)) (cond ((not (unquoted-pair? tree)) @@ -1403,24 +1403,24 @@ (when (and (pair? initial-value) (proper-pair? arglist) (= (tree-count name (cddr initial-value) 2) 1)) - + (let ((body ((if (memq ftype '(let let*)) cdddr cddr) initial-value)) (for-each-case #f)) ; avoid rewriting twice (when (and (len=1? body) (len>1? (car body)) (let ((exprs (cdar body))) (case (caar body) ; change body to use if - ((if) ; only 1 hit for 2 reversal branches, say 20 hits for 2 ifs + repeated return vals (collapsible) -- see tmp + ((if) ; only 1 hit for 2 reversal branches, say 20 hits for 2 ifs + repeated return vals (collapsible) -- see tmp (len>1? exprs)) ((when) (and (len>1? exprs) - (set! body `((if ,(car exprs) - ,@(if (null? (cddr exprs)) - (cdr exprs) + (set! body `((if ,(car exprs) + ,@(if (null? (cddr exprs)) + (cdr exprs) (list (cons 'begin (cdr exprs))))))))) ((unless) (and (len>1? exprs) - (set! body `((if (not ,(car exprs)) + (set! body `((if (not ,(car exprs)) ,@(if (null? (cddr exprs)) (cdr exprs) (list (cons 'begin (cdr exprs))))))))) @@ -1460,7 +1460,7 @@ (if (null? (cdr arg2)) arg2 `((begin ,@arg2)))))))))))) - + ;; ((and or) (let ((last (last-ref exprs))) (if (and (pair? last) (eq? (car last) name)) (format *stderr* "~S~%" body)) #f)) ;; -> ((or done? (loop (process-stderr server)))) etc ;; zillions of or/and (well, 200) -- the problem is the result, and do is not shorter @@ -1472,8 +1472,8 @@ ;; memx here might be shorter if var is a list (else #f)))) - - ;; (caar body) is 'if + + ;; (caar body) is 'if ;; 2 arg map case (when (and (= (length arglist) 2) @@ -1481,16 +1481,16 @@ (let ((args (caddr initial-value))) (let ((iter (car args)) (res (cadr args))) - + (when (and (len>1? iter) (any-null? (cadr iter))) (set! iter (cadr args)) (set! res (car args))) - + (when (and (len=2? res) (any-null? (cadr res)) (<= 2 (tree-count (car res) body 4) 3)) - + (let ((nf (cdar body))) ;((null? lst) (reverse...) (loop ...)) (when (and (len>2? nf) (pair? (car nf)) @@ -1536,26 +1536,26 @@ ;; so whatever recur has, its only return exprs are (cons|append ... res) or res ;; but what about the body above? -- we have (body ... recur) and need to edit just recur ;; if (eq? name (car cdrf)) return edited recur else (body[-1]+edited recur) - + (let ((nmap (call-with-exit (lambda (quit) (let subst ((tree recur)) (cond ((eq? tree res-name) (quit #f)) - + ((not (unquoted-pair? tree)) tree) - + ((and (eq? (car tree) 'cons) (eq? res-name (caddr tree))) (cadr tree)) - + ((eq? (car tree) 'append) (if (and (len=3? tree) (eq? (caddr tree) res-name)) (list 'apply 'values (cadr tree)) (quit #f))) - + ((and (eq? (car tree) 'if) (len=3? (cdr tree)) (not (tree-memq res-name (cadr tree))) @@ -1567,17 +1567,17 @@ (if (eq? (cadddr tree) res-name) '(values) (subst (cadddr tree))))) - + (else (cons (subst (car tree)) (subst (cdr tree)))))))))) (if (pair? nmap) - (set! for-each-case (rewrite-map #t name iter-name (cadr iter) + (set! for-each-case (rewrite-map #t name iter-name (cadr iter) (if (eq? (car cdrf) name) (copy (unbegin nmap)) (tree-subst nmap recur cdrf)) initial-value)))))))))))) ;; for two arg for-each gets about a dozen hits - + ;; one arg... (when (null? (cdr arglist)) ;; recursion -> for-each and map @@ -1591,7 +1591,7 @@ ((lambda lambda*) (caadr initial-value)) (else (cadadr initial-value))))) - + (when (len>1? nf) (when (and (pair? (cddr nf)) (pair? (car nf)) @@ -1623,13 +1623,13 @@ (len>1? (cdaddr cdrf)) (equal? (cadr (caadr cdrf)) (list 'car iter)) (equal? (caddr (caddr cdrf)) (list name (list 'cdr iter))) - (set! cdrf (list 'cons + (set! cdrf (list 'cons (tree-subst (list 'car iter) (caaadr cdrf) (cadr (caddr cdrf))) (caddr (caddr cdrf)))))) (else #f))) (set! for-each-case (rewrite-map #t name iter sequence - (copy (unbegin (cadr cdrf))) + (copy (unbegin (cadr cdrf))) initial-value))))) (let ((iters ())) @@ -1656,11 +1656,11 @@ (eq? (car iters) (car arglist)) (or (equal? (car nf) (list 'pair? (car iters))) (equal? (car nf) (list 'not (list 'null? (car iters)))))) - (set! for-each-case (rewrite-map #f name + (set! for-each-case (rewrite-map #f name (car iters) sequence - (unbegin (copy (cadr nf) (make-list (- (length (cadr nf)) 1)))) + (unbegin (copy (cadr nf) (make-list (- (length (cadr nf)) 1)))) initial-value))))))) - + ;; any number of args here, still if-based as above ;; ;; recursion->do @@ -1669,15 +1669,15 @@ ;; ;; if (define loop (lambda ...)), then initial-value is (lambda ...) ;; but name is :lambda -- define-walker around 12440 catches this case and gives true name, so it calls this function - + (unless for-each-case ; one rewrite is enough (let ((f (cdar body))) (let ((end-test (car f)) ; assume (if test result recur) (result (cadr f)) - (do-body (if (pair? (cddr f)) - (caddr f) + (do-body (if (pair? (cddr f)) + (caddr f) (list 'begin)))) ; assume end in rewrite below is ,@(unbegin...) - + (when (tree-memq name result) ; flip above assumption: (if test recur result) (set! end-test (simplify-boolean (list 'not end-test) () () env)) (let ((old-res result)) @@ -1709,13 +1709,13 @@ (let ((do-loop `(do ,(map (lambda (par init arg) (let ((var (if (pair? par) (car par) par))) (if (eq? var arg) - (list var + (list var (if (len>1? init) (cadr init) init)) (list var (if (len>1? init) (cadr init) init) arg)))) arglist - (if (memq ftype '(let let*)) + (if (memq ftype '(let let*)) (caddr initial-value) (map (lambda (p) (if (pair? p) @@ -1724,7 +1724,7 @@ arglist)) (cdr call)) (,end-test ,@(unbegin result)) - ,@(if (eq? (car do-body) name) + ,@(if (eq? (car do-body) name) () (unbegin (copy do-body (make-list (- (length do-body) 1)))))))) (lint-format "perhaps ~A" name @@ -1759,8 +1759,8 @@ (when (and (len>1? body) (memq (car body) '(let let*)) (pair? (cadr body))) - (let* ((rest-name (if (symbol? arglist) - arglist + (let* ((rest-name (if (symbol? arglist) + arglist (list-tail arglist (abs (length arglist))))) (rest-refs (tree-count rest-name body 3))) @@ -1795,10 +1795,10 @@ (car var1)))))) (new-body (if (null? (cdadr body)) ; 0 other vars '... - (list (if (or (eq? (car body) 'let) + (list (if (or (eq? (car body) 'let) (null? (cddadr body))) ; 1 other var 'let 'let*) - (cdadr body) + (cdadr body) '...)))) ;; we're assuming that trailing args are a mistake -- we could add :rest or something to allow them (lint-format "perhaps ~A" name @@ -1808,7 +1808,7 @@ new-body) (list 'lambda* new-arglist new-body))))))))))))))))) - + (define form->arity (let ((max-arity 536870912)) (lambda (form) @@ -1824,7 +1824,7 @@ ((symbol? (cadr form)) (cons 0 max-arity)) (else #f))) - + ((define define-constant define-macro define-bacro) (cond ((list? (cdadr form)) (let ((len (length (cdadr form)))) @@ -1834,19 +1834,19 @@ ((symbol? (cdadr form)) (cons 0 max-arity)) (else #f))) - + ((let) ; let = named let (let ((len (length (caddr form)))) (cons len len))) - - ((let*) + + ((let*) (cons 0 (length (caddr form)))) - + ((lambda*) (let ((args (cadr form))) (cond ((list? args) (let ((len (length args)) - (rest (or (memq :rest args) + (rest (or (memq :rest args) (memq :allow-other-keys args)))) (cons 0 (if (or rest (negative? len)) max-arity @@ -1854,12 +1854,12 @@ ((symbol? args) (cons 0 max-arity)) (else #f)))) - + ((define* define-macro* define-bacro*) (let ((args (cdadr form))) (cond ((list? args) (let ((len (length args)) - (rest (or (memq :rest args) + (rest (or (memq :rest args) (memq :allow-other-keys args)))) (cons 0 (if (or rest (negative? len)) max-arity @@ -1867,7 +1867,7 @@ ((symbol? args) (cons 0 max-arity)) (else #f)))) - + ((defmacro) (cond ((list? (caddr form)) (let ((len (length (caddr form)))) @@ -1877,21 +1877,21 @@ ((symbol? (caddr form)) (cons 0 max-arity)) (else #f))) - + (else #f)))))) - + (define (report-shadower caller head vtype v expr env) (when (symbol? v) (if (var-member v env) (lint-format "~A ~A ~A in ~S shadows an earlier declaration" caller head vtype v expr) (if (defined? v (rootlet)) (lint-format "~A ~A ~A shadows built-in ~A" caller head vtype v v))))) - + (define (make-fvar name ftype arglist initial-value env) (unless (keyword? name) (recursion->iteration name ftype arglist initial-value env)) (improper-arglist->define* name ftype arglist initial-value) - + (when *report-shadowed-variables* (for-each (lambda (v) (report-shadower ftype name 'parameter v arglist env)) @@ -1901,17 +1901,17 @@ (allow-keys (and (pair? arglist) (memq ftype '(define* define-macro* define-bacro* defmacro*)) (eq? (last-ref arglist) :allow-other-keys))) - (nv (and (pair? initial-value) + (nv (and (pair? initial-value) (tree-memq 'values initial-value) (count-values (cddr initial-value))))) - (let ((hist (if old + (let ((hist (if old (begin (hash-table-set! other-identifiers name #f) ; remove name (if initial-value (cons initial-value old) old)) (if initial-value (list initial-value) ()))) (rf (if old (length old) 0)) (ar (form->arity initial-value))) - (cons name + (cons name (inlet 'allow-other-keys allow-keys 'setters () 'env env @@ -1921,7 +1921,7 @@ 'retcons #f 'arit ar 'arglist arglist - 'set 0 + 'set 0 'sig () 'side-effect () 'scope () @@ -1932,26 +1932,26 @@ 'ref rf)))))) (reduce-function-tree new env) new)) - + (define (return-type sym e) (let ((sig (arg-signature sym e))) (and (pair? sig) (or (eq? (car sig) 'values) ; turn it into #t for now (car sig))))) ; this might be undefined in the current context (eg oscil? outside clm) - + (define any-macro? (let ((macros (let ((h (make-hash-table))) - (for-each + (for-each (lambda (m) (set! (h m) #t)) - '(call-with-values let-values define-values let*-values cond-expand require quasiquote + '(call-with-values let-values define-values let*-values cond-expand require quasiquote multiple-value-bind reader-cond match while)) h))) (lambda (f env) (or (hash-table-ref macros f) (let ((fd (var-member f env))) (and fd - (memq (var-ftype fd) '(define-macro define-macro* define-expansion + (memq (var-ftype fd) '(define-macro define-macro* define-expansion define-bacro define-bacro* defmacro defmacro* define-syntax)))))))) (define (any-procedure? f v) @@ -1972,7 +1972,7 @@ ((procedure?) (if (dilambda? c) 'dilambda? 'procedure?)) (else))))) - + (define (define->type c) (and (pair? c) (case (car c) @@ -1987,7 +1987,7 @@ ((define-macro define-macro* define-bacro define-bacro* defmacro defmacro* define-expansion) 'macro?) ((:call/cc :call/exit) 'continuation?) (else #t)))) - + (define (->lint-type c) (cond ((not (pair? c)) (->simple-type c)) ((procedure? (car c)) (return-type (car c) ())) ; (#_abs ...) @@ -1996,7 +1996,7 @@ ((not (pair? (cdr c))) (->simple-type c)) ; ?? ((symbol? (cadr c)) 'symbol?) (else (->simple-type (cadr c))))) ; don't look for return type! - + (define (compatible? type1 type2) ; we want type1, we have type2 -- is type2 ok? (or (eq? type1 type2) (not (and (symbol? type1) @@ -2047,7 +2047,7 @@ ((file-exists?) (memq type2 '(string? sequence? directory?))) ;;((iterator-at-end?) (memq type2 '(iterator? sequence?))) (else #f)))) - + (define (any-compatible? type1 type2) ;; type1 and type2 can be either a list of types or a type (if (symbol? type1) @@ -2059,7 +2059,7 @@ (and (pair? type1) (or (compatible? (car type1) type2) (any-compatible? (cdr type1) type2))))) - + (define (subsumes? type1 type2) (or (eq? type1 type2) (case type1 @@ -2067,7 +2067,7 @@ ((rational?) (memq type2 '(integer? byte? exact? odd? even?))) ((exact?) (memq type2 '(integer? byte? rational?))) ((real?) (memq type2 '(integer? byte? rational? float? negative? positive? zero? odd? even?))) - ((complex? number?) (memq type2 '(integer? byte? rational? float? real? complex? number? negative? positive? zero? + ((complex? number?) (memq type2 '(integer? byte? rational? float? real? complex? number? negative? positive? zero? even? odd? exact? inexact? nan? infinite?))) ((list?) (memq type2 '(pair? null? proper-list?))) ((proper-list?) (eq? type2 'null?)) @@ -2078,7 +2078,7 @@ ((char?) (memq type2 '(char-whitespace? char-numeric? char-alphabetic? char-upper-case? char-lower-case?))) ((iterator) (eq? type2 'iterator-at-end?)) (else #f)))) - + (define (never-false expr) (or (eq? expr #t) (let ((type (if (pair? expr) @@ -2087,13 +2087,13 @@ (and (symbol? type) (not (symbol? expr)) (not (memq type '(boolean? values))))))) - + (define (never-true expr) (or (not expr) (and (len>1? expr) (eq? (car expr) 'not) (never-false (cadr expr))))) - + (define (prettify-checker-unq op) (if (pair? op) (string-append (prettify-checker-unq (car op)) " or " (prettify-checker-unq (cadr op))) @@ -2110,7 +2110,7 @@ (let ((op-name (symbol->string op))) (string-append (if (memv (op-name 0) '(#\a #\e #\i #\o #\u)) "an " "a ") (substring op-name 0 (- (length op-name) 1)))))))) - + (define (prettify-checker op) (if (pair? op) (string-append (prettify-checker-unq (car op)) " or " (prettify-checker (cadr op))) @@ -2122,10 +2122,10 @@ ((unspecified?) "untyped") ((undefined?) "not defined") ((not) "#f") - (else + (else (let ((op-name (symbol->string op))) (string-append (if (memv (op-name 0) '(#\a #\e #\i #\o #\u)) "an " "a ") op-name)))))) - + (define (side-effect-with-vars? form env vars) ;; could evaluation of form have any side effects (like IO etc) ;; vars is not null only in get-side-effect which is checking a function (in var-side-effect) @@ -2144,12 +2144,12 @@ ;; can't optimize ((...)...) because the car might eval to a function (or (and (not (hash-table-ref no-side-effect-functions (car form))) ; includes quote, let, etc ;; if it's not in the no-side-effect table and ... - + (let ((e (var-member (car form) env))) (or (not e) (not (symbol? (var-ftype e))) (var-side-effect e))) - + (or (not (eq? (car form) 'format)) ; (format #f ...) (not (pair? (cdr form))) ; (format)! (cadr form)) @@ -2157,13 +2157,13 @@ (or (null? vars) (not (memq (car form) '(set! define define* define-macro define-macro* define-bacro define-bacro*))))) - ;; it's not the common (format #f ...) special case, then...(goto case below) + ;; it's not the common (format #f ...) special case, then...(goto case below) ;; else return #t: side-effects are possible -- this is too hard to read (case (car form) ((define-constant define-expansion) #t) - ((define define* define-macro define-macro* define-bacro define-bacro* + ((define define* define-macro define-macro* define-bacro define-bacro* quote) #f) ;; was (null? vars) which (leaving aside quote) is never the case (see above) @@ -2171,7 +2171,7 @@ (or (not (pair? (cdr form))) (not (symbol? (cadr form))) (memq (cadr form) vars))) - + ((case) (or (not (pair? (cdr form))) (side-effect-with-vars? (cadr form) env vars) ; the selector @@ -2180,17 +2180,17 @@ (or (not (pair? (car f))) (lint-any? (lambda (ff) (side-effect-with-vars? ff env vars)) (cdar f)) (case-effect? (cdr f))))))) - + ((cond) (or (not (pair? (cdr form))) (not (pair? (cadr form))) (let cond-effect? ((f (cdr form)) (e env)) (and (pair? f) - (or (and (pair? (car f)) + (or (and (pair? (car f)) (lint-any? (lambda (ff) (side-effect-with-vars? ff e vars)) (car f))) (cond-effect? (cdr f) e)))))) - + ((let let* letrec letrec*) ;; here if the var value involves a member of vars, we have to add it to vars (or (< (length form) 3) @@ -2217,10 +2217,10 @@ (not (pair? (cdar f))) ; an error, reported elsewhere: (let ((x)) x) (side-effect-with-vars? (cadar f) e vars) (let-effect? (cdr f))))) - (lint-any? (lambda (ff) + (lint-any? (lambda (ff) (side-effect-with-vars? ff e vars)) body))))) - + ((do) (or (< (length form) 3) (not (list? (cadr form))) @@ -2235,9 +2235,9 @@ (do-effect? (cdr f) e)))) (lint-any? (lambda (ff) (side-effect-with-vars? ff env vars)) (caddr form)) (lint-any? (lambda (ff) (side-effect-with-vars? ff env vars)) (cdddr form)))) - + ;; ((lambda lambda*) (lint-any? (lambda (ff) (side-effect-with-vars? ff env vars)) (cddr form))) ; this is trickier than it looks - + (else (or (lint-any? (lambda (f) ; any subform has a side-effect (and (not (null? f)) @@ -2256,7 +2256,7 @@ (return #t))) (cdr sig) (cdr form)) #f)))))))))) - + (define (side-effect? form env) (side-effect-with-vars? form env ())) @@ -2283,14 +2283,14 @@ (unless (or (memq caller (var-scope v)) (assq caller (var-scope v))) (let ((cv (var-member caller env))) - (set! (var-scope v) + (set! (var-scope v) (cons (if (and cv (memq (var-ftype cv) '(define lambda define* lambda*))) ; named-let does not define ftype caller (cons caller env)) (var-scope v)))))) - - (define check-for-bad-variable-name + + (define check-for-bad-variable-name (let ((bad-var-names ()) (sname #f) (slen #f) (s0 #f)) (define (initialize-bad-var-names vars) @@ -2300,7 +2300,7 @@ (cond ((assq (string-ref name 0) bad-var-names) => (lambda (cur) (set! (cdr cur) (cons (list n name (length name)) (cdr cur))))) - (else + (else (set! bad-var-names (cons (list (string-ref name 0) (list n name (length name))) bad-var-names)))))) vars)) (initialize-bad-var-names *report-bad-variable-names*) @@ -2315,7 +2315,7 @@ (set! sname (symbol->string vname)) ;(if (keyword? vname) (keyword->symbol vname) vname))) (set! slen (length sname)) (set! s0 (string-ref sname 0)) - + (cond ((assq s0 bad-var-names) => (lambda (baddies) (if (or (assq vname (cdr baddies)) @@ -2324,40 +2324,40 @@ (string->number (substring sname (caddr b))))) (cdr baddies))) (lint-format "surely there's a better name for this variable than ~A" caller vname))))) - + (if (> slen *report-ridiculous-variable-names*) (lint-format "the name ~A (~A chars!) is unreadable" caller vname slen) - + (case s0 ((#\i) (if (eqv? (string-position "is-" sname) 0) ; is-x? -> x? (if (char=? (sname (- slen 1)) #\?) (lint-format "'~A is redundant: perhaps use '~A" caller vname (string->symbol (substring sname 3))) (lint-format "perhaps use '~A?, not '~A" caller (string->symbol (substring sname 3)) vname)))) - + ((#\c) (if (and (> slen 8) (or (string=? "compute" (substring sname 0 7)) ; compute-* is as bad as get-* (string=? "calculate" (substring sname 0 9)))) ; perhaps one exception: computed-goto* (lint-format "surely there's a better name for this variable than ~A" caller vname))) - - ((#\@) + + ((#\@) (lint-format "the name ~A will be problematic in quasiquote" caller vname)) ;; a check for other malformed numbers got no hits - - ((#\+) + + ((#\+) (if (memq vname '(+i +2i +0.i +1.0i +2.0i +2.i +3.141592653589793i)) (lint-format "~A is not a number" caller vname))) - - ((#\-) + + ((#\-) (if (memq vname '(-i -0.i -1.0i -2.0i -2i -3.141592653589793i -8.i -8i)) (lint-format "~A is not a number" caller vname))) - + ((#\|) (if (and *report-||-rewrites* (> slen 2) (eqv? (char-position #\| (substring sname 1)) (- slen 2))) ; starting at 1, so ends -2 - (lint-format "| is not a special character, so ~A is not the symbol ~A" caller + (lint-format "| is not a special character, so ~A is not the symbol ~A" caller vname (substring sname 1 (- slen 1)))))))))) (denote (set-ref name caller form env) @@ -2377,7 +2377,7 @@ (hash-table-set! other-identifiers name (cons form (or old ()))))))) env) - + (denote (set-set name caller form env) (let ((data (var-member name env))) (when data @@ -2390,15 +2390,15 @@ (set! (var-refenv data) env)) (set! (var-signature data) #f) (set! (var-ftype data) #f)))) - - + + (denote (proper-list lst) ;; return lst as a proper list (if (not (pair? lst)) lst - (cons (car lst) - (if (pair? (cdr lst)) - (proper-list (cdr lst)) + (cons (car lst) + (if (pair? (cdr lst)) + (proper-list (cdr lst)) (case (cdr lst) ((())) (else => list)))))) (define (keywords lst count) @@ -2410,20 +2410,20 @@ (if (not (pair? clause)) (memq clause '(else #t)) (case (car clause) - ((memq memv member) + ((memq memv member) (and (= (length clause) 3) (cadr clause))) ((eq? eqv? = equal? char=? char-ci=? string=? string-ci=?) (and (= (length clause) 3) ((if (code-constant? (cadr clause)) caddr cadr) clause))) - ((or) + ((or) (and (pair? (cdr clause)) (eqv-selector (cadr clause)))) ((not null? eof-object? zero? boolean?) (and (pair? (cdr clause)) (cadr clause))) (else #f)))) - + (define (->eqf x) (case x ((char?) '(eqv? char=?)) @@ -2432,7 +2432,7 @@ ((string?) '(equal? string=?)) ((pair? vector? float-vector? int-vector? subvector? hash-table?) '(equal? equal?)) ((eof-object?) '(eq? eof-object?)) - (else + (else (if (and (len>1? x) (or (and (or (memq 'boolean? x) (memq 'not x)) @@ -2441,16 +2441,16 @@ (or (memq 'char? x) (memq 'integer? x))))) '(eqv? eqv?) '(#t #t))))) - + (define (eqf selector env) - (cond ((symbol? selector) + (cond ((symbol? selector) (if (and (or (hash-table-ref built-in-functions selector) (hash-table-ref syntaces selector)) (not (var-member selector env))) '(eq? eq?) '(#t #t))) - ((not (pair? selector)) + ((not (pair? selector)) (->eqf (->lint-type selector))) ((and (eq? (car selector) 'quote) @@ -2467,20 +2467,20 @@ (null? (cdr selector))) '(eq? eq?)) - ((symbol? (car selector)) + ((symbol? (car selector)) (let ((sig (arg-signature (car selector) env))) (if (pair? sig) (->eqf (car sig)) '(#t #t)))) (else '(#t #t)))) - + (define (unquoted x) (if (and (len=2? x) (eq? (car x) 'quote)) (cadr x) x)) - + (define (distribute-quote x) (map (lambda (item) (if (or (symbol? item) @@ -2488,7 +2488,7 @@ (list 'quote item) item)) x)) - + (define (focus-str str focus) (let ((len (length str))) (if (< len 40) @@ -2500,39 +2500,39 @@ (if (<= pos 20) (string-append (substring str 0 (min 60 (- len 1) (+ focus-len pos 20))) " ...") (string-append "... " (substring str (- pos 20) (min (- len 1) (+ focus-len pos 20))) " ..."))))))) - + (define check-star-parameters (let ((pi-arg (lambda (a b) (or (eq? b 'pi) (and (pair? b) (eq? (car b) 'pi)))))) (lambda (f args env) (if (lint-any? (lambda (k) (memq k '(:key :optional))) args) (let ((kw (if (memq :key args) :key :optional))) - (format outport "~NC~A: ~A is no longer accepted: ~A~%" lint-left-margin #\space f kw + (format outport "~NC~A: ~A is no longer accepted: ~A~%" lint-left-margin #\space f kw (focus-str (object->string args) (symbol->string kw))))) - + (if (member 'pi args pi-arg) - (format outport "~NC~A: parameter can't be a constant: ~A~%" lint-left-margin #\space f + (format outport "~NC~A: parameter can't be a constant: ~A~%" lint-left-margin #\space f (focus-str (object->string args) "pi"))) - + (let ((r (memq :rest args))) (when (pair? r) (if (not (pair? (cdr r))) (format outport "~NC~A: :rest parameter needs a name: ~A~%" lint-left-margin #\space f args) (if (pair? (cadr r)) (format outport "~NC~A: :rest parameter can't specify a default value: ~A~%" lint-left-margin #\space f args))))) - + (let ((a (memq :allow-other-keys args))) (when (pair? a) (if (pair? (cdr a)) - (format outport "~NC~A: :allow-other-keys should be at the end of the parameter list: ~A~%" lint-left-margin #\space f + (format outport "~NC~A: :allow-other-keys should be at the end of the parameter list: ~A~%" lint-left-margin #\space f (focus-str (object->string args) ":allow-other-keys"))) (if (len=1? args) (format outport "~NC~A: :allow-other-keys can't be the only parameter: ~A~%" lint-left-margin #\space f args)))) - + (for-each (lambda (p) (if (len>1? p) (lint-walk f (cadr p) env))) args)))) - + (define (checked-eval form) (and (proper-list? form) ;(not (infinite? (length form))) but when would a dotted list work? (catch #t @@ -2540,7 +2540,7 @@ (eval (copy form))); :readable))) (lambda args :checked-eval-error)))) - + (define (eval/error caller form) (catch #t (lambda () @@ -2554,7 +2554,7 @@ (and (pair? ret) (memq type ret)))) - + (define last-and-incomplete-arg2 #f) (define (and-incomplete form head arg1 arg2 env) ; head: 'and | 'or (not ...) | 'if | 'if2 -- symbol arg1 in any case @@ -2594,10 +2594,10 @@ ((and if cond when) (list arg-type arg1)) ((or if2) (list 'not (list arg-type arg1)))))) (format outport "~NCin ~A~A,~%~NCperhaps change ~S to ~S~A~%" - lint-left-margin #\space + lint-left-margin #\space (truncated-list->string form) (if (and ln (> ln 0)) (format #f " (line ~D)" ln) "") - (+ lint-left-margin 4) #\space + (+ lint-left-margin 4) #\space old-arg new-arg comment)))))))) (define (and-redundant? arg1 arg2) @@ -2614,7 +2614,7 @@ (if (eq? type1 type2) type1 (case type1 - ((number? complex?) + ((number? complex?) (case type2 ((float? real? rational? integer?) type2) ((number? complex?) type1) @@ -2623,7 +2623,7 @@ (and (number? x) (if (= x (floor x)) 'memv 'eqv?)))) (else #f))) - + ((real?) (case type2 ((float? rational? integer?) type2) @@ -2632,10 +2632,10 @@ (and (real? x) (if (= x (floor x)) 'memv 'eqv?)))) (else #f))) - - ((float?) + + ((float?) (and (memq type2 '(real? complex? number? inexact?)) type1)) - + ((rational?) (case type2 ((integer?) type2) @@ -2645,7 +2645,7 @@ (rational? (cadr arg2))) 'eqv?)) (else #f))) - + ((integer?) (case type2 ((real? rational? complex? number? exact?) type1) @@ -2655,32 +2655,32 @@ (integer? (cadr arg2))) 'eqv?)) (else #f))) - - ((exact?) + + ((exact?) (and (memq type2 '(rational? integer?)) type2)) - - ((even? odd?) + + ((even? odd?) (and (memq type2 '(integer? rational? real? complex? number?)) type1)) ; not zero? -> 0.0 - - ((zero?) + + ((zero?) (and (memq type2 '(complex? number? real?)) type1)) - - ((negative? positive?) + + ((negative? positive?) (and (eq? type2 'real?) type1)) - - ((inexact?) + + ((inexact?) (and (eq? type2 'float?) type2)) - - ((infinite? nan?) + + ((infinite? nan?) (and (memq type2 '(number? complex? inexact?)) type1)) - - ((vector?) + + ((vector?) (and (memq type2 '(float-vector? int-vector?)) type2)) - - ((float-vector? int-vector?) + + ((float-vector? int-vector?) (and (eq? type2 'vector?) type1)) - - ((symbol?) + + ((symbol?) (case type2 ((keyword? gensym?) type2) ((eq?) @@ -2688,7 +2688,7 @@ (quoted-symbol? (caddr arg2))) 'eq?)) (else #f))) - + ((keyword?) (case type2 ((symbol? constant?) type1) @@ -2697,30 +2697,30 @@ (keyword? (caddr arg2))) 'eq?)) (else #f))) - - ((gensym? defined? provided?) + + ((gensym? defined? provided?) (and (eq? type2 'symbol?) type1)) - - ((boolean?) - (and (or (eq? type2 'not) + + ((boolean?) + (and (or (eq? type2 'not) (and (eq? type2 'eq?) (len=2? (cdr arg2)) (or (boolean? (cadr arg2)) (boolean? (caddr arg2))))) type2)) - - ((list?) + + ((list?) (and (memq type2 '(null? pair? proper-list?)) type2)) - - ((null?) + + ((null?) (and (memq type2 '(list? proper-list?)) type1)) - - ((pair?) + + ((pair?) (and (eq? type2 'list?) type1)) - - ((proper-list?) + + ((proper-list?) (and (eq? type2 'null?) type2)) - + ((string?) (case type2 ((string=?) @@ -2728,16 +2728,16 @@ (eq? (->lint-type (caddr arg2)) 'string?)) 'equal?)) (else #f))) - - ((char?) + + ((char?) (and (eq? type2 'char=?) (or (eq? (->lint-type (cadr arg2)) 'char?) (eq? (->lint-type (caddr arg2)) 'char?)) 'eqv?)) - - ((char-numeric? char-whitespace? char-alphabetic? char-upper-case? char-lower-case?) + + ((char-numeric? char-whitespace? char-alphabetic? char-upper-case? char-lower-case?) (and (eq? type2 'char?) type1)) - + ((directory?) (and (memq type2 '(string? file-exists?)) type1)) @@ -2746,10 +2746,10 @@ type1 (and (eq? type2 'directory?) type2))) - + (else #f)))))) - - + + (define (and-forgetful form head arg1 arg2 env) (unless (or (memq (car arg2) '(and or not list cons vector)) ; these don't tell us anything about arg1's type (eq? arg2 last-and-incomplete-arg2)) @@ -2782,12 +2782,12 @@ " ; or maybe sequence? " ""))) (set! last-and-incomplete-arg2 arg2) (format outport "~NCin ~A~A,~%~NCperhaps change ~S to ~S~A~%" - lint-left-margin #\space + lint-left-margin #\space (truncated-list->string form) (if (and ln (> ln 0)) (format #f " (line ~D)" ln) "") - (+ lint-left-margin 4) #\space + (+ lint-left-margin 4) #\space old-arg new-arg comment))))))) - + ;; perhaps change pair? -> eq? or ignore it? (when (and (pair? (cdr arg2)) (not (eq? (car arg1) 'pair?))) @@ -2821,10 +2821,10 @@ (symbol? new-e)) (let ((ln (and (< 0 line-number 100000) line-number))) (format outport "~NCin ~A~A,~%~NCperhaps change ~A to ~A~%" - lint-left-margin #\space + lint-left-margin #\space (truncated-list->string form) (if (and ln (> ln 0)) (format #f " (line ~D)" ln) "") - (+ lint-left-margin 4) #\space + (+ lint-left-margin 4) #\space (truncated-list->string a2) (list new-e '...))))))))) @@ -2855,9 +2855,9 @@ (B2 (caddr B))) (let ((x (if (and (not (number? A1)) (member A1 B)) - A1 + A1 (and (not (number? A2)) - (member A2 B) + (member A2 B) A2)))) (when x (let ((c1 (if (equal? x A1) A2 A1)) @@ -2869,7 +2869,7 @@ (return 'ok)) (if (equal? x A2) (set! op1 (caddr Adata))) (if (equal? x B2) (set! op2 (caddr Bdata))) - + (let ((typer #f) (gtes #f) (gts #f) @@ -2890,22 +2890,22 @@ (set! gtes '(string>=? string<=?)) (set! gts '(string<? string>?)) (set! eqop 'string=?))) - + (case rel-op ((and) (cond ((equal? c1 c2) (return (cond ((eq? op1 op2) (list op1 x c1)) - + ((eq? op2 (cadr (assq op1 relops))) (list (if (memq op2 gtes) op1 op2) x c1)) - + ((and (memq op1 gtes) (memq op2 gtes)) (list eqop x c1)) - + (else #f)))) - + ((and (typer c1) (typer c2)) (cond ((or (eq? op1 op2) @@ -2926,26 +2926,26 @@ ((eq? op2 (caddr (assq op1 relops))) (return (list op1 c2 x c1))))) - + ((or) (cond ((equal? c1 c2) (return (cond ((eq? op1 op2) (list op1 x c1)) - + ((eq? op2 (cadr (assq op1 relops))) (list (if (memq op2 gtes) op2 op1) x c1)) - + ((and (memq op1 gts) (memq op2 gts)) (list 'not (list eqop x c1))) - + (else #t)))) - + ((and (typer c1) (typer c2)) (cond ((or (eq? op1 op2) (eq? op2 (cadr (assq op1 relops)))) - (return (if ((symbol->value op1 (rootlet)) c1 c2) + (return (if ((symbol->value op1 (rootlet)) c1 c2) (list op2 x c2) (list op1 x c1)))) @@ -2980,7 +2980,7 @@ (if (and (symbol? (cadr args)) (code-constant? (car args))) (set! func (->lint-type (car args)))))) - + (if (symbol? func) (for-each (lambda (arg) @@ -2991,7 +2991,7 @@ (unless (compatible? (cdr type) func) (return #t)))))) args))))))))) - + (define (and-redundants env . args) (do ((locals ()) (diffs #f) @@ -3008,7 +3008,7 @@ (let ((next-a (cdr a))) (cond ((null? (cdr next-a)) (set! keepers (cons (car next-a) keepers))) - + ((null? (cddr next-a)) (let ((res (apply and-redundant? (reverse next-a)))) (if res @@ -3016,7 +3016,7 @@ (set! keepers (cons ((if (eq? res (caar next-a)) car cadr) next-a) keepers)) (set! diffs #t)) (set! keepers (cons (car next-a) (cons (cadr next-a) keepers)))))) - + (else (let ((ar (reverse next-a))) (let ((ar1 (car ar)) @@ -3056,7 +3056,7 @@ (set! diffs #t) (set-cdr! local (cons bool (cdr local)))) (set! locals (cons (list (cadr bool) bool) locals)))))) - + (define (and-not-redundant arg1 arg2) (let ((type1 (car arg1)) ; (? ...) (type2 (caadr arg2))) ; (not (? ...)) @@ -3067,115 +3067,115 @@ 'contradictory (and (hash-table-ref booleans type2) (case type1 - ((pair?) + ((pair?) (case type2 ((list? sequence?) 'contradictory) ((proper-list? tree-cyclic?) #f) (else arg1))) - - ((null?) + + ((null?) (if (memq type2 '(list? sequence? proper-list?)) 'contradictory arg1)) - - ((list?) + + ((list?) (case type2 ((pair?) 'null?) ((null?) 'pair?) ((proper-list? tree-cyclic?) #f) ((sequence?) 'contradictory) (else arg1))) - - ((proper-list?) + + ((proper-list?) (case type2 ((list? sequence?) 'contradictory) ((null?) #f) ((pair?) 'null?) (else arg1))) - - ((symbol?) - (and (not (memq type2 '(keyword? gensym? defined? provided?))) + + ((symbol?) + (and (not (memq type2 '(keyword? gensym? defined? provided?))) arg1)) - + ((keyword? gensym?) (and (eq? type2 'symbol?) 'contradictory)) - - ((char=?) + + ((char=?) (if (eq? type2 'char?) 'contradictory (and (or (char? (cadr arg1)) (char? (caddr arg1))) (cons 'eqv? (cdr arg1))))) ; arg2 might be (not (eof-object?...)) - - ((real?) + + ((real?) (case type2 ((rational? exact?) (cons float? (cdr arg1))) ((inexact?) (cons 'rational? (cdr arg1))) ((complex? number?) 'contradictory) ((negative? positive? even? odd? zero? integer? float? infinite? nan?) #f) (else arg1))) - - ((integer?) + + ((integer?) (case type2 ((real? complex? number? rational? exact?) 'contradictory) ((float? inexact? infinite? nan?) arg1) (else #f))) - - ((rational?) + + ((rational?) (case type2 ((real? complex? number? exact?) 'contradictory) ((float? inexact? infinite? nan?) arg1) (else #f))) - - ((complex? number?) + + ((complex? number?) (and (memq type2 '(complex? number?)) 'contradictory)) - - ((float?) + + ((float?) (case type2 ((real? complex? number? inexact?) 'contradictory) ((rational? integer? exact?) arg1) (else #f))) - - ((exact?) + + ((exact?) (case type2 ((rational?) 'contradictory) ((inexact? infinite? nan?) arg1) (else #f))) - - ((even? odd?) + + ((even? odd?) (case type2 ((integer? exact? rational? real? number? complex?) 'contradictory) ((infinite? nan?) arg1) (else #f))) - - ((zero? negative? positive?) + + ((zero? negative? positive?) (and (memq type2 '(complex? number? real?)) 'contradictory)) - - ((infinite? nan?) + + ((infinite? nan?) (case type2 ((number? complex? inexact? real?) 'contradictory) ((integer? rational? exact? even? odd?) arg1) (else #f))) - + ((float-vector? int-vector?) (and (memq type2 '(vector? sequence?)) 'contradictory)) - + ((string? let? hash-table? openlet? pair? vector?) (and (eq? type2 'sequence?) 'contradictory)) - + ((tree-cyclic?) (and (memq type2 '(sequence? list? pair?)) 'contradictory)) - + ((char-whitespace? char-numeric? char-alphabetic? char-upper-case? char-lower-case?) (and (eq? type2 'char?) 'contradictory)) - + ((directory? file-exists?) (and (memq type2 '(string? sequence?)) 'contradictory)) @@ -3183,11 +3183,11 @@ ((continuation? dilambda?) (and (eq? type2 'procedure?) 'contradictory)) - - (else + + (else ;; none of the rest happen #f))))))) - + (define (or-not-redundant arg1 arg2) (let ((type1 (car arg1)) ; (? ...) (type2 (caadr arg2))) ; (not (? ...)) @@ -3198,7 +3198,7 @@ 'true (and (hash-table-ref bools type2) (case type1 - ((null?) + ((null?) (case type2 ((list?) ; not proper-list? here (list 'not (list 'pair? (cadr arg1)))) @@ -3247,11 +3247,11 @@ (and (eq? type2 'iterator?) 'true)) (else #f))))))) - + (define (gather-or-eqf-elements eqfnc sym vals env) - (let* ((func (case eqfnc - ((eq?) 'memq) - ((eqv? char=?) 'memv) + (let* ((func (case eqfnc + ((eq?) 'memq) + ((eqv? char=?) 'memv) (else 'member))) (equals (if (and (eq? func 'member) (not (eq? eqfnc 'equal?))) @@ -3260,32 +3260,32 @@ (elements (lint-remove-duplicates (map unquoted vals) env))) (cond ((null? (cdr elements)) (cons eqfnc (cons sym elements))) - + ((and (eq? eqfnc 'char=?) (= (length elements) 2) (char-ci=? (car elements) (cadr elements))) (list 'char-ci=? sym (car elements))) - + ((and (eq? eqfnc 'string=?) (= (length elements) 2) (string-ci=? (car elements) (cadr elements))) (list 'string-ci=? sym (car elements))) - + ((member elements '((#t #f) (#f #t))) (list 'boolean? sym)) ; zero? doesn't happen ((and (eq? eqfnc '=) ; (or (= <expr> 20) (= <expr> 21)) -> (<= 20 <expr> 21) (pair? sym) (eq? (car sym) 'length) - (= (length elements) 2) ; this used to be -> (member '(20 21) =) + (= (length elements) 2) ; this used to be -> (member '(20 21) =) (integer? (car elements)) (integer? (cadr elements)) (= (abs (- (car elements) (cadr elements))) 1)) `(,(if (< (cadr elements) (car elements)) '<= '>=) ,(cadr elements) ,sym ,(car elements))) - - (else + + (else `(,func ,sym ',(reverse elements) ,@equals))))) - + (define (reversible-member expr lst) (and (pair? lst) (or (member expr lst) @@ -3293,21 +3293,21 @@ (let ((rev-op (hash-table-ref reversibles (car expr)))) (and rev-op (member (list rev-op (caddr expr) (cadr expr)) lst))))))) - + (define and-rel-ops (let ((h (make-hash-table))) (for-each (lambda (op) (hash-table-set! h op #t)) - '(< = > <= >= char-ci>=? char-ci<? char-ready? char<? char-ci=? char>? - char<=? char-ci>? char-ci<=? char>=? char=? string-ci<=? string=? + '(< = > <= >= char-ci>=? char-ci<? char-ready? char<? char-ci=? char>? + char<=? char-ci>? char-ci<=? char>=? char=? string-ci<=? string=? string-ci>=? string<? string-ci<? string-ci=? string-ci>? string>=? string<=? string>? eqv? equal? eq? equivalent?)) h)) - + (define (booleans-with-not? arg1 arg2 env) (and (eq? (car arg2) 'not) (len>1? (cadr arg2)) (equal? (cdr arg1) (cdadr arg2)))) - + (define (collect-nots start end) (if (eq? (cdr start) end) ; just one not (car start) @@ -3316,7 +3316,7 @@ ((eq? np end) (reverse nf)) (set! nf (cons (cadar np) nf))))) - + ;; -------- invert-successive-nots -------- (define (invert-successive-nots return form len env) (let ((nots 0) @@ -3341,17 +3341,17 @@ (cond ((= nots arglen) ; every arg is `(not ...) (let ((nf (simplify-boolean (cons new-head (map cadr (cdr form))) () () env))) (return (simplify-boolean (list 'not nf) () () env)))) - + ((and (> nots 1) ; if nots+revers=arglen, entire thing can be inverted (= (+ nots revers) arglen)) ; revers>0 because we checked for nots=arglen above - (return (simplify-boolean + (return (simplify-boolean (list 'not (cons new-head (map (lambda (p) (if (eq? (car p) 'not) (cadr p) (cons (hash-table-ref notables (car p)) (cdr p)))) (cdr form)))) () () env))) - + ((and (> arglen 2) (or (>= nots (/ (* 3 arglen) 4)) ; > 2/3 seems to get some ugly rewrites (and (>= nots (/ (* 2 arglen) 3)) ; was > 1/2 here @@ -3361,15 +3361,15 @@ (list 'not p)) ((eq? (car p) 'not) (cadr p)) - ((hash-table-ref notables (car p)) => + ((hash-table-ref notables (car p)) => (lambda (op) (cons op (cdr p)))) (else (list 'not p)))) (cdr form))))) (return (simplify-boolean (list 'not nf) () () env)))) - + ((> max-ctr 2) - (return (simplify-boolean + (return (simplify-boolean (cons (car form) (do ((start ()) (new-form ()) @@ -3390,7 +3390,7 @@ (set! start ())) (set! new-form (cons c new-form))))))) () () env)))))) - + ;; -------- or->memx -------- (define (or->memx return form env) (do ((sym #f) @@ -3406,7 +3406,7 @@ (equal? sym (eqv-selector p))) (or (not (memq eqfnc '(char-ci=? string-ci=? =))) (memq (car p) '(char-ci=? string-ci=? =))) - + ;; = can't share: (equal? 1 1.0) -> #f, so (or (not x) (= x 1)) can't be simplified ;; except via member+equivalent? but that brings in float-epsilon and NaN differences. ;; We could add both: 1 1.0 as in cond? @@ -3421,7 +3421,7 @@ ;; ;; I think I'll try to turn out a more-or-less working expression, but warn about it. - (case (car p) + (case (car p) ((string=? equal?) (set! eqfnc (if (or (not eqfnc) (eq? eqfnc (car p))) @@ -3442,16 +3442,16 @@ (set! vals (cons (cadr p) vals)) (and (code-constant? (caddr p)) (set! vals (cons (caddr p) vals)))))) - + ((eq? eqv?) (let ((leqf (car (->eqf (->lint-type ((if (code-constant? (cadr p)) cadr caddr) p)))))) - (cond ((not eqfnc) + (cond ((not eqfnc) (set! eqfnc leqf)) - + ((or (memq leqf '(#t equal?)) (not (eq? eqfnc leqf))) (set! eqfnc 'equal?)) - + ((memq eqfnc '(#f eq?)) (set! eqfnc leqf)))) (and (= (length p) 3) @@ -3459,7 +3459,7 @@ (set! vals (cons (cadr p) vals)) (and (code-constant? (caddr p)) (set! vals (cons (caddr p) vals)))))) - + ((char-ci=? string-ci=? =) (and (or (not eqfnc) (eq? eqfnc (car p))) @@ -3469,43 +3469,43 @@ (set! vals (cons (cadr p) vals)) (and (code-constant? (caddr p)) (set! vals (cons (caddr p) vals)))))) - + ((eof-object?) (set! eqfnc (case eqfnc ((string=? string-ci=? = equal?) 'equal?) ((#f eq?) 'eq?) (else 'eqv?))) (set! vals (cons #<eof> vals))) - + ((not) (set! eqfnc (case eqfnc ((string=? string-ci=? = equal?) 'equal?) ((#f eq?) 'eq?) (else 'eqv?))) (set! vals (cons #f vals))) - - ((boolean?) + + ((boolean?) (set! eqfnc (case eqfnc ((string=? string-ci=? = equal?) 'equal?) ((#f eq?) 'eq?) (else 'eqv?))) (set! vals (cons #f (cons #t vals)))) - + ((zero?) (if (memq eqfnc '(#f eq?)) (set! eqfnc 'eqv?)) (set! vals (cons 0 (cons 0.0 vals)))) - + ((null?) (set! eqfnc (case eqfnc ((string=? string-ci=? = equal?) 'equal?) ((#f eq?) 'eq?) (else 'eqv?))) (set! vals (cons () vals))) - + ((memq memv member) (cond ((eq? (car p) 'member) (set! eqfnc 'equal?)) - + ((eq? (car p) 'memv) (set! eqfnc (if (eq? eqfnc 'string=?) 'equal? 'eqv?))) - + ((not eqfnc) (set! eqfnc 'eq?))) (and (= (length p) 3) (quoted-pair? (caddr p)) (proper-list? (cadr (caddr p))) (set! vals (append (cadr (caddr p)) vals)))) - + (else #f))) - + (if (not start) (set! start fp) ; we're in a loop above... (if (and (proper-list? form) @@ -3514,10 +3514,10 @@ (gather-or-eqf-elements eqfnc sym vals env) `(or ,@(copy (cdr form) (make-list (do ((g (cdr form) (cdr g)) (len 0 (+ len 1))) - ((eq? g start) + ((eq? g start) len)))) ,(gather-or-eqf-elements eqfnc sym vals env)))))) - + ;; false branch of if above -- not consequent on previous (when (pair? start) (if (eq? fp (cdr start)) @@ -3536,13 +3536,13 @@ nfp))))) (return (if (eq? start (cdr form)) (cons 'or (cons (gather-or-eqf-elements eqfnc sym vals env) trailer)) - `(or ,@(copy (cdr form) (make-list (do ((g (cdr form) (cdr g)) + `(or ,@(copy (cdr form) (make-list (do ((g (cdr form) (cdr g)) (len 0 (+ len 1))) - ((eq? g start) + ((eq? g start) len)))) ,(gather-or-eqf-elements eqfnc sym vals env) ,@trailer)))))))))) - + ;; -------- or->case -------- (define (or->case return form) (do ((selector #f) ; (or (and (eq?...)...)....) -> (case ....) @@ -3566,24 +3566,24 @@ ;; we have to make sure no keys are repeated: ;; (or (and (eq? x 'a) (< y 1)) (and (eq? x 'a) (< y 2))) ;; this rewrite has become much trickier than expected... - + ((boolean?) (and (equal? selector arg1) (not (memq #f keys)) (not (memq #t keys)) (set! keys (cons #f (cons #t keys))))) - + ((eof-object?) (and (equal? selector arg1) (not (memq #<eof> keys)) (set! keys (cons #<eof> keys)))) - + ((zero?) (and (equal? selector arg1) (not (memv 0 keys)) (not (memv 0.0 keys)) (set! keys (cons 0.0 (cons 0 keys))))) - + ((memq memv) (and (equal? selector arg1) (pair? (cddr expr)) @@ -3592,7 +3592,7 @@ (memv g keys)) (cadr (caddr expr)))) (set! keys (append (cadr (caddr expr)) keys)))) - + ((eq? eqv? char=?) (and (len=1? (cddr expr)) (or (and (equal? selector arg1) @@ -3603,13 +3603,13 @@ (code-constant? arg1) (not (memv (unquoted arg1) keys)) (set! keys (cons (unquoted arg1) keys)))))) - + ((not) ;; no hits here for last+not eq(etc)+no collision in keys (and (equal? selector arg1) (not (memq #f keys)) (set! keys (cons #f keys)))) - + (else #f))))))) (if (null? fp) (return `(case ,selector @@ -3631,8 +3631,8 @@ (list key result))) (cdr form)) (else #f))))))) - - + + (define (classify e env) (if (not (just-constants? e env)) e @@ -3643,7 +3643,7 @@ val e))) (lambda ignore e)))) - + ;; -------- reduce-or -------- (define (reduce-or return form len true false env) (do ((new-form ()) @@ -3658,12 +3658,12 @@ (cons 'or (reverse new-form))))))) (let ((val (classify (car exprs) env)) (old-form new-form)) - + (when (and (pair? val) (memq (car val) '(and or not))) (set! val (classify (simplify-boolean val true false env) env)) (when (and (> len 3) - (len=2? val) ; pair? val needs to precede car val + (len=2? val) ; pair? val needs to precede car val (eq? (car val) 'not) (pair? (cdr exprs))) (if (symbol? (cadr val)) @@ -3696,21 +3696,21 @@ (set! retry #t)) (cond ((not val)) ; #f in or is ignored - + ((or (eq? val #t) ; #t or any non-#f constant in or ends the expression (code-constant? val)) (set! new-form (cons val ; (or x1 123) -> value of x1 first - (if (null? new-form) + (if (null? new-form) () new-form))) ;; reversed when returned (set! exprs '(#t))) - + ((and (pair? val) ; (or ...) -> splice into current (proper-list? val) (eq? (car val) 'or)) (set! exprs (append val (cdr exprs)))) ; we'll skip the 'or in do step - + ((not (or (memq val new-form) (and (len>1? val) ; and redundant tests (hash-table-ref booleans (car val)) @@ -3720,22 +3720,22 @@ (equal? (cadr val) (cadr p)))) new-form)))) (set! new-form (cons val new-form)))) - + (if (and (not (eq? new-form old-form)) (pair? (cdr new-form))) (let ((rel (relsub (cadr new-form) (car new-form) 'or env))) ; new-form is reversed (if (or (boolean? rel) (pair? rel)) (set! new-form (cons rel (cddr new-form))))))))) - + ;; -------- reduce-and -------- - (define reduce-and + (define reduce-and (let ((last-reduce-and-form #f)) ; try to reduce repetitive output (lambda (return form len false env) (do ((new-form ()) (retry #f) (exprs (cdr form) (cdr exprs))) - ((null? exprs) + ((null? exprs) (or (null? new-form) ; (and) -> #t (let ((newer-form (let ((nform (reverse new-form))) (map (lambda (x cdr-x) @@ -3746,7 +3746,7 @@ (return (cond ((null? newer-form) (car new-form)) - + ((and (eq? (car new-form) #t) ; trailing #t is dumb if next-to-last is boolean func (pair? (cdr new-form)) (pair? (cadr new-form)) @@ -3755,20 +3755,20 @@ (if (null? (cdr newer-form)) (car newer-form) (cons 'and newer-form))) - + (retry (simplify-boolean `(and ,@newer-form ,(car new-form)) () () env)) - + (else `(and ,@newer-form ,(car new-form)))))))) - + (let* ((e (car exprs)) (val (classify e env)) (old-form new-form)) - + (if (and (pair? val) (memq (car val) '(and or not))) (set! val (classify (set! e (simplify-boolean val () false env)) env)) - + (when (and (> len 3) (pair? (cdr exprs))) (if (symbol? val) @@ -3794,11 +3794,11 @@ (set! found-it p) (let ((ln (and (< 0 line-number 100000) line-number))) (format outport "~NCin ~A~A,~%~NCperhaps change ~S to ~S~%" - lint-left-margin #\space + lint-left-margin #\space (truncated-list->string form) (if (and ln (> ln 0)) (format #f " (line ~D)" ln) "") - (+ lint-left-margin 4) #\space - (list 'and '... val '... p) + (+ lint-left-margin 4) #\space + (list 'and '... val '... p) nval) (set! found-it #t))))) (and (pair? (car p)) @@ -3806,7 +3806,7 @@ (set! found-it (car p)))) (if (pair? found-it) (and-incomplete form 'and val found-it env)))))) - (when (and (pair? val) + (when (and (pair? val) (pair? (cadr exprs)) (hash-table-ref bools (car val))) (if (member (cadr val) (cadr exprs)) @@ -3817,18 +3817,18 @@ (member (cadr val) (car p)))) (if (pair? p) (and-forgetful form 'and val (car p) env))))))))) - + (if (not (or retry (equivalent? e (car exprs)))) ; NaN again (set! retry #t)) - + ;; (and x1 x2 x1) is not reducible ;; the final thing has to remain at the end, but can be deleted earlier if it can't short-circuit the evaluation, ;; but if there are expressions following the first x1, we can't be sure that it is not ;; protecting them: ;; (and false-or-0 (display (list-ref lst false-or-0)) false-or-0) ;; so I'll not try to optimize that case. But (and x x) is optimizable. - + ;(format *stderr* " new-form: ~S\n val: ~S\n e: ~S\n exprs: ~S~%" new-form val e exprs) (cond ((eq? val #t) (if (null? (cdr exprs)) ; (and x y #t) should not remove the #t @@ -3843,24 +3843,24 @@ (or (null? new-form) (not (member e new-form)))) (set! new-form (cons e new-form))))) - + ((not val) ; #f in 'and' ends the expression - (set! new-form (if (or (null? new-form) + (set! new-form (if (or (null? new-form) (just-symbols? new-form)) '(#f) (cons #f new-form))) (set! exprs '(#f))) - + ((and (pair? e) ; if (and ...) splice into current (eq? (car e) 'and)) (set! exprs (append e (cdr exprs)))) - + ((and (len>1? e) ; (and (list? p) (pair? p) ...) -> (and (pair? p) ...) (pair? (cdr exprs)) (len>1? (cadr exprs)) (eq? (and-redundant? e (cadr exprs)) (caadr exprs)) (equal? (cadr e) (cadadr exprs)))) - + ((and (len>1? e) ; (and (list? p) (not (null? p)) ...) -> (and (pair? p) ...) (memq (car e) '(list? pair?)) (pair? (cdr exprs)) @@ -3872,11 +3872,11 @@ (equal? (cadr e) (cadadr p))))) (set! new-form (cons (list 'pair? (cadr e)) new-form)) (set! exprs (cdr exprs))) - + ;; redundant type check after something like list-ref never happens - + (else - + (when (and (not (eq? form last-reduce-and-form)) (pair? (cdr form)) (pair? (cddr form)) @@ -3898,7 +3898,7 @@ (not ((symbol->value andf) num))) (lint-format "~S, but ~S is not ~S" 'and form num andf) (lint-format "perhaps ~S -> ~S" 'and form (list 'eqv? (cadr ande) num))))) - + ((eq? otherf 'or) ; (and (integer? x) (or (= x 0) (= x 1))) -> (memv x '(0 1)) (let ((vals (call-with-exit (lambda (return) @@ -3914,10 +3914,10 @@ (cdr othere)))))) (if (and (pair? vals) (not (memq #<unspecified> vals))) - (lint-format "perhaps ~S -> ~S" 'and form + (lint-format "perhaps ~S -> ~S" 'and form (list 'memv (cadr ande) (list 'quote vals)))))))) ;; there are also cases with zero? etc - + ((eq? andf 'exact?) (let ((num ((if (eq? (cadr ande) (caddr othere)) cadr caddr) othere))) (if (and (eq? otherf '=) @@ -3927,12 +3927,12 @@ ((symbol->value andf) num))) (lint-format "perhaps ~S -> ~S" 'and form (list 'eqv? (cadr ande) num))))) - + ((and (eq? andf 'symbol?) (eq? otherf 'memq) (eq? (cadr ande) (cadr othere))) (lint-format "perhaps ~S -> ~S" 'and form othere)) - + ((and (eq? andf 'not) (eq? otherf 'or) (pair? (cadr ande)) @@ -3951,9 +3951,9 @@ (cdr othere)))))) (if (and (pair? vals) (not (memq #<unspecified> vals))) - (lint-format "perhaps ~S -> ~S" 'and form + (lint-format "perhaps ~S -> ~S" 'and form (list 'memv (cadadr ande) (list 'quote vals))))))))) - + (unless (or (and (len>2? e) ; (and ... (or ... 123) ...) -> splice out or (pair? (cdr exprs)) (eq? (car e) 'or) @@ -3969,7 +3969,7 @@ (equal? (cadr val) (cadr p)))) new-form))))) (set! new-form (cons val new-form))))) - + (if (and (not (eq? new-form old-form)) (pair? (cdr new-form))) (let ((rel (relsub (car new-form) (cadr new-form) 'and env))) @@ -3987,13 +3987,13 @@ (else #f)))) (if (and op (>= len 3) - (lint-every? (lambda (p) + (lint-every? (lambda (p) (and (len>2? p) (eq? (car p) op))) (cdr form))) (let ((first (cadadr form))) - (if (lint-every? (lambda (p) - (equal? (cadr p) first)) + (if (lint-every? (lambda (p) + (equal? (cadr p) first)) (cddr form)) (set! form `(,op ,first (,(car form) ,@(map (lambda (p) (if (null? (cdddr p)) @@ -4002,13 +4002,13 @@ (cdr form))))) (if (null? (cdddr (cadr form))) (let ((last (caddr (cadr form)))) - (if (lint-every? (lambda (p) + (if (lint-every? (lambda (p) (and (null? (cdddr p)) (equal? (caddr p) last))) (cddr form)) - (set! form (list op - (cons (car form) - (map cadr (cdr form))) + (set! form (list op + (cons (car form) + (map cadr (cdr form))) last))))))))) ;; (or (and A B) (and A C)) -> (and A (or B C)) ;; (or (and A B) (and C B)) -> (and (or A C) B) @@ -4027,31 +4027,31 @@ (simplify-boolean arg true false env) arg) env)) - (arg-op (and (pair? arg) + (arg-op (and (pair? arg) (car arg)))) - (cond ((boolean? val) + (cond ((boolean? val) (not val)) - + ((or (code-constant? arg) (and (pair? arg) (symbol? arg-op) (hash-table-ref no-side-effect-functions arg-op) (let ((ret (return-type arg-op env))) - (and (or (symbol? ret) + (and (or (symbol? ret) (pair? ret)) (not (return-type-ok? 'boolean? ret)) (not (return-type-ok? 'not ret)))) (not (var-member arg-op env)))) #f) - - ((and (pair? val) - (> (length val) 1) ; (not (not ...)) -> ... this is usually internally generated, + + ((and (pair? val) + (> (length val) 1) ; (not (not ...)) -> ... this is usually internally generated, (memq (car val) '(not if cond case begin))) ; so the message about (and x #t) is in special-case-functions below (case (car val) ((not) (cadr val)) - + ((if) (if (not (pair? (cddr val))) form @@ -4060,9 +4060,9 @@ (simplify-boolean (list 'not (cadddr val)) () () env)))) ;; ideally we'd call if-walker on this to simplify further (list 'if (cadr val) if-true if-false)))) - + ((cond case) - `(,(car val) + `(,(car val) ,@(if (eq? (car val) 'cond) () (list (cadr val))) ,@(map (lambda (c) (if (not (and (pair? c) @@ -4076,18 +4076,18 @@ (simplify-boolean (list 'not last) () () env))))) `(,(car c) ,@(copy (cdr c) (make-list (- len 1))) ,new-last)))) ((if (eq? (car val) 'cond) cdr cddr) val)))) - + ((begin) (let* ((len-1 (- (length val) 1)) (new-last (simplify-boolean (list 'not (list-ref val len-1)) () () env))) (append (copy val (make-list len-1)) (list new-last)))))) - + ((not (equal? val arg)) (list 'not val)) - + ((not (pair? arg)) form) - + ((and (memq arg-op '(and or)) ; (not (or|and x (not y))) -> (and|or (not x) y) (= (length arg) 3) (or (and (pair? (cadr arg)) @@ -4101,16 +4101,16 @@ (cadr p) (simplify-boolean (list 'not p) () () env))) (cdr arg))))) - + ((<= (length arg) 3) ; avoid (<= 0 i 12) and such (case arg-op ((< > <= >= odd? even? exact? inexact?char<? char>? char<=? char>=? string<? string>? string<=? string>=? char-ci<? char-ci>? char-ci<=? char-ci>=? string-ci<? string-ci>? string-ci<=? string-ci>=?) (cons (hash-table-ref notables arg-op) (cdr arg))) - + ;; null? is not quite right because (not (null? 3)) -> #t ;; char-upper-case? and lower are not switchable here - + ((zero?) ; (not (zero? (logand p 2^n | (ash 1 i)))) -> (logbit? p i) (if (not (pair? (cdr arg))) form @@ -4129,10 +4129,10 @@ (zero? (logand arg2 (- arg2 1))) ; it's a power of 2 (list 'logbit? arg1 (floor (log arg2 2)))) ; floor for freeBSD? form)))))) - + (else form))) (else form))))) - + ;; -------------------------------- ((or) (case len @@ -4144,7 +4144,7 @@ (when (= len 3) (let ((arg1 (cadr form)) (arg2 (caddr form))) - + (if (and (len>1? arg2) ; (or A (and ... A ...)) -> A (eq? (car arg2) 'and) (member arg1 (cdr arg2)) @@ -4155,7 +4155,7 @@ (equal? arg2 (last-ref arg1)) (not (side-effect? arg1 env))) (return arg2)) - + (when (pair? arg2) (if (and (eq? (car arg2) 'and) ; (or A (and (not A) B)) -> (or A B) (pair? (cdr arg2)) @@ -4172,10 +4172,10 @@ (simplify-boolean (list 'not (cadr arg2)) () () env)))) (lint-format "perhaps ~A" 'or ; (or (< x y) (and (>= x y) (= x 2))) -> (or (< x y) (= x 2)) ;; this could be much fancier, but it's not hit much (the 'and case below is not hit at all I think) - (lists->string form + (lists->string form (if (null? (cddr arg2)) #t - (list 'or arg1 + (list 'or arg1 (if (pair? (cdddr arg2)) (cons 'and (cddr arg2)) (caddr arg2))))))))) @@ -4204,12 +4204,12 @@ (member (cadadr arg1) (car p)))) (if (pair? p) (and-forgetful form 'or (cadr arg1) (car p) env))))))) - + (if (and (eq? (car arg2) 'and) ; (or (not A) (and A B)) -> (or (not A) B) -- this stuff actually happens! (len>1? (cdr arg2)) (equal? (cadr arg1) (cadr arg2))) (return (cons 'or (cons arg1 (cddr arg2)))))) - + (when (and (eq? (car arg1) 'and) (eq? (car arg2) 'and) (= 3 (length arg1) (length arg2)) @@ -4220,7 +4220,7 @@ (not (equal? (list 'not (caddr arg1)) (caddr arg2)))) ;; kinda dumb, but common: (or (and A B) (and (not A) C)) -> (if A B C) ;; the other side: (and (or A B) (or (not A) C)) -> (if A C (and B #t)), but it never happens - (lint-format "perhaps ~A" 'or + (lint-format "perhaps ~A" 'or (lists->string form (if (and (pair? (cadr arg1)) (eq? (caadr arg1) 'not)) @@ -4235,9 +4235,9 @@ (and-redundant? arg1 arg2)))) (if t1 (return (if (eq? t1 (car arg1)) arg2 arg1)))) - + ;; if all clauses are (eq-func x y) where one of x/y is a symbol|simple-expr repeated throughout - ;; and the y is a code-constant, or -> memq and friends. + ;; and the y is a code-constant, or -> memq and friends. ;; This could also handle cadr|caddr reversed, but it apparently never happens. (if (and (or (and (eq? (car arg2) '=) (memq (car arg1) '(< > <= >=))) @@ -4249,13 +4249,13 @@ (memq (car arg2) '(< <=))) '<= '>=) (cdr arg1)))) - + ;; this makes some of the code above redundant (let ((rel (relsub arg1 arg2 'or env))) (if (or (boolean? rel) (pair? rel)) (return rel))) - + ;; (or (pair? x) (null? x)) -> (list? x) (when (and (pair? (cdr arg1)) (pair? (cdr arg2)) @@ -4264,12 +4264,12 @@ (memq (car arg2) '(null? pair?)) (not (eq? (car arg1) (car arg2)))) (return (list 'list? (cadr arg1)))) - + (if (and (eq? (car arg1) 'zero?) ; (or (zero? x) (positive? x)) -> (not (negative? x)) -- other cases don't happen (memq (car arg2) '(positive? negative?))) ; but +nan.0 messes this up -- perhaps add that to the suggestion? - (return (list 'not (list (if (eq? (car arg2) 'positive?) 'negative? 'positive?) + (return (list 'not (list (if (eq? (car arg2) 'positive?) 'negative? 'positive?) (cadr arg1)))))) - + ;; (or (and A B) (and (not A) (not B))) -> (eq? (not A) (not B)) ;; more accurately (if A B (not B)), but every case I've seen is just boolean ;; perhaps also (or (not (or A B)) (not (or (not A) (not B)))), but it never happens @@ -4293,28 +4293,28 @@ (not (eq? (car arg1) (car arg2)))) (when (subsumes? (car arg1) (car arg2)) (return arg1)) - + (let ((t2 (if (eq? (car arg1) 'not) (and (booleans-with-not? arg2 arg1 env) (or-not-redundant arg2 arg1)) (and (booleans-with-not? arg1 arg2 env) (or-not-redundant arg1 arg2))))) - (when t2 + (when t2 (if (eq? t2 'true) (return #t) (if (pair? t2) (return t2)))))) - + ;; (or (if a c d) (if b c d)) -> (if (or a b) c d) never happens, sad to say ;; or + if + if does happen but not in this easily optimized form )))) ; len = 3 - + ;; len > 3 or nothing was caught above (invert-successive-nots return form len env) (or->memx return form env) (or->case return form) (reduce-or return form len true false env)))))) - + ;; -------------------------------- ((and) (case len @@ -4340,10 +4340,10 @@ (equal? arg1 ;(simplify-boolean arg1 () () env) (simplify-boolean (list 'not (cadr arg2)) () () env)))) (lint-format "perhaps ~A" 'and ; (and (< x y) (or (>= x y) (= x 2))) -> (and (< x y) (= x 2)) ?? - (lists->string form + (lists->string form (if (null? (cddr arg2)) #f - (list 'and arg1 + (list 'and arg1 (if (pair? (cdddr arg2)) (cons 'or (cddr arg2)) (caddr arg2))))))))) @@ -4353,12 +4353,12 @@ (not (side-effect? arg1 env))) (return arg2)) ;; the and equivalent of (or (not A) (and A B)) never happens - + (when (pair? arg2) (if (symbol? arg1) ; (and x (pair? x)) -> (pair? x) (if (memq arg1 arg2) (begin - (case (car arg2) + (case (car arg2) ((not) (return #f)) ((boolean?) (return (list 'eq? arg1 #t)))) (and-incomplete form 'and arg1 arg2 env) @@ -4374,7 +4374,7 @@ (hash-table-ref bools (car arg1))) (if (member (cadr arg1) arg2) (and-forgetful form 'and arg1 arg2 env) - (do ((p arg2 (cdr p))) + (do ((p arg2 (cdr p))) ((or (not (pair? p)) (and (pair? (car p)) (member (cadr arg1) (car p)))) @@ -4393,16 +4393,16 @@ (not (side-effect? arg1 env)) (and-redundant? arg1 arg2)))) ; (and (integer? x) (number? x)) -> (integer? x) (when t1 - (return (cond + (return (cond ((memq t1 '(eq? eqv? equal?)) (cons t1 (cdr arg2))) - + ((eq? t1 'memv) (let ((x ((if (equal? (cadr arg1) (cadr arg2)) caddr cadr) arg2))) (if (rational? x) `(memv ,(cadr arg1) '(,x ,(* 1.0 x))) `(memv ,(cadr arg1) '(,(floor x) ,x))))) - + ((eq? t1 (car arg1)) arg1) (else arg2))))) @@ -4418,15 +4418,15 @@ (equal? (cadr arg1) (cadr arg2))) (if (and (rational? (caddr arg1)) (rational? (caddr arg2))) - (return (list (car arg1) + (return (list (car arg1) (cadr arg1) ((if (memq (car arg1) '(< <=)) min max) (caddr arg1) (caddr arg2))))) (if (equal? (caddr arg1) (caddr arg2)) ; (and (< 0 x) (> x 0)) -> (< 0 x) (return arg1)) - (return (list (car arg1) + (return (list (car arg1) (cadr arg1) - (list (if (memq (car arg1) '(< <=)) 'min 'max) - (caddr arg1) + (list (if (memq (car arg1) '(< <=)) 'min 'max) + (caddr arg1) (caddr arg2))))) (when (and (or (equal? (caddr arg1) (cadr arg2)) ; (and (op x y) (op y z)) @@ -4446,10 +4446,10 @@ (cond ((equal? arg1-2 arg2-1) ; (and (op x y) (op y z)) -> (op x y z) (if (equal? arg1-1 arg2-2) (if (memq op1 '(= char=? string=? char-ci=? string-ci=?)) - arg1 + arg1 (and (memq op1 '(<= >= char<=? char>=? string<=? string>=? char-ci<=? char-ci>=? string-ci<=? string-ci>=?)) - (cons (case op1 + (cons (case op1 ((>= <=) '=) ((char<= char>=) 'char=?) ((char-ci<= char-ci>=) 'char-ci=?) @@ -4460,7 +4460,7 @@ (not (code-constant? arg2-2)) ((symbol->value op1 (rootlet)) arg1-1 arg2-2)) (list op1 arg1-1 arg2-1 arg2-2)))) - + ((equal? arg1-1 arg2-2) ; (and (op x y) (op z x)) -> (op z x y) (if (equal? arg1-2 arg2-1) (and (memq op1 '(= char=? string=? char-ci=? string-ci=?)) @@ -4469,7 +4469,7 @@ (not (code-constant? arg1-2)) ((symbol->value op1 (rootlet)) arg2-1 arg1-2)) (list op1 arg2-1 arg1-1 arg1-2)))) - + ;; here we're restricted to equalities and we know arg1 != arg2 ((equal? arg1-1 arg2-1) ; (and (op x y) (op x z)) -> (op x y z) (if (and (code-constant? arg1-2) @@ -4477,16 +4477,16 @@ (and ((symbol->value op1 (rootlet)) arg1-2 arg2-2) arg1) (list op1 arg1-1 arg1-2 arg2-2))) - + ;; equalities again ((and (code-constant? arg1-1) (code-constant? arg2-1)) (and ((symbol->value op1 (rootlet)) arg1-1 arg2-1) arg1)) - + (else (list op1 arg1-1 arg1-2 arg2-1))))))) - ;; check some special cases + ;; check some special cases (when (and (or (equal? (cadr arg1) (cadr arg2)) (and (len=1? (cddr arg2)) (equal? (cadr arg1) (caddr arg2)))) @@ -4499,14 +4499,14 @@ (if (or (eq? (car arg1) 'inexact?) (eq? (car arg2) 'inexact?)) (return (list 'eqv? (cadr arg1) 0.0)))) - + (when (hash-table-ref and-rel-ops (car arg2)) (when (and (eq? (car arg1) 'symbol?) (memq (car arg2) '(eq? eqv? equal?)) (or (quoted-symbol? (cadr arg2)) (quoted-symbol? (caddr arg2)))) (return (cons 'eq? (cdr arg2)))) - + (when (and (eq? (car arg1) 'positive?) (eq? (car arg2) '<) (eq? (cadr arg1) (cadr arg2))) @@ -4520,9 +4520,9 @@ (compatible? (car arg1) (->lint-type (cadr arg2)))) (and (code-constant? (caddr arg2)) (compatible? (car arg1) (->lint-type (caddr arg2)))))) - (return (cons (if (eq? (car arg1) 'char?) 'eqv? 'equal?) + (return (cons (if (eq? (car arg1) 'char?) 'eqv? 'equal?) (cdr arg2)))) - + (when (and (equal? (cadr arg1) (cadr arg2)) (eq? (car arg1) 'inexact?) (eq? (car arg2) 'real?)) @@ -4557,17 +4557,17 @@ (when p (let ((sig (arg-signature (car arg2) env)) (pos (- (length arg2) (length p)))) - + (when (pair? sig) (let ((arg-type (and (> (length sig) pos) (list-ref sig pos)))) (unless (compatible? (car arg1) arg-type) (let ((ln (and (< 0 line-number 100000) line-number))) (format outport "~NCin ~A~A, ~A is ~A, but ~A wants ~A" - lint-left-margin #\space - (truncated-list->string form) + lint-left-margin #\space + (truncated-list->string form) (if (and ln (> ln 0)) (format #f " (line ~D)" ln) "") - (cadr arg1) + (cadr arg1) (prettify-checker-unq (car arg1)) (car arg2) (prettify-checker arg-type)))))))))) @@ -4579,9 +4579,9 @@ (pair? (cadr arg2)) (pair? (caddr arg2)) (eq? (caadr arg1) (caaddr arg1))))) - + ((assq (caadr arg1) - '((car cdr #t) + '((car cdr #t) (caar cdar car) (cadr cddr cdr) (caaar cdaar caar) (caadr cdadr cadr) (caddr cdddr cddr) (cadar cddar cdar) (cadddr cddddr cdddr) (caaaar cdaaar caaar) (caaadr cdaadr caadr) (caadar cdadar cadar) @@ -4594,10 +4594,10 @@ (return (if (symbol? (caddr x)) `(equal? (,(caddr x) ,(cadadr arg1)) (,(caddr x) ,(cadr (caddr arg1)))) `(equal? ,(cadadr arg1) ,(cadr (caddr arg1)))))))))))) - + ;; len > 3 or nothing was caught above (invert-successive-nots return form len env) - + (if (lint-every? (lambda (a) (and (len>1? a) (or (eq? (car a) 'zero?) @@ -4614,14 +4614,14 @@ a)) (cdr form)) env))))) - + (let ((diff (apply and-redundants env (cdr form)))) - (when diff + (when diff (if (null? (cdr diff)) (return (car diff))) (return (simplify-boolean (cons 'and diff) () () env)))) ;; now there are redundancies below (see subsumes?) but they assumed the tests were side-by-side - + (reduce-and return form len false env))))))))) (define (bsimp x env) ; quick check for common easy cases @@ -4635,7 +4635,7 @@ (code-constant? (cadr x))) (cadr x) x)) - (else + (else (if (not (and (len=2? x) (pair? (cadr x)) (symbol? (caadr x)))) @@ -4658,11 +4658,11 @@ ((negative?) (and (not (hash-table-ref non-negative-ops (caadr x))) x)) (else x)))))))))) - + (define (bcomp x true false env) ; not so quick... (cond ((not (pair? x)) x) - + ((eq? (car x) 'and) (call-with-exit (lambda (return) @@ -4676,7 +4676,7 @@ (if (or (not next) ; #f in and -> end of expr (member next false)) (if (eq? sidex newx) ; no side-effects - (return #f) + (return #f) (begin (set-cdr! endx (list #f)) (return newx))) @@ -4691,10 +4691,10 @@ (set! endx (cdr endx)) (if (side-effect? next env) (set! sidex endx))))))))))) - + ((not (eq? (car x) 'or)) x) - + (else (call-with-exit (lambda (return) @@ -4722,7 +4722,7 @@ (set! endx (cdr endx)) (if (side-effect? next env) (set! sidex endx))))))))))))) - + ;; -------------------------------- ;; simplify-boolean ;; this is not really simplify boolean as in boolean algebra because in scheme there are many unequal truths, but only one falsehood @@ -4736,7 +4736,7 @@ (or (and (reversible-member in-form true) #t) (and (len>1? in-form) (eq? (car in-form) 'not) - (reversible-member (cadr in-form) false) + (reversible-member (cadr in-form) false) #t) (if (not (pair? in-form)) in-form @@ -4746,12 +4746,12 @@ (classify form env) (let ((len (length form))) (if (< len 0) - form + form (bool-simp-1 form true false len env))))))))))) - + ;; -------------------------------- - (define undumb + (define undumb (let ((dumb-ops '((fix:+ . +) (fx+ . +) (flo:+ . +) (fl+ . +) (fix:* . *) (fx* . *) (flo:* . *) (fl* . *) (fix:- . -) (fx- . -) (flo:- . -) (fl- . -) @@ -4775,7 +4775,7 @@ (flo:sqrt . sqrt) (flsqrt . sqrt) (flo:exp . exp) (flexp . exp) (flexpt . expt) (flo:log . log) (fllog . log) - (bignum+ . +) (bignum* . *) (bignum/ . /) (bignum- . -) + (bignum+ . +) (bignum* . *) (bignum/ . /) (bignum- . -) (bignum< . <) (bignum<= . <=) (bignum> . >) (bignum>= . >=) (bignum= . =) (bignum-quotient . quotient) (bignum-negative? . negative?) (bignum-magnitude . magnitude) (bignum-expt . expt) (bignum-zero? . zero?) (bignum-abs . abs) (bignum-remainder . remainder)))) @@ -4786,16 +4786,16 @@ tree) (else (cons (undumb (car tree)) (undumb (cdr tree)))))))) - + (define (splice-if func lst) (cond ;((null? lst) ()) ((not (pair? lst)) lst) ((and (pair? (car lst)) (eq? func (caar lst)) (proper-list? (cdar lst))) ; for apply - (append (splice-if func (cdar lst)) + (append (splice-if func (cdar lst)) (splice-if func (cdr lst)))) - (else (cons (car lst) + (else (cons (car lst) (splice-if func (cdr lst)))))) (define simplify-numerics @@ -4805,7 +4805,7 @@ (define (integer-result? op) (memq op '(logior lognot logxor logand numerator denominator floor round truncate ceiling ash))) - + (define (remove-inexactions val) (when (and (or (assq 'exact->inexact val) (assq 'inexact val)) @@ -4827,16 +4827,16 @@ (if (pair? p) (set-car! p (* 1.0 (car p)))))))) val) - + ;; polar notation (@) is never used anywhere except test suites - + (define numerics-table (let ((h (make-hash-table))) - + (let ((coeffs (make-vector 4 0))) (define (horners-rule form) (and (pair? form) - (call-with-exit + (call-with-exit (lambda (return) (fill! coeffs 0) (do ((p form (cdr p)) @@ -4847,7 +4847,7 @@ (result (vector-ref coeffs top))) ((< x 0) result) - (set! result + (set! result (if (eqv? (vector-ref coeffs x) 0) (list '* sym result) (if (eqv? (vector-ref coeffs x) 0.0) @@ -4856,7 +4856,7 @@ (let ((cx (car p))) (cond ((number? cx) (vector-set! coeffs 0 (+ (vector-ref coeffs 0) cx))) - + ((symbol? cx) (if (not sym) (set! sym cx) @@ -4864,11 +4864,11 @@ (return #f))) (set! top (max top 1)) (vector-set! coeffs 1 (+ (vector-ref coeffs 1) 1))) - + ((not (and (pair? cx) (eq? (car cx) '*))) (return #f)) - + (else (let ((ctr 0) (ax 1)) @@ -4889,23 +4889,23 @@ (set! coeffs (copy coeffs (make-vector (* ctr 2) 0)))) (set! top (max top ctr)) (vector-set! coeffs ctr (+ (vector-ref coeffs ctr) ax))))))))))) - + (define (num+ args form env) (case (length args) ((0)) ((1) (car args)) - (else + (else (let ((val (remove-all 0 (splice-if '+ args)))) (if (lint-every? (lambda (x) (or (not (number? x)) (rational? x))) val) (let ((rats (collect-if-rational val))) (if (len>1? rats) (let ((y (apply + rats))) - (set! val (if (zero? y) + (set! val (if (zero? y) (collect-if-not-number val) (cons y (collect-if-not-number val)))))))) (set! val (remove-inexactions val)) (if (lint-any? (lambda (p) ; collect all + and - vals -> (- (+ ...) ...) - (and (pair? p) + (and (pair? p) (eq? (car p) '-))) val) (let ((plus ()) @@ -4929,9 +4929,9 @@ (if (rational? (cadr p)) (set! c (+ c (cadr p))) (set! plus (cons (cadr p) plus))) - (for-each (lambda (p1) - (if (rational? p1) - (set! c (- c p1)) + (for-each (lambda (p1) + (if (rational? p1) + (set! c (- c p1)) (set! minus (cons p1 minus)))) (cddr p))))))) val) @@ -4942,7 +4942,7 @@ ;; (+ (- x 1) 1000): plus '(x), minus (), c 999 -> (+ x 999) ;; (+ (- 1 x) 1000): () '(x), 1001 -> (- 1001 x) ;; (+ (- x y 1) 2 z) '(z x) '(y), 1 -> (- (+ x z 1) y) - (when (and (pair? plus) + (when (and (pair? plus) (pair? minus)) (do ((p plus (cdr p)) (np ())) @@ -4952,7 +4952,7 @@ (not (side-effect? (car p) env))) (set! minus (remove-one (car p) minus)) (set! np (cons (car p) np))))) - + ;; perhaps compare tree-length of the new and old versions, and choose the smaller? (let ((new-form (if (null? minus) @@ -4961,11 +4961,11 @@ (simplify-numerics `(- ,c ,@(reverse minus)) env) (simplify-numerics `(- (+ ,@(reverse plus) ,@(if (positive? c) (list c) ())) ,@(reverse minus) ,@(if (negative? c) (list (abs c)) ())) - env))))) + env))))) (if (> (+ (tree-leaves val) 1) (tree-leaves new-form)) new-form (cons '+ val)))))) ; to (let ((plus)... above - + (case (length val) ((0)) ; (+) -> 0 ((1) (car val)) ; (+ x) -> x @@ -4977,13 +4977,13 @@ (not (number? arg1)) (not (= arg2 (*s7* 'most-negative-fixnum)))) ; abs here is now an error (list '- arg1 (abs arg2))) - + ((and (real? arg1) ; (+ -1 x) -> (- x 1) (negative? arg1) (not (number? arg2)) (not (= arg1 (*s7* 'most-negative-fixnum)))) (list '- arg2 (abs arg1))) - + ((and (pair? arg1) ; (+ (if x 0 y) z) -> (if x z (+ y z)) (eq? (car arg1) 'if) (= (length arg1) 4)) @@ -4999,7 +4999,7 @@ (if (eqv? false 0) `(if ,(cadr arg1) (+ ,true ,arg2) ,arg2) (cons '+ val)))))) - + ((and (pair? arg2) ; (+ z (if x 0 y)) -> (if x z (+ z y)) (eq? (car arg2) 'if) (= (length arg2) 4)) @@ -5012,11 +5012,11 @@ (if (eqv? false 0) `(if ,(cadr arg2) (+ ,arg1 ,true) ,arg1) (cons '+ val))))) - + ((not (and (pair? arg1) (pair? arg2))) (cons '+ val)) - + ((and (eq? (car arg1) '*) ; (+ (* a b) (* a c)) -> (* a (+ b c)) (eq? (car arg2) '*) (lint-any? (lambda (a) @@ -5039,10 +5039,10 @@ (set! times (cons (car p) times)) (set! rset (remove-one (car p) rset))) (set! pluses (cons (car p) pluses))))) - + ((and (eq? (car arg1) '/) ; (+ (/ a b) (/ c b)) -> (/ (+ a c) b) (eq? (car arg2) '/) - (pair? (cddr arg1)) + (pair? (cddr arg1)) (pair? (cddr arg2)) (equal? (cddr arg1) (cddr arg2))) (cons '/ (cons (list '+ (cadr arg1) (cadr arg2)) (cddr arg1)))) @@ -5052,9 +5052,9 @@ (len=2? arg2) (eq? (car arg2) 'log)) (list 'log (list '* (cadr arg1) (cadr arg2)))) - + (else (cons '+ val))))) - (else + (else (or (horners-rule val) ;; not many cases here, oddly enough, Horner's rule gets most (cons '+ val))))))))) @@ -5062,13 +5062,13 @@ (define (dumb+ args form env) (if (var-member (car form) env) form (num+ (undumb args) #f env))) ; not (undone form) because num+ ignores arg2 (for-each (lambda (f) (hash-table-set! h f dumb+)) '(fix:+ fx+ flo:+ fl+ bignum+))) - + (let () (define (num* args form env) (case (length args) ((0) 1) ((1) (car args)) - (else + (else (let ((val (remove-all 1 (splice-if '* args)))) (if (lint-every? (lambda (x) (or (not (number? x)) (rational? x))) val) (let ((rats (collect-if-rational val))) @@ -5080,7 +5080,7 @@ (set! val (remove-inexactions val)) (if (lint-any? (lambda (p) - (and (pair? p) + (and (pair? p) (eq? (car p) '/))) val) (let ((plus ()) @@ -5101,16 +5101,16 @@ (if (rational? (cadr p)) (set! c (* c (cadr p))) (set! plus (cons (cadr p) plus))) - (for-each (lambda (p1) - (if (rational? p1) - (set! c (/ c p1)) + (for-each (lambda (p1) + (if (rational? p1) + (set! c (/ c p1)) (set! minus (cons p1 minus)))) (cddr p))))))) val) (if (not (rational? c)) (cons '* val) (begin - (when (and (pair? plus) + (when (and (pair? plus) (pair? minus)) (do ((p plus (cdr p)) (np ())) @@ -5120,16 +5120,16 @@ (not (side-effect? (car p) env))) (set! minus (remove-one (car p) minus)) (set! np (cons (car p) np))))) - - (let ((new-form + + (let ((new-form (if (null? minus) (if (null? plus) ; (* (/ x y) (/ y x)) -> 1 c (if (and (eqv? c 1) (null? (cdr plus))) (car plus) ; (* x y (/ y)) -> x - (simplify-numerics `(* ,@(if (eqv? c 1) () (list c)) - ,@(reverse plus)) + (simplify-numerics `(* ,@(if (eqv? c 1) () (list c)) + ,@(reverse plus)) env))) ; (* x (/ y 2) 2 z) -> (* x y z) (if (null? plus) (if (and (eqv? c 1) @@ -5139,7 +5139,7 @@ (simplify-numerics `(/ ,@(if (and (eqv? c 1) (null? (cdr plus))) plus - (list (cons '* (if (eqv? c 1) + (list (cons '* (if (eqv? c 1) (reverse plus) (cons c (reverse plus)))))) ,@(reverse minus)) @@ -5147,7 +5147,7 @@ (if (> (+ (tree-leaves val) 1) (tree-leaves new-form)) new-form (cons '* val)))))) ; to (let ((plus)... above - + (case (length val) ((0) 1) ((1) (car val)) ; (* x) -> x @@ -5159,12 +5159,12 @@ (if (< (abs new-val) 1000000) new-val (cons '* val)))) - + ((memv 0 val) ; (* x 0) -> 0 - 0) + 0) ((memv -1 val) (cons '- (remove-one -1 val))) ; (* -1 x) -> (- x) - + ((and (pair? arg1) ; (* (if x 1 y) z) -> (if x z (* y z)) (eq? (car arg1) 'if) ; (* (if x 0 y) z) -> (if x 0 (* y z)) (= (length arg1) 4)) @@ -5178,7 +5178,7 @@ (if (memv false '(0 1)) `(if ,(cadr arg1) (* ,true ,arg2) ,(if (eqv? false 1) arg2 0)) (cons '* val)))))) - + ((and (pair? arg2) ; (* z (if x 1 y)) -> (if x z (* z y)) (eq? (car arg2) 'if) (= (length arg2) 4)) @@ -5189,17 +5189,17 @@ (if (memv false '(0 1)) `(if ,(cadr arg2) (* ,arg1 ,true) ,(if (eqv? false 1) arg1 0)) (cons '* val))))) - + ((or (equal? arg2 (list '/ arg1)) ; (* a (/ a)) -> 1 (equal? arg2 (list '/ 1 arg1))) 1) ((or (equal? arg1 (list '/ arg2)) ; (* (/ a) a) -> 1 (equal? arg1 (list '/ 1 arg2))) 1) - + ((not (pair? arg2)) (cons '* val)) - + ((pair? arg1) (let ((op1 (car arg1)) (op2 (car arg2))) @@ -5208,7 +5208,7 @@ (eq? op2 '-) (null? (cddr arg2))) (list '* (cadr arg1) (cadr arg2))) - + ((and (eq? op1 '/) ; (* (/ x) (/ y)) -> (/ (* x y)) etc (eq? op2 '/)) (let ((op1-arg1 (cadr arg1)) @@ -5224,7 +5224,7 @@ (list '/ (caddr arg1)) (simplify-numerics `(/ ,op1-arg1 (* ,(caddr arg1) ,op2-arg1)) env)) (simplify-numerics `(/ (* ,op1-arg1 ,op2-arg1) (* ,@(cddr arg1) ,@(cddr arg2))) env))))) - + ((and (= (length arg1) 3) (equal? (cdr arg1) (cdr arg2)) (case op1 @@ -5232,50 +5232,50 @@ ((lcm) (eq? op2 'gcd)) (else #f))) (list 'abs (cons '* (cdr arg1)))) ; (* (gcd a b) (lcm a b)) -> (abs (* a b)) but only if 2 args? - + ((and (eq? op1 'exp) ; (* (exp a) (exp b)) -> (exp (+ a b)) (eq? op2 'exp)) (list 'exp (list '+ (cadr arg1) (cadr arg2)))) - + ((and (eq? op1 'sqrt) ; (* (sqrt x) (sqrt y)) -> (sqrt (* x y))?? (eq? op2 'sqrt)) (list 'sqrt (list '* (cadr arg1) (cadr arg2)))) - + ((not (and (eq? op1 'expt) (eq? op2 'expt))) (cons '* val)) - + ((equal? (cadr arg1) (cadr arg2)) ; (* (expt x y) (expt x z)) -> (expt x (+ y z)) (list 'expt (cadr arg1) (list '+ (caddr arg1) (caddr arg2)))) - + ((equal? (caddr arg1) (caddr arg2)) ; (* (expt x y) (expt z y)) -> (expt (* x z) y) (list 'expt (list '* (cadr arg1) (cadr arg2)) (caddr arg1))) - + (else (cons '* val))))) - + ((and (eq? (car arg2) '/) (null? (cddr arg2))) ; (* a (/ b)) -> (/ a b) (list '/ arg1 (cadr arg2))) - + ((and (number? arg1) ; (* 2 (random 3.0)) -> (random 6.0) [except for (random 1)...] (eq? (car arg2) 'random) (pair? (cdr arg2)) (number? (cadr arg2)) (not (rational? (cadr arg2)))) (list 'random (* arg1 (cadr arg2)))) - + (else (cons '* val))))) - (else + (else (cond ((just-rationals? val) (let ((new-val (apply * val))) ; huge numbers here are less readable (if (< (abs new-val) 1000000) new-val (cons '* val)))) - + ((memv 0 val) ; (* x 0 2) -> 0 - 0) - + 0) + ((memv -1 val) (list '- (cons '* (remove-one -1 val)))) ; (* -1 x y) -> (- (* x y)) - + ((let search ((args val)) ; (* x (if y 0 z) w) -> (if y 0 (* x z w)) (and (pair? args) (let ((has-zero (and (pair? (car args)) @@ -5284,16 +5284,16 @@ (or (eqv? (caddar args) 0) (eqv? (car (cdddar args)) 0)) (car args)))) - (or has-zero + (or has-zero (search (cdr args)))))) => (lambda (gif) (let ((other-args (remove-one gif val))) - (list 'if (cadr gif) + (list 'if (cadr gif) (if (eqv? (caddr gif) 0) 0 (cons '* (cons (caddr gif) other-args))) (if (eqv? (cadddr gif) 0) 0 (cons '* (cons (cadddr gif) other-args))))))) - + ((lint-any? (lambda (p) ; collect * and / vals -> (/ (* ...) ...) - (and (pair? p) + (and (pair? p) (eq? (car p) '/))) val) (let ((mul ()) @@ -5323,13 +5323,13 @@ (if (equivalent? expr form) ; possible NaN form (simplify-numerics expr env))))) - + (else (cons '* val)))))))))) (hash-table-set! h '* num*) - + (define (dumb* args form env) (if (var-member (car form) env) form (num* (undumb args) form env))) (for-each (lambda (f) (hash-table-set! h f dumb*)) '(fix:* fx* flo:* fl* bignum*))) - + (let () (define (num- args form env) (let ((args (remove-inexactions args))) @@ -5355,13 +5355,13 @@ (list '- (caddar args) (cadar args)) ; (- (- x y)) -> (- y x) (cons '- args))) (else (cons '- args)))))) - (else + (else (if (just-rationals? args) (apply - args) (let ((val (remove-all 0 (splice-if '+ (cdr args))))) (if (lint-every? (lambda (x) (or (not (number? x)) (rational? x))) val) (let ((rats (collect-if-rational val))) - (if (len>1? rats) + (if (len>1? rats) (let ((y (apply + rats))) (set! val (if (zero? y) (collect-if-not-number val) @@ -5373,11 +5373,11 @@ (not (side-effect? first-arg env))) (set! nargs (remove-one first-arg nargs)) (set! first-arg 0)) - + (let ((plus ()) (minus ()) (c 0)) - + (if (pair? first-arg) (if (eq? (car first-arg) '+) (set! plus (cdr first-arg)) @@ -5423,7 +5423,7 @@ (set! c (+ c arg)) (set! new-plus (cons arg new-plus)))) plus) - + (if (not (rational? c)) (cons '- args) (let ((new-form @@ -5459,20 +5459,20 @@ (if (len=3? new-form) (let ((arg1 (cadr new-form)) (arg2 (caddr new-form))) - (cond + (cond ((and (len>1? arg2) ; (- x (truncate x)) -> (remainder x 1) (eq? (car arg2) 'truncate) (equal? arg1 (cadr arg2))) (list 'remainder arg1 1)) - - ((and (len>2? arg1) + + ((and (len>2? arg1) (len>2? arg2) (eq? (car arg1) '/) ; (- (/ a b) (/ c b)) -> (/ (- a c) b) (eq? (car arg2) '/) (equal? (cddr arg1) (cddr arg2))) (cons '/ (cons (list '- (cadr arg1) (cadr arg2)) (cddr arg1)))) - - ((and (len=3? arg1) + + ((and (len=3? arg1) (len=3? arg2) (eq? (car arg1) '*) ; (- (* a b) (* a c)) -> (* a (- b c)) (eq? (car arg2) '*) ; (- (* b a) (* c a)) -> (* a (- b c)) etc @@ -5481,13 +5481,13 @@ (if (member (cadr arg1) arg2) (list '* (cadr arg1) (list '- (caddr arg1) ((if (equal? (cadr arg1) (cadr arg2)) caddr cadr) arg2))) (list '* (caddr arg1) (list '- (cadr arg1) ((if (equal? (caddr arg1) (cadr arg2)) caddr cadr) arg2))))) - + ((and (len=2? arg1) ; (- (log a) (log b)) -> (log (/ a b)) (eq? (car arg1) 'log) (len=2? arg2) (eq? (car arg2) 'log)) (list 'log (list '/ (cadr arg1) (cadr arg2)))) - + ((and (pair? arg2) ; (- x (if y 0 z)) -> (if y x (- x z)) (eq? (car arg2) 'if) ; (- x (if y z 0)) -> (if y (- x z) x) (= (length arg2) 4) @@ -5498,21 +5498,21 @@ `(if ,(cadr arg2) ,(if (eqv? true 0) arg1 (list '- arg1 true)) ,(if (eqv? true 0) (list '- arg1 false) arg1)))) - + ((and (len=3? arg2) ; (- x (* y (quotient x y))) or reversed -> (remainder x y) (eq? (car arg2) '*) (or (and (len=3? (caddr arg2)) ; arg2 here is (* y (quotient x y)), arg1 is x (eq? (caaddr arg2) 'quotient) (equal? arg1 (cadr (caddr arg2))) (equal? (cadr arg2) (caddr (caddr arg2))) - `(remainder ,arg1 ,(cadr arg2))) + `(remainder ,arg1 ,(cadr arg2))) (and (len=3? (cadr arg2)) ; arg2 here is (* (quotient x y) y), arg1 is x (eq? (caadr arg2) 'quotient) (equal? arg1 (cadadr arg2)) (equal? (caddr arg2) (caddr (cadr arg2))) `(remainder ,arg1 ,(caddr arg2)))))) - - (else + + (else (if (> (tree-leaves form) (tree-leaves new-form)) new-form form)))) @@ -5526,7 +5526,7 @@ (define (dumb- args form env) (if (var-member (car form) env) form (num- (undumb args) (undumb form) env))) (for-each (lambda (f) (hash-table-set! h f dumb-)) '(fix:- fx- flo:- fl- bignum-))) - + (let () (define (num/ args form env) (let* ((args (remove-inexactions args)) @@ -5541,7 +5541,7 @@ (if (not (pair? arg1)) (cons '/ args) (case (car arg1) - ((/) + ((/) (case (length arg1) ((1) form) ; (/)? ((2) ; (/ (/ x)) -> x @@ -5572,8 +5572,8 @@ (op2-arg1 (and op2 (pair? (cdr arg2)) (cadr arg2)))) (cond ((eqv? arg1 1) ; (/ 1 x) -> (/ x) (simplify-numerics (list '/ arg2) env)) - - ((eqv? arg2 1) ; (/ x 1) -> x + + ((eqv? arg2 1) ; (/ x 1) -> x arg1) ((memv arg1 '(0 0.0)) ; (/ 0 x) -> 0 -- this used to worry that arg2 might be 0 or NaN, but the others don't @@ -5591,13 +5591,13 @@ (eq? op1 '-) (eqv? (cadr arg1) arg2))) -1) - + ((and (len>2? arg1) ; (/ (/ a b) c) -> (/ a b c) (eq? op1 '/) (not (and (pair? arg2) (eq? op2 '/)))) `(/ ,op1-arg1 ,@(cddr arg1) ,arg2)) - + ((and (pair? arg1) ; (/ (/ a) (/ b)) -> (/ b a)?? (eq? op1 '/) (pair? arg2) @@ -5605,7 +5605,7 @@ (let ((a1 (if (null? (cddr arg1)) (list 1 op1-arg1) (cdr arg1))) (a2 (if (null? (cddr arg2)) (list 1 op2-arg1) (cdr arg2)))) (simplify-numerics `(/ (* ,(car a1) ,@(cdr a2)) (* ,@(cdr a1) ,(car a2))) env))) - + ((and (pair? arg2) (eq? op2 '*) (not (side-effect? arg1 env)) @@ -5614,11 +5614,11 @@ (cons '/ (if (len=1? n) n ; (/ x (* y x)) -> (/ y) (cons 1 n))))) ; (/ x (* y x z)) -> (/ 1 y z) - + ((and (len>1? arg2) ; (/ c (/ a b)) -> (/ (* c b) a) (eq? op2 '/)) (cond ((null? (cddr arg2)) - (list '* arg1 op2-arg1)) ; ignoring divide by zero here (/ x (/ y)) -> (* x y) + (list '* arg1 op2-arg1)) ; ignoring divide by zero here (/ x (/ y)) -> (* x y) ((memv op2-arg1 '(0 0.0)) (cons 'a args)) ; same: (/ x (/ 0 ...)) -- give up ((eqv? op2-arg1 1) @@ -5679,7 +5679,7 @@ (equal? (cadr arg2) (cadadr arg1)) (equal? (caddr arg2) (cadr (caddr arg1)))) (cons (if (eq? op2 '-) '+ '-) (cdr arg2))) - + ((and (pair? arg1) ; (/ (* x y) (* z y)) -> (/ x z) (pair? arg2) (eq? op1 '*) @@ -5688,7 +5688,7 @@ (and (= (length arg1) (length arg2) 3) (equal? (caddr arg1) (caddr arg2)))) ((log) - (cond ((assq 'log (cdr arg1)) + (cond ((assq 'log (cdr arg1)) => (lambda (p) (= (length p) 2))) (else #f))) @@ -5705,28 +5705,28 @@ val) p)) (cdr arg1))))))) - + ((and (len>1? arg1) ; (/ (sqrt x) x) -> (/ (sqrt x)) (eq? (car arg1) 'sqrt) (equal? (cadr arg1) arg2)) (list '/ arg1)) - + ((and (len>1? arg2) ; (/ x (sqrt x)) -> (sqrt x) (eq? (car arg2) 'sqrt) (equal? (cadr arg2) arg1)) arg2) - + (else (cons '/ args)))))))) - - (else + + (else ;; spot check of divides in lg didn't turn up any that need the plus/minus style handling of + et al above (if (memv arg1 '(0 0.0)) ; (/ 0 x y) -> 0 (to be consistent with other results) arg1 (if (and (just-rationals? args) (not (memv 0 (cdr args))) (not (memv 0.0 (cdr args)))) - (catch #t - (lambda () + (catch #t + (lambda () (apply / args)) ; if no overflow catch we can hit divide by zero here (lambda a form)) (let ((nargs ; (/ x a (* b 1 c) d) -> (/ x a b c d) @@ -5754,7 +5754,7 @@ ;; also since (for example) sin(x - y) = -sin(y - x) and cos(x - y) = cos(y - x), can other simplifiers swap? (cond ((not (len=1? args)) (cons head args)) - + ((and (len=2? (car args)) ; (sin (asin x)) -> x (eq? (caar args) (case head @@ -5773,18 +5773,18 @@ ((log) 'exp) ((exp) 'log)))) (cadar args)) - + ((eqv? (car args) 0) ; (sin 0) -> 0 (case head ((sin asin sinh asinh tan tanh atanh) 0) ((exp cos cosh) 1) (else (cons head args)))) - + ((and (eq? head 'cos) ; (cos (- x)) -> (cos x) (len=2? (car args)) (eq? (caar args) '-)) (list 'cos (cadar args))) - + ((or (eq? (car args) 'pi) ; (sin pi) -> 0.0 (and (len=2? (car args)) (eq? (caar args) '-) @@ -5793,14 +5793,14 @@ ((sin tan) 0.0) ((cos) -1.0) (else (cons head args)))) - + ((eqv? (car args) 0.0) ; (sin 0.0) -> 0.0 ((symbol->value head (rootlet)) 0.0)) - + ((and (eq? head 'acos) ; (acos -1) -> pi (eqv? (car args) -1)) 'pi) - + ((and (eq? head 'exp) ; (exp (* a (log b))) -> (expt b a) (pair? (car args)) (eq? (caar args) '*)) @@ -5814,13 +5814,13 @@ (eq? (caadr targ) 'log)) (list 'expt (cadadr targ) (car targ))) (else (cons head args))))) - + (else (cons head args))))) (for-each (lambda (f) (hash-table-set! h f numtrig)) '(sin cos tan asin acos sinh cosh tanh asinh acosh atanh exp))) - + (let () (define (numlog args form env) (let ((len (length args))) @@ -5857,7 +5857,7 @@ (else 1.0)))) (hash-table-set! h 'log numlog)) - + (let () (define (numintlen args form env) (if (and (len=1? (cdr form)) @@ -5879,20 +5879,20 @@ (list 'exp (list '/ (cadar args) 2))) ; (sqrt (exp x)) -> (exp (/ x 2)) (else (cons 'sqrt args)))) (hash-table-set! h 'sqrt numsqrt)) - + (let () (define (numfloor args form env) (cond ((not (len=1? args)) form) - + ((number? (car args)) - (catch #t - (lambda () (apply (symbol->value (car form) (rootlet)) args)) + (catch #t + (lambda () (apply (symbol->value (car form) (rootlet)) args)) (lambda any (cons (car form) args)))) - + ((not (len>1? (car args))) (cons (car form) args)) - + ((or (integer-result? (caar args)) (and (eq? (caar args) 'random) (pair? (cdar args)) @@ -5905,10 +5905,10 @@ (eq? (caadr form) '/) (len=3? (cadr form))) (cons 'quotient (cdadr form))) - + ((memq (caar args) '(inexact->exact exact)) (list (car form) (cadar args))) - + ((memq (caar args) '(* + / -)) ; maybe extend this list `(,(car form) (,(caar args) ,@(map (lambda (p) (if (and (len=2? p) @@ -5925,47 +5925,47 @@ (list 'random (floor (cadar args)))) (else (cons (car form) args)))) - + (for-each (lambda (f) (hash-table-set! h f numfloor)) '(floor round ceiling truncate))) - + (let () (define (numabs args form env) (cond ((not (len=1? args)) form) - + ((and (pair? (car args)) ; (abs (abs x)) -> (abs x) (hash-table-ref non-negative-ops (caar args))) (car args)) - + ((rational? (car args)) (abs (car args))) - + ((not (pair? (car args))) (cons (car form) args)) - + ((and (memq (caar args) '(modulo random)) (= (length (car args)) 3) ; (abs (modulo x 2)) -> (modulo x 2) (real? (caddar args)) (positive? (caddar args))) (car args)) - + ((and (eq? (caar args) '-) ; (abs (- x)) -> (abs x) (len=1? (cdar args))) (list (car form) (cadar args))) ;; make-polar as arg never happens - + (else (cons (car form) args)))) (hash-table-set! h 'abs numabs) (hash-table-set! h 'magnitude numabs)) - + (let () (define (real-result? op) (memq op '(imag-part real-part abs magnitude angle max min exact->inexact inexact modulo remainder quotient lcm gcd))) - + (define (numimag args form env) (if (not (len=1? args)) form @@ -5975,7 +5975,7 @@ 0.0 (cons 'imag-part args)))) (hash-table-set! h 'imag-part numimag) - + (define (numreal args form env) (if (not (len=1? args)) form @@ -5985,7 +5985,7 @@ (car args) (cons 'real-part args)))) (hash-table-set! h 'real-part numreal)) - + (let () (define (numden args form env) (if (not (len=1? args)) @@ -5996,7 +5996,7 @@ 1 (list 'denominator (car args))))) (hash-table-set! h 'denominator numden)) - + (let () (define (numnum args form env) (cond ((not (len=1? args)) @@ -6009,7 +6009,7 @@ (numerator (car args))) (else (list 'numerator (car args))))) (hash-table-set! h 'numerator numnum)) - + (let () (define (numran args form env) (if (not (and (len=1? args) @@ -6031,7 +6031,7 @@ (cons 'complex args))) (hash-table-set! h 'complex numcmplx) (hash-table-set! h 'make-rectangular numcmplx)) - + (let () (define (numpol args form env) (if (and (len=2? args) @@ -6039,7 +6039,7 @@ (car args) (cons 'make-polar args))) (hash-table-set! h 'make-polar numpol)) - + (let () (define (numrat args form env) (let ((len2 (= (length args) 2)) @@ -6050,12 +6050,12 @@ (apply (symbol->value head (rootlet)) args)) (lambda ignore (cons head args)))) ; use this form to pick up possible arg changes - + ((and (eq? head 'ash) ; (ash x 0) -> x - len2 + len2 (eqv? (cadr args) 0)) (car args)) - + ((case head ((quotient) ; (quotient (remainder x y) y) -> 0 (and len2 @@ -6066,19 +6066,19 @@ (and len2 (eqv? (car args) 0))) (else #f)) 0) - + ((and (eq? head 'modulo) ; (modulo (abs x) y) -> (modulo x y) len2 (pair? (car args)) (eq? (caar args) 'abs)) (list 'modulo (cadar args) (cadr args))) - + (else (cons head args))))) (for-each (lambda (f) (hash-table-set! h f numrat)) '(rationalize lognot ash modulo remainder quotient))) - + (let () (define (numexpt args form env) (cond ((not (len=2? args)) @@ -6093,7 +6093,7 @@ ((or (and (eqv? (cadr args) 0) ; (expt x 0) -> 1 (not (eqv? (car args) 0))) - (eqv? (car args) 1)) ; (expt 1 x) -> 1 + (eqv? (car args) 1)) ; (expt 1 x) -> 1 1) ((eqv? (cadr args) 1) ; (expt x 1) -> x @@ -6123,7 +6123,7 @@ (else (cons 'expt args)))) (hash-table-set! h 'expt numexpt)) - + (let () (define (numang args form env) (cond ((not (pair? args)) form) @@ -6133,7 +6133,7 @@ 0.0) (else (cons 'angle args)))) (hash-table-set! h 'angle numang)) - + (let () (define (numatan args form env) (cond ((and (len=1? args) ; (atan (x y)) -> (atan x y) @@ -6146,11 +6146,11 @@ 'pi) (else (cons 'atan args)))) (hash-table-set! h 'atan numatan)) - + (let () (define (rational-result? op) (memq op '(rationalize inexact->exact exact))) - + (define (numexact args form env) (cond ((not (len=1? args)) form) @@ -6167,27 +6167,27 @@ (else (cons (car form) args)))) (hash-table-set! h 'inexact->exact numexact) (hash-table-set! h 'exact numexact)) - + (let () (define (numinexact args form env) (cond ((not (len=1? args)) form) - + ((memv (car args) '(0 0.0)) 0.0) - + ((not (and (pair? (car args)) (not (eq? (caar args) 'random)) (hash-table-ref numeric-ops (caar args)) (any-numbers? (cdar args)))) (cons (car form) args)) - + ((lint-any? (lambda (x) (and (number? x) (inexact? x))) (cdar args)) (car args)) - + (else (let ((new-form (copy (car args)))) (do ((p (cdr new-form) (cdr p))) @@ -6199,13 +6199,13 @@ ;; not (inexact (random 3)) -> (random 3.0) because results are different (hash-table-set! h 'exact->inexact numinexact) (hash-table-set! h 'inexact numinexact)) - + (let () (define (numior args form env) (let ((args (lint-remove-duplicates (remove-all 0 (splice-if 'logior args)) env))) (if (lint-every? (lambda (x) (or (not (number? x)) (integer? x))) args) (let ((rats (collect-if-integer args))) - (if (len>1? rats) + (if (len>1? rats) (let ((y (apply logior rats))) (set! args (if (zero? y) (collect-if-not-number args) @@ -6216,12 +6216,12 @@ ((just-integers? args) (apply logior args)) (else (cons 'logior args))))) (hash-table-set! h 'logior numior) - + (define (numand args form env) (let ((args (lint-remove-duplicates (remove-all -1 (splice-if 'logand args)) env))) (if (lint-every? (lambda (x) (or (not (number? x)) (integer? x))) args) (let ((rats (collect-if-integer args))) - (if (len>1? rats) + (if (len>1? rats) (let ((y (apply logand rats))) (set! args (if (= y -1) (collect-if-not-number args) @@ -6231,14 +6231,14 @@ ((memv 0 args) 0) ((just-integers? args) (apply logand args)) (else (cons 'logand args))))) - - ;; (logand 1 (logior 2 x)) -> (logand 1 x)? + + ;; (logand 1 (logior 2 x)) -> (logand 1 x)? ;; (logand 1 (logior 1 x)) -> 1 ;; (logand 3 (logior 1 x))? ;; similarly for (logior...(logand...)) - + (hash-table-set! h 'logand numand) - + (define (numxor args form env) (let ((args (splice-if 'logxor args))) ; is this correct?? (cond ((null? args) 0) ; (logxor) -> 0 @@ -6247,11 +6247,11 @@ ((and (len=2? args) (equal? (car args) (cadr args))) 0) ; (logxor x x) -> 0 (else (cons 'logxor args))))) ; (logxor x (logxor y z)) -> (logxor x y z) (hash-table-set! h 'logxor numxor)) - + (let () (define (numgcd args form env) (let ((args (lint-remove-duplicates (splice-if 'gcd args) env))) - (cond ((null? args) 0) + (cond ((null? args) 0) ((memv 1 args) 1) ((just-rationals? args) (catch #t ; maybe (gcd -9223372036854775808 -9223372036854775808) @@ -6264,7 +6264,7 @@ ((eqv? (cadr args) 0) (list 'abs (car args))) (else (cons 'gcd args))))) (hash-table-set! h 'gcd numgcd)) - + (let () (define (numlcm args form env) (let ((args (lint-remove-duplicates (splice-if 'lcm args) env))) @@ -6280,7 +6280,7 @@ (list 'abs (car args))) (else (cons 'lcm args))))) (hash-table-set! h 'lcm numlcm)) - + (let () (define (nummax args form env) (if (not (pair? args)) @@ -6318,14 +6318,14 @@ new-args))) (if (< (length new-args) (length args)) (set! args new-args))))) ; might set args to ()? - + ;; if (max c1 (min c2 . args1) . args2) where (> c1 c2) -> (max c1 . args2), if = -> c1 ;; if (min c1 (max c2 . args1) . args2) where (< c1 c2) -> (min c1 . args2), if = -> c1 ;; and if (max 4 x (min x 4)) -- is it (max x 4)? ;; (max a b) is (- (min (- a) (- b))), but that doesn't help here -- the "-" gets in our way ;; (min (- a) (- b)) -> (- (max a b))? ;; (+ a (max|min b c)) = (max|min (+ a b) (+ a c))) - + (cond ((not (pair? args)) ; something is messed up in the original expression form) ((null? (cdr args)) ; (max (min x 3) (min x 3)) -> (max (min x 3)) -> (min x 3) @@ -6345,7 +6345,7 @@ (hash-table-set! h 'max nummax) (hash-table-set! h 'min nummax)) h)) ; define numerics-table - + (lambda (form env) ; simplify-numerics?? (define (simplify-arg x) (if (or (null? x) ; constants and the like look dumb if simplified @@ -6366,7 +6366,7 @@ => (lambda (f) (f args form env))) (else (cons (car form) args))))))) - + (define (binding-ok? caller head binding env second-pass) ;; check let-style variable binding for various syntactic problems (cond (second-pass @@ -6376,7 +6376,7 @@ (or (null? (cddr binding)) (and (eq? head 'do) (len=1? (cddr binding)))))) ; (do ((i 0 . 1))...) - + ((not (pair? binding)) (lint-format "~A binding is not a list? ~S" caller head binding) #f) ; (let (a) a) ((not (symbol? (car binding))) (lint-format "~A variable is not a symbol? ~S" caller head binding) #f) ; (let ((1 2)) #f) ((keyword? (car binding)) (lint-format "~A variable is a keyword? ~S" caller head binding) #f) ; (let ((:a 1)) :a) @@ -6405,7 +6405,7 @@ (define (check-char-cmp caller op form) (if (and (tree-memq 'char->integer (cdr form)) - (lint-every? (lambda (x) + (lint-every? (lambda (x) (or (and (integer? x) (<= 0 x 255)) (and (len=2? x) @@ -6417,7 +6417,7 @@ (map (lambda (arg) ((if (integer? arg) integer->char cadr) arg)) (cdr form))))))) - + (define (write-port expr) ; ()=not specified (*stdout*), #f=something is wrong (not enough args) (and (pair? expr) (if (eq? (car expr) 'newline) @@ -6428,12 +6428,12 @@ (if (pair? (cddr expr)) (caddr expr) ()))))) - + (define (display->format d) (case (car d) ((newline) (copy "~%")) - - ((display) + + ((display) (let* ((arg (cadr d)) (arg-arg (and (len>1? arg) (cadr arg)))) @@ -6473,7 +6473,7 @@ (values (string-append "~A" (caddr arg)) arg-arg)) (else (values "~A" arg))))) - + ((write) ;; very few special cases actually happen here, unlike display above (if (string? (cadr d)) @@ -6481,12 +6481,12 @@ (if (char? (cadr d)) (string (cadr d)) (values "~S" (cadr d))))) - + ((write-char) (if (char? (cadr d)) (string (cadr d)) (values "~C" (cadr d)))) - + ((write-string) ; same as display but with possible start|end indices (let ((indices (and (len>1? (cddr d)) ; port (cdddr d)))) @@ -6517,24 +6517,24 @@ (and (len>2? x) (eq? (car x) 'lambda) (len=1? (cadr x)))) - + (denote (identity? x) ; (lambda (x) x), or (define (x) x) -> procedure-source (and (easy-lambda? x) (null? (cdddr x)) (eq? (caddr x) (caadr x)))) - + (denote (simple-lambda? x) (and (easy-lambda? x) (null? (cdddr x)) (= (tree-count (caadr x) (caddr x) 2) 1))) - + (define (less-simple-lambda? x) (and (easy-lambda? x) (= (tree-count (caadr x) (cddr x) 2) 1))) - + (define (cdr-count c) (case c ((cdr) 1) ((cddr) 2) ((cdddr) 3) (else 4))) - + (define* (find-unique-name f1 f2 (i 1)) (let ((sym (string->symbol (format #f "<~D>" i)))) (if (not (or (eq? sym f1) @@ -6543,48 +6543,48 @@ (tree-memq sym f2))) sym (find-unique-name f1 f2 (+ i 1))))) - - (define (unrelop caller head form) ; assume len=3 + + (define (unrelop caller head form) ; assume len=3 (let ((arg1 (cadr form)) (arg2 (caddr form))) (if (len=3? arg1) (if (eq? (car arg1) '-) (if (memv arg2 '(0 0.0)) ; (< (- x y) 0) -> (< x y), need both 0 and 0.0 because (eqv? 0 0.0) is #f - (lint-format "perhaps ~A" caller - (lists->string form + (lint-format "perhaps ~A" caller + (lists->string form (list head (cadr arg1) (caddr arg1)))) (if (and (integer? arg2) ; (> (- x 50868) 256) -> (> x 51124) (integer? (caddr arg1))) - (lint-format "perhaps ~A" caller - (lists->string form + (lint-format "perhaps ~A" caller + (lists->string form (list head (cadr arg1) (+ (caddr arg1) arg2)))))) ;; (> (- x) (- y)) (> (- x 1) (- y 1)) and so on -- do these ever happen? (no, not even if we allow +-*/) - + (if (and (eq? (car arg1) '+) ; (< (+ x 1) 3) -> (< x 2) - (integer? arg2) + (integer? arg2) (integer? (caddr arg1))) - (lint-format "perhaps ~A" caller - (lists->string form + (lint-format "perhaps ~A" caller + (lists->string form (list head (cadr arg1) (- arg2 (caddr arg1))))))) (if (len=3? arg2) (if (eq? (car arg2) '-) (if (memv arg1 '(0 0.0)) ; (< 0 (- x y)) -> (> x y) - (lint-format "perhaps ~A" caller - (lists->string form + (lint-format "perhaps ~A" caller + (lists->string form (list (hash-table-ref reversibles head) (cadr arg2) (caddr arg2)))) (if (and (integer? arg1) (integer? (caddr arg2))) - (lint-format "perhaps ~A" caller - (lists->string form + (lint-format "perhaps ~A" caller + (lists->string form (list (hash-table-ref reversibles head) (cadr arg2) (+ arg1 (caddr arg2))))))) (if (and (eq? (car arg2) '+) ; (< 256 (+ fltdur 50868)) -> (> fltdur -50612) (integer? arg1) (integer? (caddr arg2))) - (lint-format "perhaps ~A" caller - (lists->string form + (lint-format "perhaps ~A" caller + (lists->string form (list (hash-table-ref reversibles head) (cadr arg2) (- arg1 (caddr arg2))))))))))) - - + + (define (check-start-and-end caller head form ff env) (if (len>1? form) (if (pair? (cddr form)) @@ -6598,7 +6598,7 @@ (define (other-case c) ((if (char-upper-case? c) char-downcase char-upcase) c)) - + (define (check-boolean-affinity caller form env) ;; does built-in boolean func's arg make sense (when (= (length form) 2) @@ -6620,7 +6620,7 @@ (let ((val (checked-eval form))) (if (not (eq? val :checked-eval-error)) (lint-format "perhaps ~A" caller (lists->string form val))))) - + (when (and (pair? (cadr form)) (symbol? (caadr form))) (let ((rt (if (and (eq? (caadr form) 'quote) @@ -6642,7 +6642,7 @@ h)) ;; not combinable: caaaar caaadr caadar caaddr cadaar cadadr caddar cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar - (define combine-cxrs + (define combine-cxrs (let ((cxr? (lambda (s) (and (pair? (cdr s)) (len=2? (cadr s)) @@ -6653,7 +6653,7 @@ (arg2 (and arg1 (cxr? arg1) (cadr arg1))) (arg3 (and arg2 (cxr? arg2) (cadr arg2)))) (values (string-append (hash-table-ref combinable-cxrs (car form)) - (hash-table-ref combinable-cxrs (car arg1)) + (hash-table-ref combinable-cxrs (car arg1)) (if arg2 (hash-table-ref combinable-cxrs (car arg2)) "") (if arg3 (hash-table-ref combinable-cxrs (car arg3)) "")) (let ((val (cadr (or arg3 arg2 arg1)))) @@ -6671,7 +6671,7 @@ (len (length name)) (i 0 (+ i 1)) (bit 0 (+ bit 2))) - ((= i len) + ((= i len) (set! ci (cons (cons c sum) ci)) (set! ic (cons (cons sum c) ic))) (set! sum (+ sum (expt 2 (if (char=? (name i) #\a) bit (+ bit 1)))))))) @@ -6679,21 +6679,21 @@ caaaar caaadr caadar caaddr cadaar cadadr caddar cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar)) (list (reverse ci) (reverse ic))) |# - (define match-cxr - (let ((int->cxr (hash-table 1 'car 2 'cdr - 5 'caar 6 'cadr 10 'cddr 9 'cdar - 21 'caaar 22 'caadr 26 'caddr 42 'cdddr 37 'cdaar 41 'cddar 25 'cadar 38 'cdadr - 106 'cadddr 170 'cddddr 85 'caaaar 86 'caaadr 89 'caadar 90 'caaddr 101 'cadaar 102 'cadadr + (define match-cxr + (let ((int->cxr (hash-table 1 'car 2 'cdr + 5 'caar 6 'cadr 10 'cddr 9 'cdar + 21 'caaar 22 'caadr 26 'caddr 42 'cdddr 37 'cdaar 41 'cddar 25 'cadar 38 'cdadr + 106 'cadddr 170 'cddddr 85 'caaaar 86 'caaadr 89 'caadar 90 'caaddr 101 'cadaar 102 'cadadr 105 'caddar 149 'cdaaar 150 'cdaadr 153 'cdadar 154 'cdaddr 165 'cddaar 166 'cddadr 169 'cdddar)) - (cxr->int (hash-table 'car 1 'cdr 2 - 'caar 5 'cadr 6 'cddr 10 'cdar 9 - 'caaar 21 'caadr 22 'caddr 26 'cdddr 42 'cdaar 37 'cddar 41 'cadar 25 'cdadr 38 - 'cadddr 106 'cddddr 170 'caaaar 85 'caaadr 86 'caadar 89 'caaddr 90 'cadaar 101 'cadadr 102 + (cxr->int (hash-table 'car 1 'cdr 2 + 'caar 5 'cadr 6 'cddr 10 'cdar 9 + 'caaar 21 'caadr 22 'caddr 26 'cdddr 42 'cdaar 37 'cddar 41 'cadar 25 'cdadr 38 + 'cadddr 106 'cddddr 170 'caaaar 85 'caaadr 86 'caadar 89 'caaddr 90 'cadaar 101 'cadadr 102 'caddar 105 'cdaaar 149 'cdaadr 150 'cdadar 153 'cdaddr 154 'cddaar 165 'cddadr 166 'cdddar 169))) (lambda (c1 c2) - (hash-table-ref int->cxr (logand (or (hash-table-ref cxr->int c1) 0) + (hash-table-ref int->cxr (logand (or (hash-table-ref cxr->int c1) 0) (or (hash-table-ref cxr->int c2) 0)))))) - + (define (mv-range producer env) (if (symbol? producer) (let ((v (var-member producer env))) @@ -6701,7 +6701,7 @@ (pair? ((cdr v) 'nvalues)) ((cdr v) 'nvalues))) (and (pair? producer) - (case (car producer) + (case (car producer) ((lambda lambda*) (and (len>1? (cdr producer)) (count-values (cddr producer)))) @@ -6714,7 +6714,7 @@ (cdr producer)) (list len len))) (else (mv-range (car producer) env)))))) - + (define (eval-constant-expression caller form) (if (just-code-constants? (cdr form)) (catch #t @@ -6728,7 +6728,7 @@ (if (not (and (pair? tree) (list? (cdr tree)))) tree - (case (car tree) + (case (car tree) ((list-values) (if (and (assq 'apply-values (cdr tree)) (len=2? (cdr tree)) @@ -6738,7 +6738,7 @@ (list 'append (cadadr tree) (cadr (caddr tree))) (list 'cons (cadr tree) (cadr (caddr tree)))) (cons 'list (unlist-values (cdr tree))))) ; #_list perhaps? and #_cons #_append above? - + ((append) (if (and (len=2? (cdr tree)) (pair? (cadr tree)) @@ -6751,10 +6751,10 @@ ((2) (list 'cons (cadr lst) rest)) ((3) (list 'cons (cadr lst) (list 'cons (caddr lst) rest))) (else (cons 'append (unlist-values (cdr tree))))))))) - + (else (cons (unlist-values (car tree)) (unlist-values (cdr tree))))))) - + (define (qq-tree? tree) (and (pair? tree) (or (eq? (car tree) 'apply-values) @@ -6781,7 +6781,7 @@ (pair? (caddr f)) (memq (caaddr f) '(lambda lambda*)))))))) - + (define special-case-functions (let ((special-case-table (make-hash-table))) @@ -6790,7 +6790,7 @@ (format *stderr* "~A already has a value: ~A~%" key (hash-table-ref special-case-table key))) (hash-table-set! special-case-table key value)) - (define string->char= + (define string->char= (let ((substring->char? (lambda (s2) (and (eq? (car s2) 'substring) (= (length s2) 4) @@ -6809,7 +6809,7 @@ (if (eq? (car s2) 'string) ; (equal? "[" (string r)) -> (char=? #\[ r) (if (not (len=2? s2)) ; (eqv? "a" (string)) or (string=? "a" (string a b)) (lint-format "~A is #f" caller original-form) - (lint-format "perhaps ~A" caller + (lint-format "perhaps ~A" caller (lists->string original-form (list 'char=? (string-ref s1 0) (cadr s2))))) (if (substring->char? s2) ; (equal? "^" (substring s 0 1)) -> (char=? #\^ (string-ref s 0)) (lint-format "perhaps ~A" caller @@ -6837,7 +6837,7 @@ ;; ---------------- member and assoc ---------------- (let () - (define sp-memx + (define sp-memx (let ((list-one? (lambda (p) (and (len=2? p) (case (car p) @@ -6855,12 +6855,12 @@ ((3) (let ((selector (cadr form)) (items (caddr form))) - + (let ((current-eqf (case head ((memq assq) 'eq?) ((memv assv) 'eqv?) (else 'equal?))) (selector-eqf (car (eqf selector env))) (one-item (and (memq head '(memq memv member)) (list-one? items)))) ;; one-item assoc doesn't simplify cleanly - + (if one-item (let* ((target (one-item items)) (iter-eqf (eqf target env))) @@ -6868,7 +6868,7 @@ (unquoted-pair? target)) (set! target (list 'quote target))) ; ; (member x (list "asdf")) -> (string=? x "asdf") -- maybe equal? here? (lint-format "perhaps ~A" caller (lists->string form (list (cadr iter-eqf) selector target)))) - + ;; not one-item (letrec ((duplicates? (lambda (lst fnc) (and (pair? lst) @@ -6881,11 +6881,11 @@ (duplicate-constants? (cdr lst) fnc)))))) (if (and (symbol? selector-eqf) ; (memq 1.0 x): perhaps memq -> memv (not (eq? selector-eqf current-eqf))) - (lint-format "~A: perhaps ~A -> ~A" caller (truncated-list->string form) head + (lint-format "~A: perhaps ~A -> ~A" caller (truncated-list->string form) head (if (memq head '(memq memv member)) (case selector-eqf ((eq?) 'memq) ((eqv?) 'memv) ((equal?) 'member)) (case selector-eqf ((eq?) 'assq) ((eqv?) 'assv) ((equal?) 'assoc))))) - + ;; -------------------------------- ;; check for head mismatch with items (when (pair? items) @@ -6893,19 +6893,19 @@ (quoted-pair? items)) (let ((elements ((if (eq? (car items) 'quote) cadr cdr) items))) (let ((baddy #f)) - (catch #t - (lambda () + (catch #t + (lambda () (set! baddy ((if (eq? (car items) 'list) duplicate-constants? duplicates?) elements (symbol->value head)))) (lambda args #f)) (if (pair? baddy) ; (member x (list "asd" "abc" "asd")) (lint-format "duplicated entry ~S in ~A" caller (car baddy) items))) - + (when (proper-list? elements) (let ((maxf #f) (keys (if (eq? (car items) 'quote) (if (memq head '(memq memv member)) - elements + elements (and (just-pairs? elements) (map car elements))) (if (memq head '(memq memv member)) @@ -6916,7 +6916,7 @@ (eq? (car e) 'quote) (pair? (cadr e)))) elements) - (map caadr elements)))))) + (map caadr elements)))))) (when (proper-list? keys) (if (eq? (car items) 'quote) (do ((p keys (cdr p))) @@ -6952,30 +6952,30 @@ (case maxf ((eq?) (if (not (memq head '(memq assq))) ; (member (car op) '(x y z)) - (lint-format "~A could be ~A in ~A" caller - head + (lint-format "~A could be ~A in ~A" caller + head (if (memq head '(memv member)) 'memq 'assq) form))) ((eqv?) (if (not (memq head '(memv assv))) ; (memq (strname 0) '(#\{ #\[ #\())) - (lint-format "~A ~Aould be ~A in ~A" caller - head + (lint-format "~A ~Aould be ~A in ~A" caller + head (if (memq head '(memq assq)) "sh" "c") (if (memq head '(memq member)) 'memv 'assv) form))) ((equal? #t) ; (memq (car op) '("a" #())) (if (not (memq head '(member assoc))) - (lint-format "~A should be ~A in ~A" caller - head + (lint-format "~A should be ~A in ~A" caller + head (if (memq head '(memq memv)) 'member 'assoc) form)))))) - + (if (and (= (length elements) 2) ; (memq expr '(#t #f)) (memq #t elements) (memq #f elements)) (lint-format "perhaps ~A" caller (lists->string form (list 'boolean? selector))))))) ;; not (memv x '(0 0.0)) -> (zero? x) because x might not be a number - + (case (car items) ((map) (let ((memx (memq head '(memq memv member)))) @@ -6984,45 +6984,45 @@ (map-items (caddr items))) (cond ((eq? mapf 'car) ; (memq x (map car y)) -> (assq x y) (lint-format "perhaps use assoc: ~A" caller - (lists->string form (list (case current-eqf ((eq?) 'assq) ((eqv?) 'assv) ((equal?) 'assoc)) + (lists->string form (list (case current-eqf ((eq?) 'assq) ((eqv?) 'assv) ((equal?) 'assoc)) selector map-items)))) - + ((eq? selector #t) (if (eq? mapf 'null?) ; (memq #t (map null? items)) -> (memq () items) - (lint-format "perhaps ~A" caller + (lint-format "perhaps ~A" caller (lists->string form (list 'memq () map-items))) - (let ((b (if (eq? mapf 'b) 'c 'b))) + (let ((b (if (eq? mapf 'b) 'c 'b))) ;; (memq #t (map cadr items)) -> (member #t items (lambda (a b) (cadr b))) - (lint-format "perhaps avoid 'map: ~A" caller + (lint-format "perhaps avoid 'map: ~A" caller (lists->string form `(member #t ,map-items (lambda (a ,b) (,mapf ,b)))))))) - + ((and (pair? selector) (eq? (car selector) 'string->symbol) ; this could be extended, but it doesn't happen (eq? mapf 'string->symbol) (not (and (pair? map-items) (eq? (car map-items) 'quote)))) - (lint-format "perhaps ~A" caller + (lint-format "perhaps ~A" caller ;; (memq (string->symbol x) (map string->symbol y)) -> (member x y string=?) (lists->string form `(member ,(cadr selector) ,map-items string=?)))) - - (else + + (else ;; (member x (map b items)) -> (member x items (lambda (a c) (equal? a (b c)))) (let ((b (if (eq? mapf 'b) 'c 'b))) ; a below can't collide because eqf won't return 'a - (lint-format "perhaps avoid 'map: ~A" caller - (lists->string form `(member ,selector ,map-items + (lint-format "perhaps avoid 'map: ~A" caller + (lists->string form `(member ,selector ,map-items (lambda (a ,b) (,current-eqf a (,mapf ,b))))))))))))) - + ((string->list) ; (memv c (string->list s)) -> (char-position c s) - (lint-format "perhaps ~A" caller + (lint-format "perhaps ~A" caller (lists->string form (cons 'char-position (cons (cadr form) (cdr items)))))) - + ((cons) ; (member x (cons y z)) -> (or (equal? x y) (member x z)) (if (and (not (pair? selector)) (len=3? items)) (lint-format "perhaps avoid 'cons: ~A" caller (lists->string form `(or (,current-eqf ,selector ,(cadr items)) (,head ,selector ,(caddr items))))))) - + ((append) ; (member x (append (list x) y)) -> (or (equal? x x) (member x y)) (if (and (not (pair? selector)) (len=3? items) @@ -7034,7 +7034,7 @@ (when (and (memq head '(memq memv)) (quoted-pair? items)) (let ((nitems (length (cadr items)))) - + (if (pair? selector) ; (memv (string-ref x 0) '(+ -)) -> #f etc (let ((sig (arg-signature (car selector) env))) (if (and (pair? sig) @@ -7051,7 +7051,7 @@ `(,head ,selector ',vals))))))))) (if (> nitems 20) (lint-format "perhaps use a hash-table here, rather than ~A" caller (truncated-list->string form))) - + (let ((bad (lint-find-if (lambda (x) (not (or (symbol? x) (char? x) @@ -7066,7 +7066,7 @@ (values "pointless list member: ~S in ~A" caller bad)) ;; quoted item here is caught above ; (memq x '(a (+ 1 2) 3)) form))))))) - + ((4) (let ((func (list-ref form 3))) (if (symbol? func) @@ -7103,8 +7103,8 @@ (if (or (eq? func 'eq?) (eq? (caaddr func) 'eq?)) 'assq - (if (eq? (caaddr func) 'eqv?) - 'assv + (if (eq? (caaddr func) 'eqv?) + 'assv 'assoc)))))) (when (pair? (cadr form)) ; (member (abs x) lst (lambda (a b) (< b 2))) (let ((args (cadr func))) @@ -7115,7 +7115,7 @@ (for-each (lambda (f) (hash-special f sp-memx)) '(memq assq memv assv member assoc))) - + ;; ---------------- car, cdr, etc ---------------- (let () (define (sp-crx caller head form env) @@ -7124,25 +7124,25 @@ (when cxr (set! last-simplify-cxr-line-number line-number) (cond ((< (length cxr) 5) ; (car (cddr x)) -> (caddr x) - (lint-format "perhaps ~A" caller + (lint-format "perhaps ~A" caller (lists->string form (list (symbol "c" cxr "r") arg)))) - + ;; if it's car|cdr followed by cdr's, use list-ref|tail ((not (char-position #\a cxr)) ; (cddddr (cddr x)) -> (list-tail x 6) (lint-format "perhaps ~A" caller (lists->string form (list 'list-tail arg (length cxr))))) - + ((not (char-position #\a (substring cxr 1))) ; (car (cddddr (cddr x))) -> (list-ref x 6) (lint-format "perhaps ~A" caller (lists->string form (list 'list-ref arg (- (length cxr) 1))))) - + (else (set! last-simplify-cxr-line-number -1))))) (combine-cxrs form))) - + (when (and (len>1? form) (len>1? (cadr form))) (let ((arg (cadr form))) - (when (eq? head 'car) - (case (car arg) + (when (eq? head 'car) + (case (car arg) ((list-tail) ; (car (list-tail x y)) -> (list-ref x y) (if (len=3? arg) (lint-format "perhaps ~A" caller (lists->string form (list 'list-ref (cadr arg) (caddr arg)))))) @@ -7159,7 +7159,7 @@ ((memq memv member assq assv assoc) (if (pair? (cdr arg)) ; (car (memq x ...)) is either x or (car #f) -> error (lint-format "~A is ~A, or an error" caller (truncated-list->string form) (cadr arg)))))) - + (when (and (eq? (car arg) 'or) ; (cdr (or (assoc x y) (cons 1 2))) -> (cond ((assoc x y) => cdr) (else 2)) (not (eq? form last-rewritten-internal-define)) (len=3? arg)) @@ -7170,7 +7170,7 @@ (eq? head 'cdr)) (memq (car arg2) '(error throw)) (quoted-pair? arg2))) - (let ((else-val (catch #t + (let ((else-val (catch #t (lambda () (case (car arg2) ((quote) ((symbol->value head) (cadr arg2))) @@ -7201,13 +7201,13 @@ caller head (truncated-list->string arg) (truncated-list->string ((if (eq? head 'car) cadr caddr) arg)))) - + (when (memq head '(car cadr caddr cadddr)) - (case (car arg) + (case (car arg) ((string->list vector->list) ; (car (string->list x)) -> (string-ref x 0) - (lint-format "perhaps ~A" caller (lists->string form + (lint-format "perhaps ~A" caller (lists->string form (list (if (eq? (car arg) 'string->list) 'string-ref 'vector-ref) - (cadr arg) + (cadr arg) (case head ((car) 0) ((cadr) 1) ((caddr) 2) (else 3)))))) ((reverse reverse!) (lint-format "perhaps ~A~A" caller ; (car (reverse x)) -> (list-ref x (- (length x) 1)) @@ -7216,8 +7216,8 @@ "") (lists->string form (if (symbol? (cadr arg)) - `(list-ref ,(cadr arg) - (- (length ,(cadr arg)) + `(list-ref ,(cadr arg) + (- (length ,(cadr arg)) ,(case head ((car) 1) ((cadr) 2) ((caddr) 3) (else 4)))) `(let ((<1> ,(cadr arg))) ; let is almost certainly cheaper than reverse (list-ref <1> (- (length <1>) @@ -7227,8 +7227,8 @@ combinable-cxrs)) ;; not combinable cxrs: ;; caaaar caaadr caadar caaddr cadaar cadadr caddar - ;; cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar - + ;; cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar + ;; ---------------- set-car! ---------------- (let () (define (sp-set-car! caller head form env) @@ -7240,25 +7240,25 @@ (truncated-list->string form))) (if (pair? target) (case (car target) - + ((list-tail) ; (set-car! (list-tail x y) z) -> (list-set! x y z) (lint-format "perhaps ~A" caller (lists->string form (list 'list-set! (cadr target) (caddr target) (caddr form))))) - + ((cdr cddr cdddr cddddr) ; (set-car! (cddr (cdddr x)) y) -> (list-set! x 5 y) (set! last-simplify-cxr-line-number line-number) - (lint-format "perhaps ~A" caller - (lists->string form + (lint-format "perhaps ~A" caller + (lists->string form (if (and (pair? (cadr target)) (memq (caadr target) '(cdr cddr cdddr cddddr))) ;; (set-car! (cdr (cddr x)) y) -> (list-set! x 3 y) - (list 'list-set! + (list 'list-set! (cadadr target) - (+ (cdr-count (car target)) (cdr-count (caadr target))) + (+ (cdr-count (car target)) (cdr-count (caadr target))) (caddr form)) ;; (set-car! (cdr x) y) -> (list-set! x 1 y) - (list 'list-set! - (cadr target) - (cdr-count (car target)) + (list 'list-set! + (cadr target) + (cdr-count (car target)) (caddr form))))))))))) (hash-special 'set-car! sp-set-car!)) @@ -7294,15 +7294,15 @@ (memq 'not (car sig)))) (not (memq (car sig) '(#t values boolean? not))))) (lint-format "~A can't be true (~A never returns #f)" caller (truncated-list->string form) (caadr form))))))) - + (if (not (= line-number last-simplify-boolean-line-number)) (let ((val (simplify-boolean form () () env))) (set! last-simplify-boolean-line-number line-number) (if (not (equal? form val)) ; (not (and (> x 2) (not z))) -> (or (<= x 2) z) (lint-format "perhaps ~A" caller (lists->string form val)))))) - + (hash-special 'not sp-not)) - + ;; ---------------- and/or ---------------- (let () (define (sp-and caller head form env) @@ -7319,7 +7319,7 @@ (lint-format "one-armed if might cause confusion here: ~A" caller form))))) (hash-special 'and sp-and) (hash-special 'or sp-and)) - + ;; ---------------- = ---------------- (let () (define (any-real? lst) ; ignore 0.0 and 1.0 in this since they normally work @@ -7334,12 +7334,12 @@ (if (and (> len 2) (any-real? (cdr form))) (lint-format "= can be troublesome with floats: ~A" caller (truncated-list->string form))) - + (let ((cleared-form (cons = (remove-if (lambda (x) (not (number? x))) (cdr form))))) (if (and (> (length cleared-form) 2) (not (checked-eval cleared-form))) ; (= 1 y 2) (lint-format "this comparison can't be true: ~A" caller (truncated-list->string form)))) - + (when (= len 3) (let ((arg1 (cadr form)) (arg2 (caddr form))) @@ -7367,10 +7367,10 @@ (if var (if (or (eqv? arg1 0) ; (= (length x) 0) -> (null? x) (eqv? arg2 0)) - (lint-format "perhaps (assuming ~A is a list), ~A" caller var + (lint-format "perhaps (assuming ~A is a list), ~A" caller var (lists->string form (list 'null? var))) (if (symbol? var) ; (= (length x) 1) -> (and (pair? x) (null? (cdr x))) - (lint-format "perhaps (assuming ~A is a list), ~A" caller var + (lint-format "perhaps (assuming ~A is a list), ~A" caller var (lists->string form `(and (pair? ,var) (null? (cdr ,var))))))))))) (unrelop caller '= form)) (check-char-cmp caller '= form))) @@ -7384,19 +7384,19 @@ (set! made-suggestion old)))) (hash-special 'boolean=? sp-=->eq) (hash-special 'symbol=? sp-=->eq)) - + ;; ---------------- < > <= >= ---------------- (let () (define (sp-< caller head form env) (let ((len (length form))) (let ((cleared-form (cons head ; keep operator - (remove-if (lambda (x) - (not (number? x))) + (remove-if (lambda (x) + (not (number? x))) (cdr form))))) (if (and (> (length cleared-form) 2) (not (checked-eval cleared-form))) ; (< x 1 2 0 y) (lint-format "this comparison can't be true: ~A" caller (truncated-list->string form)))) - + (if (= len 3) (unrelop caller head form) (when (> len 3) @@ -7417,7 +7417,7 @@ (do ((last-arg (cadr form)) (new-args (list (cadr form))) (lst (cddr form) (cdr lst))) - ((null? lst) + ((null? lst) (if (repeated-member? new-args env) ; (<= x y x z x) -> (= x y z) (lint-format "perhaps ~A" caller (truncated-lists->string form (cons '= (lint-remove-duplicates (reverse new-args) env)))) (if (< (length new-args) (- len 1)) @@ -7427,9 +7427,9 @@ (unless (equal? (car lst) last-arg) (set! last-arg (car lst)) (set! new-args (cons last-arg new-args)))))))) - + (cond ((not (= len 3))) - + ((and (real? (cadr form)) (or (< (cadr form) 0) (and (zero? (cadr form)) @@ -7437,7 +7437,7 @@ (pair? (caddr form)) ; (> 0 (string-length x)) (hash-table-ref non-negative-ops (caaddr form))) (lint-format "~A can't be negative: ~A" caller (caaddr form) (truncated-list->string form))) - + ((and (real? (caddr form)) (or (< (caddr form) 0) (and (zero? (caddr form)) @@ -7445,7 +7445,7 @@ (pair? (cadr form)) ; (< (string-length x) 0) (hash-table-ref non-negative-ops (caadr form))) (lint-format "~A can't be negative: ~A" caller (caadr form) (truncated-list->string form))) - + ((and (pair? (cadr form)) (eq? (caadr form) 'length)) (let ((arg (cadadr form))) @@ -7512,7 +7512,7 @@ (if (memq head '(< <=)) "never" "always") head form)) - + ((and (memq head '(<= >=)) (or (and (eqv? (caddr form) 0) (pair? (cadr form)) ; (<= (string-length m) 0) -> (= (string-length m) 0) @@ -7522,7 +7522,7 @@ (hash-table-ref non-negative-ops (caaddr form))))) (lint-format "~A is never negative, so ~A" caller ((if (eqv? (caddr form) 0) caadr caaddr) form) - (lists->string form (or (not (eq? (eq? head '<=) + (lists->string form (or (not (eq? (eq? head '<=) (eqv? (caddr form) 0))) (cons '= (cdr form)))))) ((and (eqv? (caddr form) 256) @@ -7530,7 +7530,7 @@ (eq? (caadr form) 'char->integer)) (lint-format "perhaps ~A" caller (lists->string form (and (memq head '(< <=)) #t)))) - + ((or (and (eqv? (cadr form) 0) ; (> (numerator x) 0) -> (> x 0) (len>1? (caddr form)) (eq? (caaddr form) 'numerator)) @@ -7544,18 +7544,18 @@ (list head (cadadr form) (caddr form))))))) (check-char-cmp caller head form))) ;; could change (> x 0) to (positive? x) and so on, but the former is clear and ubiquitous - + (for-each (lambda (f) (hash-special f sp-<)) '(< > <= >=))) ; '= handled by sp-= above - + ;; ---------------- char< char> etc ---------------- (let () (define (sp-char< caller head form env) ;; only once: (char<=? #\0 c #\1) (let ((cleared-form (cons head ; keep operator - (remove-if (lambda (x) - (not (char? x))) + (remove-if (lambda (x) + (not (char? x))) (cdr form))))) (if (and (> (length cleared-form) 2) ; (char>? x #\a #\b y) (not (checked-eval cleared-form))) @@ -7567,7 +7567,7 @@ (and (char? (caddr form)) (char=? (caddr form) (other-case (caddr form)))))) (lint-format "char-ci=? could be char=? here: ~A" caller form) - + (when (and (eq? head 'char=?) ; (char=? #\a (char-downcase x)) -> (char-ci=? #\a x) (pair? (cdr form)) (let ((casef (let ((op #f)) @@ -7591,13 +7591,13 @@ (hash-special f sp-char<)) '(char<? char>? char<=? char>=? char=? char-ci<? char-ci>? char-ci<=? char-ci>=? char-ci=?))) - + ;; ---------------- string< string> etc ---------------- (let () (define (sp-string< caller head form env) (let ((cleared-form (cons head ; keep operator - (remove-if (lambda (x) - (not (string? x))) + (remove-if (lambda (x) + (not (string? x))) (cdr form))))) (if (and (> (length cleared-form) 2) ; (string>? "a" x "b" y) (not (checked-eval cleared-form))) @@ -7644,7 +7644,7 @@ new-args)))))) (when (and (eq? head 'string=?) - (= (length form) 3)) + (= (length form) 3)) (unless (string->char= caller form form) ; (string=? "x" (string y)) (string->char= caller (cons (car form) (reverse (cdr form))) form)) @@ -7657,7 +7657,7 @@ (for-each (lambda (f) (hash-special f sp-string<)) '(string<? string>? string<=? string>=? string=? string-ci<? string-ci>? string-ci<=? string-ci>=? string-ci=?))) - + ;; ---------------- length ---------------- (let () (define (sp-length caller head form env) @@ -7678,28 +7678,28 @@ (lint-format "perhaps ~A -> ~A" caller (truncated-list->string form) (max 0 (- (caddr arg-args) (cadr arg-args)))) (lint-format "perhaps ~A" caller (lists->string form (list '- (caddr arg-args) (cadr arg-args))))) (lint-format "perhaps ~A" caller (lists->string form (list '- (list 'length (car arg-args)) (cadr arg-args))))))) - + ((reverse reverse! list->vector list->string let->list) (lint-format "perhaps ~A" caller (lists->string form (list 'length (car arg-args))))) - + ((cons) ; (length (cons item items)) -> (+ (length items) 1) (if (pair? (cdr arg-args)) (lint-format "perhaps ~A" caller (lists->string form (list '+ (list 'length (cadr arg-args)) 1))))) - + ((make-list) ; (length (make-list 3)) -> 3 (lint-format "perhaps ~A" caller (lists->string form (car arg-args)))) - + ((append) ; (length (append x y)) -> (+ (length x) (length y)) (if (= (length arg) 3) (lint-format "perhaps ~A" caller (lists->string form `(+ (length ,(car arg-args)) (length ,(cadr arg-args))))))) - + ((quote) ; (length '(1 2 3)) -> 3 (if (list? (car arg-args)) (lint-format "perhaps ~A" caller (lists->string form (length (car arg-args))))))))))) - + ;; not pair cadr (if (code-constant? (cadr form)) ; (length 0) -> #f - (lint-format "perhaps ~A -> ~A" caller + (lint-format "perhaps ~A -> ~A" caller (truncated-list->string form) (length ((if (and (pair? (cadr form)) (eq? (caadr form) 'quote)) @@ -7732,11 +7732,11 @@ (let ((op '((zero? = zero?) (positive? > negative?) (negative? < positive?)))) (if (null? (cddr arg)) (list (caddr (assq head op)) (cadr arg)) - (list (cadr (assq head op)) (cadr arg) + (list (cadr (assq head op)) (cadr arg) (if (null? (cdddr arg)) (caddr arg) (cons '+ (cddr arg))))))))) - + ((abs magnitude) ; (zero? (abs x)) -> (zero? x) (if (eq? head 'zero?) (lint-format "perhaps ~A" caller (lists->string form (cons 'zero? (cdr arg)))))) @@ -7747,25 +7747,25 @@ ((numerator) ; (negative? (numerator x)) -> (negative? x) (lint-format "perhaps ~A" caller (lists->string form (list head (cadr arg))))) - + ((string-length) ; (zero? (string-length x)) -> (string=? x "") (if (eq? head 'zero?) (lint-format "perhaps ~A" caller (lists->string form (list 'string=? (cadr arg) ""))))) - + ((vector-length) ; (zero? (vector-length c)) -> (equal? c #()) (if (eq? head 'zero?) (lint-format "perhaps ~A" caller (lists->string form (list 'equal? (cadr arg) #()))))) - + ((length) ; (zero? (length routes)) -> (null? routes) (if (eq? head 'zero?) (lint-format "perhaps (assuming ~A is list) use null? instead of length: ~A" caller (cadr arg) (lists->string form (list 'null? (cadr arg)))))))))))))) - + ;; (zero? (logand...)) is nearly always preceded by not and handled elsewhere (for-each (lambda (f) (hash-special f sp-zero?)) '(zero? positive? negative?))) - + ;; ---------------- / ---------------- (let () (define (sp-/ caller head form env) @@ -7790,7 +7790,7 @@ (lint-format "~A will cause division by 0 if ~A is empty" caller len (cadr len))))))) (hash-special '/ sp-/)) - + ;; ---------------- copy ---------------- (let () (define (sp-copy caller head form env) @@ -7802,7 +7802,7 @@ (and (pair? (cadr form)) ; (copy (copy x)) -> (copy x) (memq (caadr form) '(copy string-copy)))) ; or any maker? (lint-format "~A could be ~A" caller (truncated-list->string form) (cadr form))) - + ((equal? (cadr form) '(owlet)) ; (copy (owlet)) -> (owlet) (lint-format "~A could be (owlet): owlet is copied internally" caller form)) @@ -7813,11 +7813,11 @@ (and (eqv? (cadddr form) 0) ; (copy x x 0) (null? (cddddr form))))) (lint-format "~A is a no-op" caller form)) - + ((= (length form) 5) (check-start-and-end caller 'copy (cdddr form) form env)))) (hash-special 'copy sp-copy)) - + ;; ---------------- string-copy ---------------- (let () (define (sp-string-copy caller head form env) @@ -7827,22 +7827,22 @@ string-append list->string symbol->string number->string))) (lint-format "~A could be ~A" caller (truncated-list->string form) (cadr form))))) (hash-special 'string-copy sp-string-copy)) - + ;; ---------------- string-down|upcase ---------------- (let () (define (sp-string-upcase caller head form env) (if (and (pair? (cdr form)) (string? (cadr form))) ; (string-downcase "SPEAK") -> "speak" - (lint-format "perhaps ~A" caller (lists->string form + (lint-format "perhaps ~A" caller (lists->string form ((if (eq? head 'string-upcase) string-upcase string-downcase) (cadr form)))))) (hash-special 'string-upcase sp-string-upcase) (hash-special 'string-downcase sp-string-upcase)) - + ;; ---------------- string ---------------- (let () (define (sp-string caller head form env) - (if (lint-every? (lambda (x) + (if (lint-every? (lambda (x) (and (char? x) (char<=? #\space x #\~))) ; #\0xx chars here look dumb (cdr form)) @@ -7854,8 +7854,8 @@ (let ((arg (cdadr form))) (if (and (len>1? arg) (integer? (cadr arg))) ; (string (string-ref x 0)) -> (substring x 0 1) - (lint-format "perhaps ~A" caller - (lists->string form + (lint-format "perhaps ~A" caller + (lists->string form (list 'substring (car arg) (cadr arg) (+ 1 (cadr arg)))))))) (if (and (memq (caadr form) '(char-upcase char-downcase)) (lint-every? (lambda (p) @@ -7868,7 +7868,7 @@ (string ,@(map cadr (cdr form))))))))))) ;; repeated args as in vector/list (sp-list below) got no hits (hash-special 'string sp-string)) - + ;; ---------------- string? ---------------- (let () (define (sp-string? caller head form env) @@ -7880,7 +7880,7 @@ (lint-format "number->string always returns a string, so ~A" caller (lists->string form #t))) (check-boolean-affinity caller form env))) (hash-special 'string? sp-string?)) - + ;; ---------------- number? ---------------- (let () (define (sp-number? caller head form env) @@ -7890,7 +7890,7 @@ (lint-format "string->number returns either #f or a number, so ~A" caller (lists->string form (cadr form))) (check-boolean-affinity caller form env))) (hash-special 'number? sp-number?)) - + ;; ---------------- exact? inexact? infinite? nan? ---------------- (let () (define (sp-exact? caller head form env) @@ -7900,7 +7900,7 @@ (for-each (lambda (f) (hash-special f sp-exact?)) '(exact? inexact? infinite? nan?))) - + ;; ---------------- symbol? etc ---------------- (let () (define (sp-symbol? caller head form env) @@ -7911,8 +7911,8 @@ char? boolean? float-vector? int-vector? vector? let? hash-table? input-port? byte? output-port? iterator? continuation? dilambda? procedure? macro? random-state? eof-object? c-pointer? syntax? undefined? unspecified?))) - - ;; ---------------- pair? list? ---------------- + + ;; ---------------- pair? list? ---------------- (let () (define (sp-pair? caller head form env) (check-boolean-affinity caller form env) @@ -7920,12 +7920,12 @@ (pair? (cadr form)) (memq (caadr form) '(memq memv member assq assv assoc signature))) (lint-format "~A returns either #f or a pair, so ~A" caller (caadr form) - (lists->string form (cadr form))))) + (lists->string form (cadr form))))) (for-each (lambda (f) (hash-special f sp-pair?)) '(pair? list?))) - - ;; ---------------- integer? ---------------- + + ;; ---------------- integer? ---------------- (let () (define (sp-integer? caller head form env) (check-boolean-affinity caller form env) @@ -7935,7 +7935,7 @@ (lint-format "~A returns either #f or an integer, so ~A" caller (caadr form) (lists->string form (cadr form))))) (hash-special 'integer? sp-integer?)) - + ;; ---------------- null? ---------------- (let () (define (sp-null? caller head form env) @@ -7946,7 +7946,7 @@ (lint-format "perhaps ~A" caller (lists->string form (list 'zero? (list 'length (cadadr form))))))) (hash-special 'null? sp-null?)) - + ;; ---------------- odd? even? ---------------- (let () (define (sp-odd? caller head form env) @@ -7958,8 +7958,8 @@ (int-arg (or (and (integer? arg1) arg1) (and (integer? arg2) arg2)))) (if int-arg - (lint-format "perhaps ~A" caller - (lists->string form + (lint-format "perhaps ~A" caller + (lists->string form (if (and (integer? arg1) (integer? arg2)) (eval/error caller form) @@ -7967,12 +7967,12 @@ (if (integer? arg1) arg2 arg1))))))))) (hash-special 'odd? sp-odd?) (hash-special 'even? sp-odd?)) - + ;; ---------------- string-ref ---------------- (let () (define (sp-string-ref caller head form env) (when (= (length form) 3) - + (if (equal? (cadr form) "") (lint-format "~A is an error" caller form) (when (just-code-constants? (cdr form)) ; (string-ref "abc" 0) -> #\a @@ -7981,39 +7981,39 @@ (let ((val (eval form))) (lint-format "perhaps ~A" caller (lists->string form val)))) (lambda args - (lint-format "~A: ~A" caller + (lint-format "~A: ~A" caller (object->string form) (apply format #f (cadr args))))))) - + (when (pair? (cadr form)) (let ((target (cadr form))) (case (car target) ((substring) ; (string-ref (substring x 1) 2) -> (string-ref x (+ 2 1)) (if (= (length target) 3) (lint-format "perhaps ~A" caller (lists->string form `(string-ref ,(cadr target) (+ ,(caddr form) ,(caddr target))))))) - + ((symbol->string) ; (string-ref (symbol->string 'abs) 1) -> #\b (if (and (integer? (caddr form)) (pair? (cadr target)) (eq? (caadr target) 'quote) (symbol? (cadadr target))) (lint-format "perhaps ~A" caller (lists->string form (string-ref (symbol->string (cadadr target)) (caddr form)))))) - + ((make-string) ; (string-ref (make-string 3 #\a) 1) -> #\a (if (and (integer? (cadr target)) (integer? (caddr form)) (> (cadr target) (caddr form))) (lint-format "perhaps ~A" caller (lists->string form (if (= (length target) 3) (caddr target) #\space)))))))))) - + (hash-special 'string-ref sp-string-ref)) - + ;; ---------------- vector-ref etc ---------------- (let () (define (sp-vector-ref caller head form env) (unless (= line-number last-checker-line-number) (when (= (length form) 3) (let ((seq (cadr form))) - + (when (code-constant? (cadr form)) (if (eqv? (length (cadr form)) 0) (lint-format "~A is an error" caller form) @@ -8028,11 +8028,11 @@ "'" "") (object->string val)))) (lambda args - (lint-format "~A: ~A" caller + (lint-format "~A: ~A" caller (object->string form) (apply format #f (cadr args)))))))) - (if (and (eq? head 'list-ref) ; (list-ref lst 0) -> car etc + (if (and (eq? head 'list-ref) ; (list-ref lst 0) -> car etc (memv (caddr form) '(0 1 2)) (not (and (pair? seq) (memq (car seq) '(cdr cddr cdddr))))) @@ -8046,17 +8046,17 @@ (caddr seq) (caddr form)) (cadr seq)) - (list (case (caddr form) + (list (case (caddr form) ((0) 'car) - ((1) 'cadr) + ((1) 'cadr) ((2) 'caddr)) seq)))) (when (pair? seq) (if (and (memq (car seq) '(vector-ref int-vector-ref float-vector-ref list-ref hash-table-ref let-ref)) (= (length seq) 3)) ; (vector-ref (vector-ref x i) j) -> (x i j) - (let ((seq1 (cadr seq))) ; x - (lint-format "perhaps ~A" caller - (lists->string form + (let ((seq1 (cadr seq))) ; x + (lint-format "perhaps ~A" caller + (lists->string form (if (and (pair? seq1) ; (vector-ref (vector-ref (vector-ref x i) j) k) -> (x i j k) (memq (car seq1) '(vector-ref int-vector-ref float-vector-ref list-ref hash-table-ref let-ref)) (= (length seq1) 3)) @@ -8064,7 +8064,7 @@ (list seq1 (caddr seq) (caddr form)))))) (if (memq (car seq) '(make-vector make-list vector list make-float-vector make-int-vector float-vector int-vector - make-hash-table hash-table + make-hash-table hash-table inlet)) (lint-format "this doesn't make much sense: ~A" caller form))) (when (eq? head 'list-ref) @@ -8092,7 +8092,7 @@ (for-each (lambda (f) (hash-special f sp-vector-ref)) '(vector-ref list-ref hash-table-ref let-ref int-vector-ref float-vector-ref))) - + ;; ---------------- vector-set! etc ---------------- (let () (define (sp-vector-set! caller head form env) @@ -8100,7 +8100,7 @@ (let ((target (cadr form)) (index (caddr form)) (val (cadddr form))) - + (cond ((and (len=3? val) ; (vector-set! x 0 (vector-ref x 0)) (eq? target (cadr val)) (equal? index (caddr val)) @@ -8115,34 +8115,34 @@ (integer? len) (>= index len)) (lint-format "index ~A is too large in ~A" caller index (truncated-list->string form))) - (else - (lint-format "~S is a constant, so ~A is problematic, and ~S is discarded; perhaps ~A" caller + (else + (lint-format "~S is a constant, so ~A is problematic, and ~S is discarded; perhaps ~A" caller target head target (lists->string form val)))))) ((not (pair? target))) - + ((and (not (memq head '(string-set! hash-table-set! let-set!))) ; (vector-set! (vector-ref x 0) 1 2) -- vector within vector (memq (car target) '(vector-ref list-ref float-vector-ref int-vector-ref))) (lint-format "perhaps ~A" caller (lists->string form `(set! (,@(cdr target) ,index) ,val)))) - + ((and (not (eq? head 'string-set!)) ; (hash-table-set! (vector-ref x 0) 'a 2) -> (set! ((x 0) 'a) 2) (memq (car target) '(vector-ref list-ref))) (lint-format "perhaps ~A" caller (lists->string form `(set! ((,@(cdr target)) ,index) ,val)))) - - ((memq (car target) '(make-vector vector make-string string make-list list append cons + + ((memq (car target) '(make-vector vector make-string string make-list list append cons vector-append inlet sublet copy vector-copy string-copy list-copy int-vector float-vector byte-vector string-append make-byte-vector - make-int-vector make-float-vector make-hash-table hash-table + make-int-vector make-float-vector make-hash-table hash-table )) ;list-copy is from r7rs (lint-format "~A is simply discarded; perhaps ~A" caller (truncated-list->string target) ; (vector-set! (make-vector 3) 1 1) -- does this ever happen? (lists->string form val))) - + ((and (eq? head 'list-set!) (memq (car target) '(cdr cddr cdddr cddddr)) (integer? (caddr form))) ; (list-set! (cdr x) 0 y) -> (list-set! x 1 y) - (lint-format "perhaps ~A" caller - (lists->string form + (lint-format "perhaps ~A" caller + (lists->string form `(list-set! ,(cadr target) ,(+ (caddr form) (cdr-count (car target))) ,(cadddr form))))))))) (for-each (lambda (f) (hash-special f sp-vector-set!)) @@ -8171,7 +8171,7 @@ (null? (cdadr dims)) (eqv? (caadr dims) (- end start))) (lint-format "perhaps ~A" caller (lists->string form `(subvector ,(cadr form) ,start ,end))))))))))) - + (hash-special 'subvector sp-subvector)) ;; ---------------- object->string ---------------- @@ -8186,14 +8186,14 @@ (if (and (code-constant? arg2) ; (object->string x :else) (not (memq arg2 '(#f #t :readable)))) ; #f and #t are display|write choice, :readable = ~W (lint-format "bad second argument: ~A" caller arg2))))))) - + (hash-special 'object->string sp-object->string)) - + (define (all-caps-warning arg) (and (string? arg) (or (string-position "ERROR" arg) (string-position "WARN" arg)))) - + ;; ---------------- display ---------------- (let () (define (sp-display caller head form env) @@ -8204,28 +8204,28 @@ ()))) (cond ((all-caps-warning arg) (lint-format "There's no need to shout: ~A" caller (truncated-list->string form))) - + ((not port) (lint-format "~A could be ~A" caller form (cadr form))) ((not (len>1? arg))) - + ((and (eq? (car arg) 'format) ; (display (format #f str x)) -> (format () str x) (not (cadr arg))) (lint-format "perhaps ~A" caller (lists->string form (cons 'format (cons port (cddr arg)))))) - + ((and (eq? (car arg) 'apply) ; (display (apply format #f str x) p) -> (apply format p str x) (eq? (cadr arg) 'format) (pair? (cddr arg)) (not (caddr arg))) (lint-format "perhaps ~A" caller (lists->string form `(apply format ,port ,@(cdddr arg))))) - + ((and (pair? port) (eq? (car port) 'current-output-port)) (lint-format "(current-output-port) is the default port for display: ~A" caller form)))))) - + (hash-special 'display sp-display)) - + ;; ---------------- flush-output-port, newline, close-output-port ---------------- (let () (define (sp-flush-output-port caller head form env) @@ -8238,7 +8238,7 @@ (hash-special 'flush-output-port sp-flush-output-port) (hash-special 'close-output-port sp-flush-output-port) (hash-special 'newline sp-flush-output-port)) - + ;; ---------------- write-char, write-byte, write ---------------- (let () (define (sp-write-char caller head form env) @@ -8260,11 +8260,11 @@ (if (and (len>1? (cadr form)) (eq? (caadr form) 'integer->char)) (lint-format "perhaps ~A" caller (lists->string form (cons 'write-byte (cons (cadadr form) (cddr form))))))))))) - + (hash-special 'write-char sp-write-char) (hash-special 'write-byte sp-write-char) (hash-special 'write sp-write-char)) - + ;; ---------------- read, port-filename, port-line-number, read-char, read-byte ---------------- (let () (define (sp-read caller head form env) @@ -8279,7 +8279,7 @@ (for-each (lambda (c) (hash-special c sp-read)) '(read port-filename port-line-number read-char read-byte peek-char close-input-port))) - + ;; ---------------- char-alphabetic? char-lower-case? char-numeric? char-upper-case? char-whitespace? etc ---------------- (let () (define (sp-char-numeric caller head form env) @@ -8290,14 +8290,14 @@ (for-each (lambda (c) (hash-special c sp-char-numeric)) '(char-alphabetic? char-lower-case? char-numeric? char-upper-case? char-whitespace? char-upcase char-downcase))) - + ;; ---------------- make-vector etc ---------------- (let () (define (sp-make-vector caller head form env) ;; type of initial value (for make-float|int-vector) is checked elsewhere (when (>= (length form) 3) (case (caddr form) - ((#<unspecified>) + ((#<unspecified>) (if (eq? head 'make-vector) ; (make-vector 3 #<unspecified>) (lint-format "#<unspecified> is the default initial value in ~A" caller form))) ((0) @@ -8311,7 +8311,7 @@ (let ((typer (cadddr form))) (unless (memq typer setters) (lint-format "~A is not a built-in type" caller (cadddr form)))))) - + (when (and (pair? (cdr form)) (integer? (cadr form)) (zero? (cadr form))) @@ -8322,7 +8322,7 @@ (for-each (lambda (f) (hash-special f sp-make-vector)) '(make-vector make-int-vector make-float-vector))) - + ;; ---------------- make-string make-byte-vector ---------------- (let () (define (sp-make-string caller head form env) @@ -8335,7 +8335,7 @@ (for-each (lambda (f) (hash-special f sp-make-string)) '(make-string make-byte-vector))) - + ;; ---------------- make-list ---------------- (let () (define (sp-make-list caller head form env) @@ -8346,7 +8346,7 @@ (lint-format "initial value is pointless here: ~A" caller form)) (lint-format "perhaps ~A" caller (lists->string form ())))) (hash-special 'make-list sp-make-list)) - + ;; ---------------- reverse string->list etc ---------------- (let () (define (sp-reverse caller head form env) @@ -8362,10 +8362,10 @@ (if (symbol? seq) (object->string seq :readable) (object->string seq)))))) - + (when (len>1? (cadr form)) - (let ((inverses '((reverse . reverse) - (reverse! . reverse!) + (let ((inverses '((reverse . reverse) + (reverse! . reverse!) ;; reverse and reverse! are not completely interchangable: ;; (reverse (cons 1 2)): (2 . 1) ;; (reverse! (cons 1 2)): error: reverse! argument, (1 . 2), is a pair but should be a proper list @@ -8382,28 +8382,28 @@ (arg-of-arg (cadadr form)) (func-of-arg (caadr form))) (if (pair? inv-op) (set! inv-op (cdr inv-op))) - + (cond ((eq? func-of-arg inv-op) ; (vector->list (list->vector x)) -> x (if (eq? head 'string->symbol) (lint-format "perhaps ~A" caller (lists->string form arg-of-arg)) (lint-format "~A could be (copy ~S)" caller form arg-of-arg))) - + ((and (eq? head 'list->string) ; (list->string (vector->list x)) -> (copy x (make-string (length x))) (eq? func-of-arg 'vector->list)) (lint-format "perhaps ~A" caller (lists->string form `(copy ,arg-of-arg (make-string (length ,arg-of-arg)))))) - + ((and (eq? head 'list->string) ; (list->string (make-list x y)) -> (make-string x y) (eq? func-of-arg 'make-list)) (lint-format "perhaps ~A" caller (lists->string form (cons 'make-string arg-args)))) - + ((and (eq? head 'string->list) ; (string->list (string x y)) -> (list x y) (eq? func-of-arg 'string)) (lint-format "perhaps ~A" caller (lists->string form (cons 'list arg-args)))) - + ((and (eq? head 'list->vector) ; (list->vector (make-list ...)) -> (make-vector ...) (eq? func-of-arg 'make-list)) (lint-format "perhaps ~A" caller (lists->string form (cons 'make-vector arg-args)))) - + ((and (eq? head 'list->vector) ; (list->vector (string->list x)) -> (copy x (make-vector (length x))) (eq? func-of-arg 'string->list)) (lint-format "perhaps ~A" caller (lists->string form `(copy ,arg-of-arg (make-vector (length ,arg-of-arg)))))) @@ -8416,27 +8416,27 @@ (cdadr form))) (lint-format "perhaps ~A" caller (lists->string form (cons 'append (map cadr (cdadr form)))))) - + ((and (eq? head 'vector->list) ; (vector->list (make-vector ...)) -> (make-list ...) (eq? func-of-arg 'make-vector)) (lint-format "perhaps ~A" caller (lists->string form (cons 'make-list arg-args)))) - + ((and (eq? head 'vector->list) ; (vector->list (vector ...)) -> (list ...) (eq? func-of-arg 'vector)) (lint-format "perhaps ~A" caller (lists->string form (cons 'list arg-args)))) - + ((and (eq? head 'vector->list) ; (vector->list (vector-copy ...)) -> (vector->list ...) (eq? func-of-arg 'vector-copy)) (lint-format "perhaps ~A" caller (lists->string form (cons 'vector->list arg-args)))) - + ((and (memq func-of-arg '(reverse reverse! copy)) (len>1? arg-of-arg) ; (list->string (reverse (string->list x))) -> (reverse x) (eq? (car arg-of-arg) inv-op)) (lint-format "perhaps ~A" caller (lists->string form (list (if (eq? func-of-arg 'reverse!) 'reverse func-of-arg) (cadr arg-of-arg))))) - + ((and (memq head '(reverse reverse!)) ; (reverse (string->list x)) -> (string->list (reverse x)) -- often redundant (memq func-of-arg '(string->list vector->list sort!))) - (cond ((not (eq? func-of-arg 'sort!)) + (cond ((not (eq? func-of-arg 'sort!)) (if (null? (cdr arg-args)) (lint-format "perhaps less consing: ~A" caller (lists->string form (list func-of-arg (list 'reverse arg-of-arg)))))) @@ -8444,7 +8444,7 @@ (hash-table-ref reversibles (cadr arg-args))) => (lambda (op) (lint-format "possibly ~A" caller (lists->string form (list 'sort! arg-of-arg op))))))) - + ((and (len>1? arg-of-arg) (or (memq func-of-arg '(cdr cddr cdddr cddddr)) (and (eq? func-of-arg 'list-tail) @@ -8460,19 +8460,19 @@ (lists->string form (if (eq? head 'list->string) (list 'substring (cadr arg-of-arg) len-diff) `(copy ,(cadr arg-of-arg) (make-vector (- (length ,(cadr arg-of-arg)) ,len-diff)))))))) - + ((and (memq head '(list->vector list->string)) (eq? func-of-arg 'sort!) ; (list->vector (sort! (vector->list x) y)) -> (sort! x y) (len>1? arg-of-arg) (len>1? arg-args) (eq? (car arg-of-arg) (if (eq? head 'list->vector) 'vector->list 'string->list))) (lint-format "perhaps ~A" caller (lists->string form (list 'sort! (cadr arg-of-arg) (cadr arg-args))))) - + ((and (memq head '(list->vector list->string)) (or (memq func-of-arg '(list cons)) (quoted-undotted-pair? arg))) (let ((maker (if (eq? head 'list->vector) 'vector 'string))) - (case func-of-arg + (case func-of-arg ((list) (if (var-member maker env) ; (list->string (list x y z)) -> (string x y z) (lint-format "~A could be simplified, but you've shadowed '~A" caller (truncated-list->string form) maker) @@ -8484,17 +8484,17 @@ (if (var-member maker env) ; (list->string (cons x ())) -> (string x) (lint-format "~A could be simplified, but you've shadowed '~A" caller (truncated-list->string form) maker) (lint-format "perhaps ~A" caller (lists->string form (list maker arg-of-arg))))))))) - + ((and (memq head '(list->string list->vector)) ; (list->string (reverse x)) -> (reverse (apply string x)) (memq func-of-arg '(reverse reverse!))) (lint-format "perhaps ~A" caller (lists->string form (list 'reverse (list head arg-of-arg))))) - + ((and (eq? head 'string->symbol) ; (string->symbol (string-append...)) -> (symbol ...) (or (memq func-of-arg '(string-append append)) (and (eq? func-of-arg 'apply) (memq arg-of-arg '(string-append append))))) (lint-format "perhaps ~A" caller - (lists->string form + (lists->string form (if (eq? func-of-arg 'apply) (cons 'apply (cons 'symbol (cdr arg-args))) (cons 'symbol arg-args))))) @@ -8519,21 +8519,21 @@ ((reverse!) (eq? func-of-arg 'reverse)) (else #f)) (lint-format "~A could be (copy ~S)" caller form arg-of-arg)) - + ((and (len>1? arg-of-arg) ; (op (reverse (inv-op x))) -> (reverse x) (eq? func-of-arg 'reverse) (eq? inv-op (car arg-of-arg))) (lint-format "perhaps ~A" caller (lists->string form (list 'reverse (cadr arg-of-arg))))))))) - + (when (pair? (cddr form)) ; (string->list x y y) is () (when (and (memq head '(vector->list string->list)) (pair? (cdddr form))) (check-start-and-end caller head (cddr form) form env)) - + (when (and (eq? head 'number->string) ; (number->string saturation 10) (eqv? (caddr form) 10)) (lint-format "10 is the default radix for number->string: ~A" caller (truncated-list->string form)))) - + (when (memq head '(reverse reverse!)) (if (eq? head 'reverse!) (if (symbol? (cadr form)) @@ -8541,11 +8541,11 @@ (if (and v (eq? (var-definer v) 'parameter)) (lint-format "if ~A (a function argument) is a pair, ~A is ill-advised" caller - (cadr form) + (cadr form) (truncated-list->string form)))) (if (code-constant? (cadr form)) (lint-format "~A is a constant, so ~A is problematic" caller - (cadr form) + (cadr form) (truncated-list->string form))))) (when (pair? (cadr form)) @@ -8562,15 +8562,15 @@ (memq (car arg-arg) '(reverse reverse!)) (pair? (cdr arg-arg)) (symbol? (cadr arg-arg))) - (lint-format "perhaps ~A" caller - (lists->string form `(copy ,(cadr arg-arg) + (lint-format "perhaps ~A" caller + (lists->string form `(copy ,(cadr arg-arg) (make-list (- (length ,(cadr arg-arg)) ,(if (eq? arg-op 'cdr) 1 (cadr arg-args)))))))) - + (if (and (eq? arg-op 'append) ; (reverse (append (reverse b) res)) = (append (reverse res) b) (eq? (car arg-arg) 'reverse) (len=1? (cdr arg-args))) (lint-format "perhaps ~A" caller (lists->string form `(append (reverse ,(cadr arg-args)) ,(cadr arg-arg)))))) - + (when (and (= (length arg) 3) (pair? (cadr arg-args))) (cond ((and (eq? arg-op 'map) ; (reverse (map abs (sort! x <))) -> (map abs (sort! x >)) @@ -8580,16 +8580,16 @@ => (lambda (op) (lint-format "possibly ~A" caller (lists->string form `(,arg-op ,arg-arg (sort! ,(cadadr arg-args) ,op))))))) ;; (reverse (apply vector (sort! x <))) doesn't happen (nor does this map case, but it's too pretty to leave out) - + (if (and (eq? arg-op 'cons) ; (reverse (cons x (reverse lst))) -- adds x to end -- (append lst (list x)) (memq (caadr arg-args) '(reverse reverse!)) (len=1? (cdadr arg-args))) (lint-format "perhaps ~A" caller (lists->string form `(append ,(cadadr arg-args) (list ,arg-arg))))))))))) - + (for-each (lambda (f) (hash-special f sp-reverse)) '(reverse reverse! list->vector vector->list list->string string->list symbol->string string->symbol number->string))) - + ;; ---------------- char->integer string->number etc ---------------- (let () (define (sp-char->integer caller head form env) @@ -8620,7 +8620,7 @@ (if (and (pair? arg) (memq (car arg) '(read read-char))) (lint-format "perhaps ~A" caller (lists->string form (cons 'read-byte (cdr arg)))))) - + ((string->number) (if (and (pair? (cddr form)) (integer? (caddr form)) ; type error is checked elsewhere @@ -8631,25 +8631,25 @@ (null? (cddr form))) ; (string->number (string num-char)) -> (- (char->integer num-char) (char->integer #\0)) (lint-format "perhaps ~A" caller (lists->string form `(- (char->integer ,(cadr arg)) (char->integer #\0))))))) - + ((symbol->keyword) (if (and (len>1? arg) ; (symbol->keyword (string->symbol x)) -> (string->keyword x) (eq? (car arg) 'string->symbol)) (lint-format "perhaps ~A" caller (lists->string form (list 'string->keyword (cadr arg)))) (if (quoted-symbol? arg) (lint-format "perhaps ~A" caller (lists->string form (symbol->keyword (cadr arg))))))) - + ((keyword->symbol) (if (and (len>1? arg) (eq? (car arg) 'string->keyword)) (lint-format "perhaps ~A" caller (lists->string form (list 'string->symbol (cadr arg)))) (if (keyword? arg) (lint-format "perhaps ~A -> '~A" caller (object->string form) (object->string (keyword->symbol arg))))))))))) - + (for-each (lambda (f) (hash-special f sp-char->integer)) '(char->integer integer->char symbol->keyword keyword->symbol string->number))) - + ;; ---------------- symbol ---------------- (let () (define (sp-symbol caller head form env) @@ -8672,7 +8672,7 @@ (and (eq? (caadr form) 'apply) (memq (cadadr form) '(string-append append))))) (lint-format "perhaps ~A" caller - (lists->string form + (lists->string form (if (eq? (caadr form) 'apply) (cons 'apply (cons 'symbol (cddadr form))) (cons 'symbol (cdadr form)))))))) @@ -8712,10 +8712,10 @@ (eq? (car arg) 'apply) ; unfortunately the values version is only slightly faster (eq? (cadr arg) 'string-append)) (set! nargs (cons (list 'apply 'values (caddr arg)) nargs))) - + ((not (pair? (cdr p))) (set! nargs (cons arg nargs))) - + ((and (pair? arg) (eq? (car arg) 'string) (pair? (cadr p)) @@ -8723,28 +8723,28 @@ (set! nargs (cons (cons 'string (append (cdr arg) (cdadr p))) nargs)) (set! combined #t) (set! p (cdr p))) - + ((and (string? arg) (string? (cadr p))) (set! nargs (cons (string-append arg (cadr p)) nargs)) (set! combined #t) (set! p (cdr p))) - + (else (set! nargs (cons (car p) nargs))))))) - + ;; (if ... "" ...) as arg split out got a couple dozen hits but we still need copy for the "" branch, so it's not much better - + (cond ((null? args) ; (string-append) -> "" (lint-format "perhaps ~A" caller (lists->string form ""))) - + ((null? (cdr args)) ; (string-append a) -> a (if (not (tree-memq 'values (cdr form))) (lint-format "perhaps ~A~A" caller (lists->string form (car args)) (if combined "" ", or use copy")))) ; (string-append x "") appears to be a common substitute for string-copy - + ((lint-every? string? args) ; (string-append "a" "b") -> "ab" (lint-format "perhaps ~A" caller (lists->string form (apply string-append args)))) - + ((lint-every? (lambda (a) ; (string-append "a" (string #\b)) -> "ab" (or (string? a) (and (pair? a) @@ -8759,7 +8759,7 @@ (eval (cons 'string-append args))))) (lint-format "perhaps ~A -> ~S" caller (truncated-list->string form) val))) (lambda args #f))) - + ((lint-every? (lambda (c) ; (string-append (make-string 3 #\a) (make-string 2 #\b)) -> (format #f "~NC~NC" 3 #\a 2 #\b) (and (len>2? c) (eq? (car c) 'make-string))) @@ -8768,12 +8768,12 @@ (lists->string form `(format #f ,(apply string-append (make-list (abs (length (cdr form))) "~NC")) ,@(map (lambda (c) (values (cadr c) (caddr c))) (cdr form)))))) - + ((not (equal? args (cdr form))) ; (string-append x (string-append y z)) -> (string-append x y z) (lint-format "perhaps ~A" caller (lists->string form (cons 'string-append args))))) (set! last-checker-line-number line-number)))) (hash-special 'string-append sp-string-append)) - + ;; ---------------- vector-append ---------------- (let () (define (sp-vector-append caller head form env) @@ -8787,18 +8787,18 @@ (remove-all #() (splice-if 'vector-append (cdr form)))))) (cond ((null? args) ; (vector-append) -> #() (lint-format "perhaps ~A" caller (lists->string form #()))) - + ((null? (cdr args)) ; (vector-append x) -> (copy x) (lint-format "perhaps ~A" caller (lists->string form (list 'copy (car args))))) - + ((lint-every? vector? args) ; (vector-append #(1 2) (vector-append #(3))) -> #(1 2 3) (lint-format "perhaps ~A" caller (lists->string form (apply vector-append args)))) - + ((not (equal? args (cdr form))) ; (vector-append x (vector-append y z)) -> (vector-append x y z) (lint-format "perhaps ~A" caller (lists->string form (cons 'vector-append args))))) (set! last-checker-line-number line-number)))) (hash-special 'vector-append sp-vector-append)) - + ;; ---------------- cons ---------------- (let () (define (sp-cons caller head form env) @@ -8806,32 +8806,32 @@ (not (= last-cons-line-number line-number))) (if (any-null? (caddr form)) ; (cons x '()) -> (list x) (lint-format "perhaps ~A" caller (lists->string form (list 'list (cadr form)))) - + (when (pair? (caddr form)) (let ((op (caaddr form))) - + (cond ((or (eq? op 'list) ; (cons x (list ...)) -> (list x ...) (and (eq? op 'list-values) (not (tree-memq 'apply-values (cdaddr form))))) (lint-format "perhaps ~A" caller (lists->string form (cons 'list (cons (cadr form) (unlist-values (cdaddr form))))))) - + ((and (pair? (cadr form)) ; (cons (car x) (cdr x)) -> (copy x) (let ((x (assq (caadr form) ; but if cdr is a pair, copy is more expensive and slightly different - '((car cdr #t) + '((car cdr #t) (caar cdar car) (cadr cddr cdr) (caaar cdaar caar) (caadr cdadr cadr) (caddr cdddr cddr) (cadar cddar cdar) (cadddr cddddr cdddr) (caaaar cdaaar caaar) (caaadr cdaadr caadr) (caadar cdadar cadar) (caaddr cdaddr caddr) (cadaar cddaar cdaar) (cadadr cddadr cdadr) (caddar cdddar cddar))))) - (and x + (and x (eq? (cadr x) op) (caddr x)))) => (lambda (cfunc) (if (and cfunc (equal? (cadadr form) (cadr (caddr form))) (not (side-effect? (cadadr form) env))) - (lint-format "possibly ~A" caller - (lists->string form - (list 'copy + (lint-format "possibly ~A" caller + (lists->string form + (list 'copy (if (symbol? cfunc) (list cfunc (cadadr form)) (cadadr form)))))))) @@ -8843,8 +8843,8 @@ (if (pair? chain) (if (eq? (car chain) 'list) (begin - (lint-format "perhaps ~A" caller - (lists->string form + (lint-format "perhaps ~A" caller + (lists->string form (cons 'list (append (reverse args) (cdr chain))))) (set! last-cons-line-number line-number)) (if (and (eq? (car chain) 'cons) @@ -8856,21 +8856,21 @@ (if (and (pair? (caddr chain)) (memq (caaddr chain) '(cons list))) (loop (cons (cadr chain) args) (caddr chain))))))))) - + ((else) (lint-format "else (as car of second argument to cons) makes no sense: ~A" caller form)))))))))) - + (hash-special 'cons sp-cons)) - + ;; ---------------- append ---------------- (let () (define (append->list . items) (let ((lst (list 'list))) - (for-each + (for-each (lambda (item) (set! lst (append lst (if (eq? (car item) 'list) (cdr item) - ((if (eq? (car item) 'cons) list distribute-quote) + ((if (eq? (car item) 'cons) list distribute-quote) (cadr item)))))) items) lst)) @@ -8884,17 +8884,17 @@ ((2) (let ((arg2 (cadr args)) (arg1 (car args))) - (cond ((or (any-null? arg2) + (cond ((or (any-null? arg2) (equal? arg2 '(list))) (list 'copy arg1)) - + ((null? arg1) arg2) - + ((not (pair? arg1)) form) - - ((and (pair? arg2) + + ((and (pair? arg2) (or (eq? (car arg1) 'list) (and (eq? (car arg1) 'cons) (any-null? (caddr arg1))) @@ -8905,31 +8905,31 @@ (any-null? (caddr arg2))) (quoted-undotted-pair? arg2))) (apply append->list args)) - + ((and (eq? (car arg1) 'list) (len=1? (cdr arg1))) (list 'cons (cadr arg1) arg2)) - + ((eq? (car arg1) 'cons) (if (any-null? (caddr arg1)) (list 'cons (cadr arg1) arg2) (let ((cargs `(append ,(caddr arg1) ,arg2))) `(cons ,(cadr arg1) ,cargs)))) - + ((and (eq? (car arg1) 'list) (len=2? (cdr arg1))) `(cons ,(cadr arg1) (cons ,(caddr arg1) ,arg2))) - + ((and (quoted-pair? arg1) (null? (cdadr arg1))) (if (or (symbol? (caadr arg1)) (pair? (caadr arg1))) `(cons ',(caadr arg1) ,arg2) (list 'cons (caadr arg1) arg2))) - + ((not (equal? (cdr form) args)) (cons 'append args)) - + (else form)))) (else @@ -8942,27 +8942,27 @@ (quoted-undotted-pair? item)))) args) (apply append->list args)) - + ((and (len=2? (car args)) (eq? (caar args) 'list)) (let ((cargs (transform-append `(append ,@(cdr args))))) `(cons ,(cadar args) ,cargs))) - + ((and (pair? (car args)) (eq? (caar args) 'cons)) (let ((cargs `(append ,(caddar args) ,@(cdr args)))) `(cons ,(cadar args) ,cargs))) - + ((let ((n-1 (list-ref args (- len1 2)))) (and (len=2? n-1) (eq? (car n-1) 'list))) `(append ,@(copy args (make-list (- len1 2))) - (cons ,(cadr (list-ref args (- len1 2))) + (cons ,(cadr (list-ref args (- len1 2))) ,(list-ref args (- len1 1))))) - + ((not (equal? (cdr form) args)) (cons 'append args)) - + (else form)))))) (define (sp-append caller head form env) @@ -8971,56 +8971,56 @@ (letrec ((splice-append (lambda (lst) (cond ((null? lst) ()) - + ((not (pair? lst)) lst) - + ((and (pair? (car lst)) (eq? (caar lst) 'append) (proper-list? (cdar lst))) ; for append below (if (null? (cdar lst)) ; (append) at end -> () to keep copy intact? (case (cdr lst) ((()) => list) (else => splice-append)) - (append (splice-append (cdar lst)) + (append (splice-append (cdar lst)) (splice-append (cdr lst))))) - + ((and (len=2? (car lst)) (eq? (caar lst) 'copy) (pair? (cdr lst))) (cons (cadar lst) (splice-append (cdr lst)))) - + ((and (len=3? (car lst)) ; (append (apply append x)...) -> (append (apply values x)...) (eq? (caar lst) 'apply) (memq (cadar lst) '(append string-append vector-append))) - (cons (list 'apply 'values (caddar lst)) + (cons (list 'apply 'values (caddar lst)) (splice-append (cdr lst)))) - + ((or (null? (cdr lst)) (not (or (any-null? (car lst)) (and (len=1? (car lst)) (eq? (caar lst) 'list))))) - (cons (car lst) + (cons (car lst) (splice-append (cdr lst)))) - + (else (splice-append (cdr lst))))))) - + (let ((new-args (splice-append (cdr form)))) ; (append '(1) (append '(2) '(3))) -> (append '(1) '(2) '(3)) (let ((len1 (length new-args)) (suggestion made-suggestion)) - + (when (and (> len1 2) (null? (list-ref new-args (- len1 1))) (pair? (list-ref new-args (- len1 2))) (memq (car (list-ref new-args (- len1 2))) '(list cons append map string->list vector->list make-list))) (set-cdr! (list-tail new-args (- len1 2)) ()) (set! len1 (- len1 1))) - + (if (positive? len1) (let ((last (list-ref new-args (- len1 1)))) ;; (define (f) (append '(1) '(2))) (define a (f)) (set! (a 1) 32) (f) -> '(1 32) (if (quoted-pair? last) - (lint-format "append does not copy its last argument, so ~A is dangerous" caller + (lint-format "append does not copy its last argument, so ~A is dangerous" caller (truncated-list->string form))))) - + (case len1 ((0) ; (append) -> () (lint-format "perhaps ~A" caller (lists->string form ()))) @@ -9030,15 +9030,15 @@ (let ((arg2 (cadr new-args)) (arg1 (car new-args))) - (cond ((or (any-null? arg2) + (cond ((or (any-null? arg2) (member arg2 '((list) "" (string) #() (vector)))) ; (append '(1 2) ()) -> (copy '(1 2)), #() includes #i() et al (lint-format "perhaps clearer: ~A" caller (lists->string form (list 'copy arg1)))) - + ((null? arg1) ; (append () x) -> x (lint-format "perhaps ~A" caller (lists->string form arg2))) - + ((not (pair? arg1))) - + ((and (pair? arg2) ; (append (list x y) '(z)) -> (list x y z) or extensions thereof (or (eq? (car arg1) 'list) (and (eq? (car arg1) 'cons) @@ -9050,42 +9050,42 @@ (any-null? (caddr arg2))) (quoted-undotted-pair? arg2))) (lint-format "perhaps ~A" caller (lists->string form (apply append->list new-args)))) - + ((and (eq? (car arg1) 'list) ; (append (list x) y) -> (cons x y) (len=1? (cdr arg1))) (lint-format "perhaps ~A" caller (lists->string form (list 'cons (cadr arg1) arg2)))) - + ((eq? (car arg1) 'cons) ; (append (cons x y) z) -> (cons x z) or (cons z (append y z)) (lint-format "perhaps ~A" caller ; append insists on proper lists, so this should be equivalent - (lists->string form + (lists->string form (if (any-null? (caddr arg1)) (list 'cons (cadr arg1) arg2) `(cons ,(cadr arg1) (append ,(caddr arg1) ,arg2)))))) - + ((and (eq? (car arg1) 'list) ; (append (list x y) z) -> (cons x (cons y z)) (len=2? (cdr arg1))) (lint-format "perhaps ~A" caller (lists->string form `(cons ,(cadr arg1) (cons ,(caddr arg1) ,arg2))))) - + ;; not sure about this: reports the un-qq'd form ((and (eq? (car arg1) 'list-values) (not (qq-tree? arg1))) (set! last-checker-line-number -1) (sp-append caller 'append (list 'append (unlist-values arg1) arg2) env)) - + ((and (eq? (car arg1) 'vector->list) (pair? arg2) (eq? (car arg2) 'vector->list)) (lint-format "perhaps ~A" caller (lists->string form (list 'vector->list (list 'append (cadr arg1) (cadr arg2)))))) - + ((and (quoted-pair? arg1) ; (append '(x) y) -> (cons 'x y) (null? (cdadr arg1))) - (lint-format "perhaps ~A" caller + (lint-format "perhaps ~A" caller (lists->string form (if (or (symbol? (caadr arg1)) (pair? (caadr arg1))) `(cons ',(caadr arg1) ,arg2) (list 'cons (caadr arg1) arg2))))) - + ((not (equal? (cdr form) new-args)) ; (append () '(1 2) 1) -> (append '(1 2) 1) (lint-format "perhaps ~A" caller (lists->string form (cons 'append new-args))))))) (else @@ -9098,7 +9098,7 @@ (quoted-undotted-pair? item)))) new-args) ; (append '(1) (append '(2) '(3)) '(4)) -> (list 1 2 3 4) (lint-format "perhaps ~A" caller (lists->string form (apply append->list new-args)))) - + ((and (len=2? (car new-args)) ; (append (list x) y (list z)) -> (cons x (append y (list z)))? (eq? (caar new-args) 'list)) (let ((cargs (transform-append `(append ,@(cdr new-args))))) @@ -9107,26 +9107,26 @@ ((and (pair? (car new-args)) (eq? (caar new-args) 'cons)) (let ((cargs (transform-append `(append ,(caddar new-args) ,@(cdr new-args))))) - (lint-format "perhaps ~A" caller + (lint-format "perhaps ~A" caller (lists->string form `(cons ,(cadar new-args) ,cargs))))) - + ((let ((n-1 (list-ref new-args (- len1 2)))) (and (len=2? n-1) (eq? (car n-1) 'list))) ; (append x (list y) z) -> (append x (cons y z)) - (lint-format "perhaps ~A" caller - (lists->string form + (lint-format "perhaps ~A" caller + (lists->string form `(append ,@(copy new-args (make-list (- len1 2))) - (cons ,(cadr (list-ref new-args (- len1 2))) + (cons ,(cadr (list-ref new-args (- len1 2))) ,(list-ref new-args (- len1 1))))))) - + ((not (equal? (cdr form) new-args)) ; (append x y (append)) -> (append x y ()) (lint-format "perhaps ~A" caller (lists->string form (cons 'append new-args))))))) - + (if (and (= made-suggestion suggestion) (not (equal? (cdr form) new-args))) (lint-format "perhaps ~A" caller (lists->string form (cons 'append new-args))))))))) (hash-special 'append sp-append)) - + ;; ---------------- apply ---------------- (let () (define (sp-apply caller head form env) @@ -9143,7 +9143,7 @@ (unless (or (<= len 2) (any-macro? f env) (eq? f 'macroexpand)) ; handled specially (syntactic, not a macro) - + (when (and (symbol? f) (not (var-member f env))) (let ((func (symbol->value f *e*))) @@ -9156,7 +9156,7 @@ (= (car ary) 1) (= (cdr ary) 1)) ; (apply car x) -> (car (car x)) (lint-format "perhaps ~A" caller (lists->string form (list f (list 'car (caddr form))))))))))) - + (let ((happy #f) (last-arg (form (- len 1)))) (if (and (not (list? last-arg)) @@ -9166,65 +9166,65 @@ (let ((args (caddr form)) (cdr-args (and (pair? (caddr form)) (cdaddr form)))) (if (identity? f) ; (apply (lambda (x) x) y) -> (car y) - (lint-format "perhaps (assuming ~A is a list of one element) ~A" caller args + (lint-format "perhaps (assuming ~A is a list of one element) ~A" caller args (lists->string form (list 'car args))) (if (simple-lambda? f) ; (apply (lambda (x) (f x)) y) -> (f (car y)) - (lint-format "perhaps (assuming ~A is a list of one element) ~A" caller args + (lint-format "perhaps (assuming ~A is a list of one element) ~A" caller args (lists->string form (tree-subst (list 'car args) (caadr f) (caddr f)))))) - + (cond ((eq? f 'list) ; (apply list x) -> x? (lint-format "perhaps ~A" caller (lists->string form args))) ((any-null? args) ; (apply f ()) -> (f) (lint-format "perhaps ~A" caller (lists->string form (list f)))) - + ((or (not (pair? args)) - (case (car args) + (case (car args) ((list) ; (apply f (list a b)) -> (f a b) (lint-format "perhaps ~A" caller (lists->string form (cons f cdr-args)))) - + ((quote) ; (apply eq? '(a b)) -> (eq? 'a 'b) (and (pair? cdr-args) (pair? (car cdr-args)) - (lint-format "perhaps ~A" caller + (lint-format "perhaps ~A" caller (lists->string form (cons f (distribute-quote (car cdr-args))))))) - + ((cons cons*) ; (apply f (cons a b)) -> (apply f a b) - (lint-format "perhaps ~A" caller - (lists->string form + (lint-format "perhaps ~A" caller + (lists->string form (if (and (len>1? cdr-args) (len>1? (cadr cdr-args)) (eq? (caadr cdr-args) 'cons)) `(apply ,f ,(car cdr-args) ,@(cdadr cdr-args)) (cons 'apply (cons f cdr-args)))))) - + ((append) ; (apply f (append (list ...)...)) -> (apply f ... ...) (and (pair? cdr-args) (pair? (car cdr-args)) (eq? (caar cdr-args) 'list) - (lint-format "perhaps ~A" caller + (lint-format "perhaps ~A" caller (lists->string form `(apply ,f ,@(cdar cdr-args) ,(if (not (pair? (cdr cdr-args))) (cdr cdr-args) - (if (null? (cddr cdr-args)) + (if (null? (cddr cdr-args)) (cadr cdr-args) (cons 'append (cdr cdr-args))))))))) - + ((reverse reverse!) ; (apply vector (reverse x)) -> (reverse (apply vector x)) (and (memq f '(string vector int-vector float-vector)) (pair? cdr-args) - (lint-format "perhaps ~A" caller + (lint-format "perhaps ~A" caller (lists->string form (list 'reverse (list 'apply f (car cdr-args))))))) - + ((make-list) ; (apply string (make-list x y)) -> (make-string x y) (if (memq f '(string vector)) - (lint-format "perhaps ~A" caller + (lint-format "perhaps ~A" caller (lists->string form (cons (if (eq? f 'string) 'make-string 'make-vector) cdr-args))))) - + ((map) - (case f + (case f ((string-append) ; (apply string-append (map ...)) (if (eq? (car cdr-args) 'symbol->string) (lint-format "perhaps ~A" caller ; (apply string-append (map symbol->string ...)) @@ -9237,34 +9237,34 @@ (eq? (caddr body) (caadar cdr-args))) (and (string? (caddr body)) (eq? (cadr body) (caadar cdr-args))))) - (let ((str (string-append "~{" + (let ((str (string-append "~{" (if (string? (cadr body)) (cadr body) "~A") (if (string? (caddr body)) (caddr body) "~A") "~}"))) (lint-format "perhaps ~A" caller (lists->string form (list 'format #f str (cadr cdr-args)))))))))) - + ((string) ; (apply string (map char-downcase x)) -> (string-downcase (apply string x)) (if (memq (car cdr-args) '(char-upcase char-downcase)) (lint-format "perhaps, assuming ~A is a list, ~A" caller (cadr cdr-args) (lists->string form (list (if (eq? (car cdr-args) 'char-upcase) 'string-upcase 'string-downcase) (list 'apply string (cadr cdr-args))))))) - + ((append) ; (apply append (map vector->list args)) -> (vector->list (apply append args)) (case (car cdr-args) ((vector->list) (lint-format "perhaps ~A" caller (lists->string form `(vector->list (apply append ,@(cdr cdr-args)))))) ((list) ; (apply append (map list args)) -> args (lint-format "perhaps ~A" caller (lists->string form (cadr cdr-args)))))) - + (else #f))) ;; (apply append (map f ...)) is very common but changing it to ;; (map (lambda (x) (apply values (f x))) ...) - ;; is not an obvious win. The code is more complicated, and currently apply values + ;; is not an obvious win. The code is more complicated, and currently apply values ;; copies its args as do apply and append -- how many copies are there here?! ;; cursory timing tests indicate that (apply append ...) is faster - + ;; need to check for only one apply values ((list-values) ; (apply f `(,x ,@z)) -> (apply f x z) (let ((last-arg (last-ref args))) @@ -9284,12 +9284,12 @@ (unless (hash-table-ref syntaces f) ; also not any-macro I presume (when (and (pair? last-arg) (eq? (car last-arg) 'list)) ; (apply f y z (list a b)) -> (f y z a b) - (lint-format "perhaps ~A" caller - (lists->string form - (append (copy (cdr form) (make-list (- len 2))) + (lint-format "perhaps ~A" caller + (lists->string form + (append (copy (cdr form) (make-list (- len 2))) (cdr last-arg))))) ;; can't cleanly go from (apply write o p) to (write o (car p)) since p can be () - + (when (and (not happy) (any-null? last-arg)) ; (apply f ... ()) -> (f ...) (lint-format "perhaps ~A" caller (lists->string form (cons f (copy (cddr form) (make-list (- len 3))))))))))))))) @@ -9302,12 +9302,12 @@ (lint-format "perhaps ~A" caller (lists->string form (append (copy (cdr form) (make-list (- len 2))) (list (list 'car (list-ref form (- len 1))))))))))))) - + (hash-special 'apply sp-apply)) - + ;; ---------------- format ---------------- (let () - (define count-directives + (define count-directives (let ((format-control-char (let ((chars (make-vector 256 #f))) (for-each (lambda (c) @@ -9345,7 +9345,7 @@ (if (not (vector-ref format-control-char (char->integer c))) ; (format #f "~H" 1) (lint-format "unrecognized format directive: ~C in ~S, ~S" caller c str form)) (set! dirs (+ dirs 1)) - + ;; ~n so try to figure out how many args are needed (this is not complete) (when (char-ci=? c #\n) (let ((j (+ i 1))) @@ -9366,9 +9366,9 @@ (lint-format "missing format directive: ~S" caller str) (if (not (char-ci=? (string-ref str j) #\t)) (set! dirs (+ dirs 1))))))))) - + (set! tilde-time #f) - (case c + (case c ((#\{) (set! curlys (+ curlys 1))) ((#\}) (set! curlys (- curlys 1))) ((#\%) (set! returns (+ returns 1))) @@ -9383,19 +9383,19 @@ (substring str (- i 1) (+ i 1))))) (begin ; not tilde-time (set! pos (char-position #\~ str i)) - (if pos + (if pos (begin (set! tildes (+ tildes 1)) (set! tilde-time #t) (set! i pos)) (set! i len)))))) - + (if (not (= curlys 0)) ; (format #f "~{~A" 1) (lint-format "~A has ~D unmatched ~A~A: ~A" - caller head - (abs curlys) - (if (positive? curlys) "{" "}") - (if (> curlys 1) "s" "") + caller head + (abs curlys) + (if (positive? curlys) "{" "}") + (if (> curlys 1) "s" "") (truncated-list->string form))) (if (and (= tildes returns) (not (cadr form)) ; (format #f "...~%..." -> "...\n..." @@ -9411,30 +9411,30 @@ (set! i (+ i 1)) (string-set! strc i #\n)))))) dirs)))) - + (define (sp-format caller head form env) (if (< (length form) 3) (begin (cond ((< (length form) 2) ; (format) (lint-format "~A has too few arguments: ~A" caller head (truncated-list->string form))) - + ((and (pair? (cadr form)) ; (format (format #f str)) (eq? (caadr form) 'format)) (lint-format "redundant format: ~A" caller (truncated-list->string form))) - + ((and (code-constant? (cadr form)) ; (format 1) (not (string? (cadr form)))) (lint-format "format with one argument takes a string: ~A" caller (truncated-list->string form))) - + ((and (string? (cadr form)) ; (format "str") -> str (eq? head 'format) ; not snd-display, error, etc (not (char-position #\~ (cadr form)))) (lint-format "perhaps ~A" caller (lists->string form (cadr form))))) env) - + (let ((control-string ((if (string? (cadr form)) cadr caddr) form)) (args ((if (string? (cadr form)) cddr cdddr) form))) - + (when (eq? head 'format) (if (string? (cadr form)) ; (format "s") (lint-format "please include the port argument to format, perhaps ~A" caller (cons 'format (cons () (cdr form)))) @@ -9448,14 +9448,14 @@ (and (pair? (car sig)) (memq 'string? (car sig))))))))) (lint-format "perhaps ~A" caller ; (format #f "~S" x) -> (object->string x) - (lists->string form + (lists->string form (cons 'object->string - (cons (cadddr form) + (cons (cadddr form) (if (string=? (caddr form) "~A") '(#f) ()))))))) (if (and (eq? (cadr form) 't) ; (format t " ") (not (var-member 't env))) (lint-format "'t in ~A should probably be #t" caller (truncated-list->string form)))) - + (if (lint-any? all-caps-warning (cdr form)) (lint-format "There's no need to shout: ~A" caller (truncated-list->string form))) @@ -9470,7 +9470,7 @@ (cond ((not (or (= ndirs nargs) (tree-memq 'values form))) (lint-format "~A has ~A arguments: ~A" ; (format #f "~nT" 1 2) - caller head + caller head (if (> ndirs nargs) "too few" "too many") (truncated-list->string form))) ; this can be confused by (e.g) (format () "~A~96,'-T~A~%" red-text normal-text) @@ -9482,7 +9482,7 @@ ((string-position "~^~}" control-string) (lint-format "pointless ~~^ in ~S" caller control-string))))) - + (when (pair? args) (let ((pos (and (string? control-string) (char-position #\~ control-string)))) @@ -9494,9 +9494,9 @@ (set! pos (char-position #\~ control-string (+ pos 2)))) (if (quoted-symbol? a) ; not integer -- might be counter, keyword and things like () get no hits - (lint-format "perhaps put the argument ~A in the control string: ~A" caller + (lint-format "perhaps put the argument ~A in the control string: ~A" caller a (truncated-list->string form)) - + (when (and (len>1? a) (not (memv directive '(#\S #\s)))) (case (car a) @@ -9511,26 +9511,26 @@ (lint-format "~A arg ~A could use the format directive ~~~A and change the argument to ~A" caller head a (case (caddr a) ((2) "B") ((8) "O") (else "X")) (cadr a)))))) - + ((symbol->string object->string string->symbol) ; (format #f "~A" (symbol->string 'x)) (lint-format "~A arg ~A could be ~A" caller head a (cadr a))) - + ((make-string) ; (format #f "~A" (make-string len c)) (if (pair? (cddr a)) (lint-format "~A arg ~A could use the format directive ~~NC and change the argument to ... ~A ~A ..." caller head a (cadr a) (if (char? (caddr a)) (format #f "~W" (caddr a)) (caddr a))))) - + ((apply) (if (and (len=3? a) (memq (cadr a) '(append string-append vector-append))) (lint-format "use ~~{...~~} rather than ~A: ~A" caller (cadr a) a))) - + ((string-append) ; (format #f "~A" (string-append x y)) (if (eq? head 'format) (lint-format "format appends strings, so ~A seems wasteful" caller a)))))))) args)))))) (hash-special 'format sp-format)) - + ;; ---------------- error/throw ---------------- (let () (define (sp-error caller head form env) @@ -9570,7 +9570,7 @@ target (truncated-list->string form))))))) (hash-special 'sort! sp-sort)) - + ;; ---------------- substring ---------------- (let () (define (sp-substring caller head form env) @@ -9581,15 +9581,15 @@ (lint-format "perhaps ~A -> ~S" caller (truncated-list->string form) val))) (lambda (type info) (lint-format "~A -> ~A" caller (truncated-list->string form) (apply format #f info)))) - + (let ((str (cadr form))) - + (when (string? str) ; (substring "++++++" 0 2) -> (make-string 2 #\+) (let ((len (length str))) (when (and (> len 0) (string=? str (make-string len (string-ref str 0)))) (lint-format "perhaps ~A" caller - (lists->string form + (lists->string form (let ((chars (if (null? (cddr form)) len (if (pair? (cdddr form)) @@ -9598,28 +9598,43 @@ (list '- (cadddr form) (caddr form))) (list '- len (caddr form)))))) (list 'make-string chars (string-ref str 0)))))))) + (when (pair? (cddr form)) - (when (null? (cdddr form)) - (when (and (pair? str) ; (substring (substring x 1) 2) -> (substring x 3) - (eq? (car str) 'substring) - (null? (cdddr str))) - (lint-format "perhaps ~A" caller - (lists->string form - (list 'substring (cadr str) - (if (and (integer? (caddr form)) - (integer? (caddr str))) - (+ (caddr str) (caddr form)) - (list '+ (caddr str) (caddr form))))))) - - ;; end indices are complicated -- since this rarely happens, not worth the trouble - (if (eqv? (caddr form) 0) ; (substring x 0) -> (copy x) - (lint-format "perhaps clearer: ~A" caller (lists->string form (list 'copy str))))) - + (when (and (pair? str) ; (substring (substring x 1) 2) -> (substring x 3) + (eq? (car str) 'substring)) + (let ((inner-x (caddr str)) + (inner-y (and (pair? (cdddr str)) + (cadddr str))) + (outer-x (caddr form)) + (outer-y (and (pair? (cdddr form)) + (cadddr form)))) + (let ((x (if (and (integer? outer-x) + (integer? inner-x)) + (+ outer-x inner-x) + (list '+ outer-x inner-x)))) + (if (not (or inner-y outer-y)) + (lint-format "perhaps ~A" caller + (lists->string form + (list 'substring (cadr str) x))) + (lint-format "perhaps ~A" caller ; (substring (substring str x1 y1) x2 y2) + (lists->string form + (list 'substring (cadr str) x + (if outer-y + (if (and (integer? outer-y) + (integer? inner-x)) + (+ outer-y inner-x) + (list '+ outer-y inner-x)) + inner-y)))))))) + + (if (and (eqv? (caddr form) 0) + (null? (cdddr form))) ; (substring x 0) -> (copy x) + (lint-format "perhaps clearer: ~A" caller (lists->string form (list 'copy str)))) + (when (pair? (cdddr form)) (let ((end (cadddr form))) (if (equal? (caddr form) end) ; (substring x (+ y 1) (+ y 1)) is "" (lint-format "leaving aside errors, ~A is \"\"" caller form)) - + (when (and (len=3? str) (eqv? (caddr form) 0) (eq? (car str) 'string-append)) @@ -9629,12 +9644,12 @@ (equal? (cadddr form) (cadr in-arg2))) (lint-format "perhaps ~A" caller (lists->string form `(copy ,(cadr str) (make-string ,(cadddr form) ,(caddr in-arg2)))))))) - + (if (and (len>1? end) ; (substring x start (length|string-length x)) -> (substring s start) (memq (car end) '(string-length length)) (equal? (cadr end) str)) (lint-format "perhaps ~A" caller (lists->string form (copy form (make-list 3)))) - + (when (symbol? end) (let ((v (var-member end env))) (if (and v @@ -9644,18 +9659,18 @@ (var-history v)))) ; if len is still (string-length x), (substring x 1 len) -> (substring x 1) (lint-format "perhaps, if ~A is still ~A, ~A" caller end (var-initial-value v) (lists->string form (copy form (make-list 3)))))))))))))) - + (hash-special 'substring sp-substring)) - + ;; ---------------- list, *vector ---------------- (let ((seq-maker (lambda (seq) - (cdr (assq seq '((list . make-list) + (cdr (assq seq '((list . make-list) (vector . make-vector) (float-vector . make-float-vector) (int-vector . make-int-vector) (byte-vector . make-byte-vector)))))) (seq-default (lambda (seq) - (cdr (assq seq '((list . #f) + (cdr (assq seq '((list . #f) (vector . #<unspecified>) (float-vector . 0.0) (int-vector . 0) @@ -9677,9 +9692,9 @@ (and (len=2? p) (eq? f (car p)))) (cddr form))) - (lint-format "perhaps ~A" caller + (lint-format "perhaps ~A" caller (truncated-lists->string form - (if (lint-every? (lambda (p) + (if (lint-every? (lambda (p) (code-constant? (cadr p))) (cdr form)) `(map ,f ',(map (lambda (p) ; p = arg which might be quoted (not = f) @@ -9690,14 +9705,14 @@ (cdr form))) `(map ,f (list ,@(map cadr (cdr form)))))))))))) ;; *vector here gets a dozen or so hits but (apply vector (map f (list ...))) involves too much consing - ;; list-values in this case is always apply-values as 'f + ;; list-values in this case is always apply-values as 'f ;; the only other hits in this area are and/or and test macros (when (and (> len 4) (lint-every? (lambda (a) (equal? a val)) (cddr form))) (if (code-constant? val) ; (vector 12 12 12 12 12 12) -> (make-vector 6 12) (lint-format "perhaps ~A~A" caller - (lists->string form + (lists->string form (if (eqv? (seq-default head) val) (list (seq-maker head) (- len 1)) (list (seq-maker head) (- len 1) val))) @@ -9712,14 +9727,14 @@ (hash-table-ref makers (car val))) (if (> (tree-leaves val) 3) ;; I think we need to laboriously repeat the function call here: - ;; (let ((a 1) (b 2) (c 3)) + ;; (let ((a 1) (b 2) (c 3)) ;; (define f (let ((ctr 0)) (lambda (x y z) (set! ctr (+ ctr 1)) (+ x y ctr (* 2 z))))) ;; (list (f a b c) (f a b c) (f a b c) (f a b c)) ;; so (apply list (make-list 4 (<1>))) or variants thereof fail ;; (eval (append '(list) (make-list 4 '(<1>)))) ;; works, but it's too ugly. (lint-format "perhaps ~A" caller - (lists->string form + (lists->string form `(let ((<1> (lambda () ,val))) (,head ,@(make-list (- len 1) '(<1>))))))) ;; if seq copy else @@ -9731,30 +9746,30 @@ ;; ---------------- list-tail ---------------- (let () (define (sp-list-tail caller head form env) - (cond + (cond ((not (= (length form) 3)) #f) - + ((eqv? (caddr form) 0) ; (list-tail x 0) -> x (lint-format "perhaps ~A" caller (lists->string form (cadr form)))) - + ((and (pair? (cadr form)) (eq? (caadr form) 'list-tail)) (lint-format "perhaps ~A" caller ; (list-tail (list-tail x 1) 2) -> (list-tail x 3) - (lists->string form + (lists->string form (list 'list-tail (cadadr form) (if (and (integer? (caddr form)) (integer? (caddr (cadr form)))) (+ (caddr (cadr form)) (caddr form)) (list '+ (caddr (cadr form)) (caddr form))))))) - + ((memv (caddr form) '(1 2)) ; (list-tail x 1) -> (cdr x) - (lint-format "perhaps ~A" caller - (lists->string form + (lint-format "perhaps ~A" caller + (lists->string form (list (if (eqv? (caddr form) 1) 'cdr 'cddr) (cadr form))))))) (hash-special 'list-tail sp-list-tail)) - + ;; ---------------- eq? ---------------- (let () (define (sp-eq? caller head form env) @@ -9767,39 +9782,39 @@ (specific-op (and (eq? (cadr eq1) (cadr eq2)) (not (memq (cadr eq1) '(eqv? equal?))) (cadr eq1)))) - + (eval-constant-expression caller form) - + (if (or (eq? (car eq1) 'equal?) (eq? (car eq2) 'equal?)) ; (eq? #(0) #(0)) - (lint-format "eq? should be equal?~A in ~A" caller - (if specific-op (format #f " or ~A" specific-op) "") + (lint-format "eq? should be equal?~A in ~A" caller + (if specific-op (format #f " or ~A" specific-op) "") (truncated-list->string form)) (if (or (eq? (car eq1) 'eqv?) (eq? (car eq2) 'eqv?)) ; (eq? x 1.5) - (lint-format "eq? should be eqv?~A in ~A" caller + (lint-format "eq? should be eqv?~A in ~A" caller (if specific-op (format #f " or ~A" specific-op) "") (truncated-list->string form)))) - + (let ((expr 'unset)) (cond ((or (not arg1) ; (eq? #f x) -> (not x) (quoted-not? arg1)) (set! expr (simplify-boolean (list 'not arg2) () () env))) - + ((or (not arg2) ; (eq? x #f) -> (not x) (quoted-not? arg2)) (set! expr (simplify-boolean (list 'not arg1) () () env))) - + ((and (any-null? arg1) ; (eq? () x) -> (null? x) (not (code-constant? arg2))) (set! expr (or (equal? arg2 '(list)) ; (eq? () (list)) -> #t (list 'null? arg2)))) - + ((and (any-null? arg2) ; (eq? x ()) -> (null? x) (not (code-constant? arg1))) (set! expr (or (equal? arg1 '(list)) (list 'null? arg1)))) - + ((and (eq? arg1 #t) ; (eq? #t <boolean-expr>) -> boolean-expr (pair? arg2)) ; (eq? #t <never-#t-expr) -> #f (let ((rtn (return-type (car arg2) env))) @@ -9812,7 +9827,7 @@ (not (memq #t rtn)) (not (memq 'values rtn))) (set! expr #f))))))) - + ((and (eq? arg2 #t) ; (eq? <boolean-expr> #t) -> boolean-expr (pair? arg1)) ; (eq? <never-#t-expr) #t) -> #f (let ((rtn (return-type (car arg1) env))) @@ -9831,11 +9846,11 @@ ;; ->lint-type -> #t if unknown (unless (compatible? t1 t2) (set! expr #f))) - + (if (not (eq? expr 'unset)) ; (eq? x '()) -> (null? x) (lint-format "perhaps ~A" caller (lists->string form expr))))))) (hash-special 'eq? sp-eq?)) - + ;; ---------------- eqv? equal? ---------------- (let () (define (useless-copy? a) @@ -9859,7 +9874,7 @@ (useless-copy? arg2)) ; (equal? (vector-copy #(a b c)) #(a b c)) -> (equal? #(a b c) #(a b c)) (lint-format "perhaps ~A" caller (lists->string form - (list head + (list head (if (useless-copy? arg1) (cadr arg1) arg1) (if (useless-copy? arg2) (cadr arg2) arg2))))) (unless (string->char= caller form form) @@ -9869,8 +9884,8 @@ (memq (cadr eq1) '(char=? string=?)) (memq (cadr eq2) '(char=? string=?))) (lint-format "this can't be right: ~A" caller form)) - - ;; (equal? a (list b)) and equivalents happen a lot (well, a few dozen times), but is the extra consing worse than + + ;; (equal? a (list b)) and equivalents happen a lot (well, a few dozen times), but is the extra consing worse than ;; (and (pair? a) (null? (cdr a)) (equal? (car a) b)) -- code readability seems more important here ;; also, a is often an expression, and let+local is worse than list @@ -9879,35 +9894,35 @@ (if (eq? head 'equal?) (if specific-op ; equal? could be string=? in (equal? (string x) (string-append y z)) (lint-format "~A could be ~A in ~S" caller head specific-op form)) - (lint-format "~A should be equal?~A in ~S" caller head - (if specific-op (format #f " or ~A" specific-op) "") + (lint-format "~A should be equal?~A in ~S" caller head + (if specific-op (format #f " or ~A" specific-op) "") form))) - + ((or (eq? (car eq1) 'eqv?) (eq? (car eq2) 'eqv?)) (if (eq? head 'eqv?) (if specific-op ; (eqv? (integer->char x) #\null) (lint-format "~A could be ~A in ~S" caller head specific-op form)) - (lint-format "~A ~A be eqv?~A in ~S" caller head - (if (eq? head 'eq?) "should" "could") + (lint-format "~A ~A be eqv?~A in ~S" caller head + (if (eq? head 'eq?) "should" "could") (if specific-op (format #f " or ~A" specific-op) "") form))) - + ((not (or (eq? (car eq1) 'eq?) (eq? (car eq2) 'eq?)))) ((not (and arg1 arg2)) ; (eqv? x #f) -> (not x) (lint-format "~A could be not: ~A" caller head (lists->string form (list 'not (or arg1 arg2))))) - - ((or (any-null? arg1) + + ((or (any-null? arg1) (any-null? arg2)) ; (eqv? x ()) -> (null? x) (lint-format "~A could be null?: ~A" caller head - (lists->string form + (lists->string form (list 'null? (if (any-null? arg1) arg2 arg1))))) (else ; (eqv? x 'a) - (lint-format "~A could be eq?~A in ~S" caller head - (if specific-op (format #f " or ~A" specific-op) "") + (lint-format "~A could be eq?~A in ~S" caller head + (if specific-op (format #f " or ~A" specific-op) "") form))) (let ((t1 (->lint-type arg1)) ; (eqv? (floor pi) 'a) -> #f @@ -9940,7 +9955,7 @@ (hash-special 'equivalent? sp-equivalent)) - + ;; ---------------- map for-each ---------------- (let () (define (sp-map caller head form env) @@ -9948,8 +9963,8 @@ (args (- len 2))) (if (< len 3) ; (map (lambda (v) (vector-ref v 0))) (lint-format "~A missing argument~A in: ~A" - caller head - (if (= len 2) "" "s") + caller head + (if (= len 2) "" "s") (truncated-list->string form)) (let ((func (cadr form)) (ary #f)) @@ -9961,9 +9976,9 @@ (eqv? (length p) 0)) (and (pair? p) (case (car p) - ((vector string) + ((vector string) (null? (cdr p))) - ((quote) + ((quote) (and (pair? (cdr p)) (eqv? (length (cadr p)) 0))) (else #f))))) @@ -10025,13 +10040,13 @@ (let ((val (eval form))) (lint-format "perhaps ~A" caller (lists->string form (list 'quote val))))) (lambda args #f)))) - + (when (and (pair? func) (memq (car func) '(lambda lambda*))) (if (pair? (cadr func)) (let ((arglen (length (cadr func)))) (set! ary (if (eq? (car func) 'lambda) - (if (negative? arglen) + (if (negative? arglen) (cons (abs arglen) 512000) (cons arglen arglen)) (cons 0 (if (or (negative? arglen) @@ -10047,13 +10062,13 @@ (if (pair? ary) (if (< args (car ary)) ; (map (lambda (a b) a) '(1 2)) (lint-format "~A has too few arguments in: ~A" - caller head + caller head (truncated-list->string form)) (if (> args (cdr ary)) ; (map abs '(1 2) '(3 4)) (lint-format "~A has too many arguments in: ~A" - caller head + caller head (truncated-list->string form))))) - (for-each + (for-each (lambda (obj) (if (and (len>1? obj) (memq (car obj) '(vector->list string->list let->list))) ; (vector->list #(1 2)) could be simplified to: #(1 2) @@ -10063,17 +10078,17 @@ (truncated-list->string (cadr obj)) head))) (cddr form)) - + (when (eq? head 'map) (when (and (memq func '(char-downcase char-upcase)) (pair? (caddr form)) ; (map char-downcase (string->list str)) -> (string->list (string-downcase str)) (eq? (caaddr form) 'string->list)) - (lint-format "perhaps ~A" caller + (lint-format "perhaps ~A" caller (lists->string form (list 'string->list (list (if (eq? func 'char-upcase) 'string-upcase 'string-downcase) (cadr (caddr form))))))) (when (identity? func) ; to check f here as var is more work ; (map (lambda (x) x) lst) -> lst (lint-format "perhaps ~A" caller (lists->string form (caddr form))))) - + (let ((arg1 (caddr form))) (when (and (len>1? arg1) (or (memq (car arg1) '(cdr cddr cdddr cddddr)) @@ -10083,7 +10098,7 @@ (memq (caadr arg1) '(string->list vector->list))) (let ((string-case (eq? (caadr arg1) 'string->list)) ; (cdr (vector->list v)) -> (subvector v 1 (length v)) (len-diff (case (car arg1) ((list-tail) (caddr arg1)) (else => cdr-count)))) - (lint-format "~A accepts ~A arguments, so perhaps ~A" caller head + (lint-format "~A accepts ~A arguments, so perhaps ~A" caller head (if string-case 'string 'vector) (lists->string arg1 (if string-case (list 'substring (cadadr arg1) len-diff) @@ -10093,10 +10108,10 @@ (eq? (caadr form) 'lambda) (not (lint-any? (lambda (x) (side-effect? x env)) (cddadr form)))) (lint-format "pointless for-each: ~A" caller (truncated-list->string form))) - + (when (= args 1) (let ((seq (caddr form))) - + (when (pair? seq) (case (car seq) ((cons) ; (for-each display (cons msgs " ")) @@ -10110,29 +10125,29 @@ ;; but only if first arg is only used once in first func, and everything is simple (one-line or symbol) (let* ((seq-func (cadr seq)) (arg-name (find-unique-name func seq-func))) - + (if (symbol? func) ; (map f (map g h)) -> (map (lambda (<1>) (f (g <1>))) h) -- dubious - (if (symbol? seq-func) - (lint-format "perhaps ~A" caller - (lists->string form `(,head (lambda (,arg-name) - (,func (,seq-func ,arg-name))) + (if (symbol? seq-func) + (lint-format "perhaps ~A" caller + (lists->string form `(,head (lambda (,arg-name) + (,func (,seq-func ,arg-name))) ,(caddr seq)))) - (if (simple-lambda? seq-func) + (if (simple-lambda? seq-func) ;; (map f (map (lambda (x) (g x)) h)) -> (map (lambda (x) (f (g x))) h) - (lint-format "perhaps ~A" caller + (lint-format "perhaps ~A" caller (lists->string form `(,head (lambda (,arg-name) (,func ,(tree-subst arg-name (caadr seq-func) (caddr seq-func)))) ,(caddr seq)))))) (if (less-simple-lambda? func) - (if (symbol? seq-func) + (if (symbol? seq-func) ;; (map (lambda (x) (f x)) (map g h)) -> (map (lambda (x) (f (g x))) h) - (lint-format "perhaps ~A" caller + (lint-format "perhaps ~A" caller (lists->string form `(,head (lambda (,arg-name) ,@(tree-subst (list seq-func arg-name) (caadr func) (cddr func))) ,(caddr seq)))) - (if (simple-lambda? seq-func) + (if (simple-lambda? seq-func) ;; (map (lambda (x) (f x)) (map (lambda (x) (g x)) h)) -> (map (lambda (x) (f (g x))) h) - (lint-format "perhaps ~A" caller + (lint-format "perhaps ~A" caller (lists->string form `(,head (lambda (,arg-name) ,@(tree-subst (tree-subst arg-name (caadr seq-func) (caddr seq-func)) (caadr func) (cddr func))) @@ -10147,7 +10162,7 @@ (let ((op (if (eq? func 'write) "~S" "~A")) (len (- (length seq) 1))) (lists->string form `(format () ,(do ((i 0 (+ i 1)) - (str "" (string-append str op))) + (str "" (string-append str op))) ((= i len) str)) ,@(cdr seq)))) (let ((op (if (eq? func 'write) "~{~S~}" "~{~A~}"))) @@ -10176,27 +10191,27 @@ ;; (for-each (lambda (elt) (display elt)) lst) (let ((ctrl-string "") (arg-ctr 0)) - + (define* (gather-format str (arg :unset)) (set! ctrl-string (string-append ctrl-string str))) - + (for-each (lambda (d) - (if (or (memq larg d) + (if (or (memq larg d) (and (pair? (cdr d)) (pair? (cadr d)) (memq larg (cadr d)))) (set! arg-ctr (+ arg-ctr 1))) (gather-format (display->format d))) body) - + (when (= arg-ctr 1) ; (for-each (lambda (x) (display x)) args) -> (format () "~{~A~}" args) - (lint-format "perhaps ~A" caller + (lint-format "perhaps ~A" caller (lists->string form (list 'format op (string-append "~{" ctrl-string "~}") seq)))))))))))))))))) (for-each (lambda (f) (hash-special f sp-map)) '(map for-each))) - + ;; ---------------- magnitude ---------------- (let () (define (sp-magnitude caller head form env) @@ -10225,18 +10240,18 @@ (for-each (lambda (f) (hash-special f sp-open-input-file)) '(open-input-file open-output-file))) - + ;; ---------------- values ---------------- (let () (define (car-values? a b) ; (values 2 (values 3 4) 5) -> (values 2 3 4 5) - (and (pair? b) + (and (pair? b) (eq? (car b) 'values))) (define (sp-values caller head form env) (cond ((member #f (cdr form) car-values?) (lint-format "perhaps ~A" caller (lists->string form (cons 'values (splice-if 'values (cdr form)))))) ((len=2? form) - (lint-format "perhaps ~A" caller + (lint-format "perhaps ~A" caller (lists->string form ; (values (list-values 'x (apply-values y))) -> (cons 'x y) (if (and (pair? (cadr form)) (eq? (caadr form) 'list-values) @@ -10258,7 +10273,7 @@ a)) (cdr form)))))))) (hash-special 'values sp-values)) - + ;; ---------------- call-with-values ---------------- (let () (define (sp-call/values caller head form env) ; (call/values p c) -> (c (p)) @@ -10280,28 +10295,28 @@ (or (> (car consumed-values) (car produced-values)) (< (cdr consumed-values) (cadr produced-values)))) (let ((clen ((if (> (car consumed-values) (car produced-values)) car cdr) consumed-values))) - (lint-format "call-with-values consumer ~A wants ~D value~P, but producer ~A returns ~A" + (lint-format "call-with-values consumer ~A wants ~D value~P, but producer ~A returns ~A" caller (truncated-list->string consumer) clen clen (truncated-list->string producer) ((if (> (car consumed-values) (car produced-values)) car cadr) produced-values))))) - + (cond ((not (pair? producer)) ; (call-with-values log c) (if (and (symbol? producer) (not (memq (return-type producer ()) '(#t #f values)))) (lint-format "~A does not return multiple values" caller producer) (lint-format "perhaps ~A" caller (lists->string form (list consumer (list producer)))))) - + ((not (eq? (car producer) 'lambda)) ; (call-with-values (eval p env) (eval c env)) -> ((eval c env) ((eval p env))) (lint-format "perhaps ~A" caller (lists->string form (list consumer (list producer))))) - + ((pair? (cadr producer)) ; (call-with-values (lambda (x) 0) list) (lint-format "~A requires too many arguments" caller (truncated-list->string producer))) - + ((symbol? (cadr producer)) ; (call-with-values (lambda x 0) list) (lint-format "~A's parameter ~A will always be ()" caller (truncated-list->string producer) (cadr producer))) - + ((len=1? (cddr producer)) ; (call-with-values (lambda () (read-char p)) cons) (let ((body (caddr producer))) (if (or (code-constant? body) @@ -10309,16 +10324,16 @@ (symbol? (car body)) (not (memq (return-type (car body) ()) '(#t #f values))))) (lint-format "~A does not return multiple values" caller body) - (lint-format "perhaps ~A" caller - (lists->string form + (lint-format "perhaps ~A" caller + (lists->string form (if (and (pair? body) (eq? (car body) 'values)) (cons consumer (cdr body)) (list consumer body))))))) - + (else (lint-format "perhaps ~A" caller (lists->string form (list consumer (list producer))))))))) (hash-special 'call-with-values sp-call/values)) - + ;; ---------------- multiple-value-bind ---------------- (let () (define (sp-mvb caller head form env) @@ -10326,33 +10341,33 @@ (let ((vars (cadr form)) (producer (caddr form)) (body (cdddr form))) - + (if (null? vars) (lint-format "this multiple-value-bind is pointless; perhaps ~A" caller - (lists->string form + (lists->string form (if (side-effect? producer env) (cons 'begin (cons producer body)) (if (null? (cdr body)) (car body) (cons 'begin body))))) - + (unless (symbol? vars) ; else any number of values is ok (let ((vals (mv-range producer env)) ; (multiple-value-bind (a b) (values 1 2 3) b) (args (length vars))) (if (and (integer? args) (pair? vals) (not (<= (car vals) args (cadr vals)))) - (lint-format "multiple-value-bind wants ~D values, but ~A returns ~A" - caller args + (lint-format "multiple-value-bind wants ~D values, but ~A returns ~A" + caller args (truncated-list->string producer) ((if (< args (car vals)) car cadr) vals))) - + (if (and (pair? producer) ; (multiple-value-bind (a b) (f) b) -> ((lambda (a b) b) (f)) (symbol? (car producer)) (not (memq (return-type (car producer) ()) '(#t #f values)))) (lint-format "~A does not return multiple values" caller (car producer)) - (lint-format "perhaps ~A" caller - (lists->string form + (lint-format "perhaps ~A" caller + (lists->string form (if (and (null? (cdr body)) (pair? (car body)) (symbol? (caar body)) @@ -10362,7 +10377,7 @@ (list (caar body) producer) `((lambda ,vars ,@body) ,producer))))))))))) (hash-special 'multiple-value-bind sp-mvb)) - + ;; ---------------- let-values ---------------- (let () (define (sp-let-values caller head form env) @@ -10378,10 +10393,10 @@ ,(cadr call)))))) (if (just-len>1? (cadr form)) (lint-format "perhaps ~A" caller ; (let-values (((x) (values 1)) ((y) (values 2))) (list x y)) ... - (lists->string + (lists->string form - `(with-let - (apply sublet (curlet) + `(with-let + (apply sublet (curlet) (list ,@(map (lambda (v) `((lambda ,(car v) (values ,@(map (lambda (name) @@ -10391,13 +10406,13 @@ (cadr form)))) ,@(cddr form)))))))) (hash-special 'let-values sp-let-values)) - + ;; ---------------- let*-values ---------------- - (hash-special 'let*-values + (hash-special 'let*-values (lambda (caller head form env) (if (and (pair? (cdr form)) (proper-pair? (cadr form)) ; every? uses for-each which ignores dotted-list cdr? - (just-len>1? (cadr form))) + (just-len>1? (cadr form))) (lint-format "perhaps ~A" caller (lists->string form ; (let*-values (((a) (f x))) (+ a b)) -> (let ((a (f x))) (+ a b)) (let loop ((var-data (cadr form))) @@ -10410,27 +10425,27 @@ (if (null? (cdr var-data)) `((lambda ,(car v) ,@(cddr form)) ,(cadr v)) `((lambda ,(car v) ,(loop (cdr var-data))) ,(cadr v))))))))))) - + ;; ---------------- define-values ---------------- - (hash-special 'define-values + (hash-special 'define-values (lambda (caller head form env) (when (pair? (cdr form)) (if (null? (cadr form)) (lint-format "~A is pointless" caller (truncated-list->string form)) (when (pair? (cddr form)) - (lint-format "perhaps ~A" caller + (lint-format "perhaps ~A" caller (cond ((symbol? (cadr form)) - (lists->string form (list 'define (cadr form) (list 'list (caddr form))))) - + (lists->string form (list 'define (cadr form) (list 'list (caddr form))))) + ((len=1? (cadr form)) (lists->string form (list 'define (caadr form) (caddr form)))) - + (else ; (define-values (x y) (values 3 2)) -> (varlet (curlet) ((lambda (x y) (curlet)) (values 3 2))) (let-temporarily ((target-line-length 120)) (truncated-lists->string form - `(varlet (curlet) - ((lambda ,(cadr form) - (curlet)) + `(varlet (curlet) + ((lambda ,(cadr form) + (curlet)) ,(caddr form))))))))))))) ;; ---------------- eval ---------------- (let () @@ -10441,11 +10456,11 @@ (if (not (pair? arg)) (if (not (symbol? arg)) ; (eval 32) (lint-format "this eval is pointless; perhaps ~A" caller (lists->string form arg))) - (case (car arg) + (case (car arg) ((quote) ; (eval 'x) (if (pair? (cdr arg)) (lint-format "perhaps ~A" caller (lists->string form (cadr arg))))) - + ((string->symbol) ; (eval (string->symbol "x")) -> x (if (pair? (cdr arg)) ; (eval (string->symbol x)) -> (eval-string x) (if (string? (cadr arg)) @@ -10453,18 +10468,18 @@ (lint-format "string->symbol argument can't be a null string:~A" caller (truncated-list->string form)) (lint-format "perhaps ~A" caller (lists->string form (string->symbol (cadr arg))))) (lint-format "perhaps ~A" caller (lists->string form (list 'eval-string (cadr arg))))))) - + ((with-input-from-string call-with-input-string) (if (and (len>1? (cdr arg)) ; (eval (call-with-input-string port read)) -> (eval-string port) (eq? (caddr arg) 'read)) (lint-format "perhaps ~A" caller (lists->string form (list 'eval-string (cadr arg)))))) - + ((read) (if (and (= (length arg) 2) ; (eval (read (open-input-string expr))) -> (eval-string expr) (len>1? (cadr arg)) (eq? (caadr arg) 'open-input-string)) (lint-format "perhaps ~A" caller (lists->string form (list 'eval-string (cadadr arg)))))) - + ((list) (if (lint-every? (lambda (p) ; (eval (list '* 2 x)) -> (* 2 (eval x)) (or (symbol? p) @@ -10492,40 +10507,40 @@ (list e arg) (cons 'with-let (cons e (unbegin (cadr arg)))))))))))) (hash-special 'eval sp-eval)) - + ;; ---------------- fill! etc ---------------- (let () (define (sp-fill! caller head form env) (if (and (pair? (cdr form)) (code-constant? (cadr form))) (lint-format "~A is a constant, so ~A is problematic" caller - (cadr form) + (cadr form) (truncated-list->string form))) (if (= (length form) 5) (check-start-and-end caller head (cdddr form) form env))) (for-each (lambda (f) (hash-special f sp-fill!)) '(fill! string-fill! list-fill! vector-fill!))) - + ;; ---------------- write-string ---------------- (let () (define (sp-write-string caller head form env) (cond ((not (len>1? form))) - + ((= (length form) 4) (check-start-and-end caller 'write-string (cddr form) form env)) - + ((and (len>1? (cdr form)) (pair? (caddr form)) (eq? (caaddr form) 'current-output-port)) (lint-format "(current-output-port) is the default port for ~A: ~A" caller head form)) - + ((equal? (cadr form) (string #\newline)) (lint-format "perhaps ~A" caller (lists->string form (cons 'newline (cddr form))))) - + ((equal? (cadr form) "") (lint-format "~A is pointless" caller form)))) - + (hash-special 'write-string sp-write-string)) ;; ---------------- read-line ---------------- @@ -10540,7 +10555,7 @@ (eq? (caadr form) 'current-input-port)) (lint-format "(current-input-port) is the default port for ~A: ~A" caller head form)))) (hash-special 'read-line sp-read-line)) - + ;; ---------------- string-length ---------------- (let () (define (sp-string-length caller head form env) @@ -10550,9 +10565,9 @@ (if (and (len>1? (cadr form)) ; (string-length (make-string 3)) -> 3 (eq? (caadr form) 'make-string)) (lint-format "perhaps ~A" caller (lists->string form (cadadr form))))))) - + (hash-special 'string-length sp-string-length)) - + ;; ---------------- vector-length ---------------- (let () (define (sp-vector-length caller head form env) @@ -10561,7 +10576,7 @@ (lint-format "perhaps ~A -> ~A" caller (truncated-list->string form) (vector-length (cadr form))) (let ((arg (cadr form))) (if (len>1? arg) - (case (car arg) + (case (car arg) ((make-vector) ; (vector-length (make-vector 10)) -> 10 (lint-format "perhaps ~A" caller (lists->string form (cadr arg)))) ((copy vector-copy) @@ -10578,7 +10593,7 @@ (cadddr arg)))) (list '- end start)))))))))))))) (hash-special 'vector-length sp-vector-length)) - + ;; ---------------- dynamic-wind ---------------- (let () (define (sp-dw caller head form env) @@ -10588,7 +10603,7 @@ (end (cadddr form)) (empty 0)) ;; (equal? init end) as a mistake doesn't seem to happen - + (when (and (len>1? init) (eq? (car init) 'lambda)) (if (not (null? (cadr init))) @@ -10602,13 +10617,13 @@ (if (null? (cdddr init)) (set! empty 1)) ; (dynamic-wind (lambda () (+)) (lambda () (list)) (lambda () #f)) (lint-format "this could be omitted: ~A in ~A" caller last-expr init)))))) - + (if (and (pair? body) (eq? (car body) 'lambda)) (if (not (null? (cadr body))) (lint-format "dynamic-wind body function should be a thunk: ~A" caller body)) (set! empty 3)) ; don't try to access body below - + (when (and (len>1? end) (eq? (car end) 'lambda)) (if (not (null? (cadr end))) @@ -10623,10 +10638,10 @@ (set! empty (+ empty 1))) (lint-format "this could be omitted: ~A in ~A" caller last-expr end))) (if (= empty 2) ; (dynamic-wind (lambda () #f) (lambda () #()) (lambda () #f)) -> #() - (lint-format "this dynamic-wind is pointless, ~A" caller + (lint-format "this dynamic-wind is pointless, ~A" caller (lists->string form (if (null? (cdddr body)) (caddr body) (cons 'begin (cddr body)))))))))))) (hash-special 'dynamic-wind sp-dw)) - + ;; ---------------- with-output-to-string ---------------- (let () (define (sp-wots caller head form env) @@ -10643,7 +10658,7 @@ (memq (caar body) '(write display))) ; write-char write-string never happen (if (null? (cdr body)) (lint-format "perhaps ~A" caller - (lists->string form (cons 'object->string + (lists->string form (cons 'object->string (cons (cadar body) (if (eq? (caar body) 'display) '(#f) ()))))) (if (and (len=1? (cdr body)) @@ -10651,11 +10666,11 @@ (eq? (caadr body) 'newline)) (lint-format "perhaps ~A" caller (lists->string form - (list 'format #f + (list 'format #f (if (eq? (caar body) 'display) "~A~%" "~S~%") (cadar body)))))))))) (hash-special 'with-output-to-string sp-wots)) - + ;; ---------------- help ---------------- (hash-special 'help (lambda (caller head form env) @@ -10674,11 +10689,11 @@ ;; ---------------- *s7* ---------------- - (hash-special '*s7* + (hash-special '*s7* (let ((s7-fields (let ((h (make-hash-table))) (for-each (lambda (f) (hash-table-set! h f #t)) - '(print-length safety cpu-time heap-size max-heap-size free-heap-size gc-freed max-string-length max-list-length + '(print-length safety cpu-time heap-size max-heap-size free-heap-size gc-freed max-string-length max-list-length max-vector-length max-vector-dimensions default-hash-table-length initial-string-port-length memory-usage gc-protected-objects file-names rootlet-size c-types stack-top stack-size stacktrace-defaults history-enabled max-stack-size stack catches float-format-precision bignum-precision default-rationalize-error debug @@ -10695,16 +10710,16 @@ (symbol? (cadr arg)) ; (*s7* 'vector-print-length) (not (hash-table-ref s7-fields (cadr arg)))) (lint-format "unknown *s7* field: ~A" caller arg))))))) - + ;; ---------------- make-hash-table ---------------- - (hash-special 'make-hash-table + (hash-special 'make-hash-table (lambda (caller head form env) (if (= (length form) 3) (let ((func (caddr form))) (if (and (symbol? func) ; (make-hash-table eq? symbol-hash) (not (memq func '(eq? eqv? equal? equivalent? char=? char-ci=? string=? string-ci=? =)))) (lint-format "make-hash-table function, ~A, is not a hash function" caller func)))))) - + ;; ---------------- cond-expand ---------------- (let () (define (sp-cond-expand caller head form env) @@ -10735,7 +10750,7 @@ (lint-format "macroexpand's argument should be an expression whose car is a macro: ~A" caller (truncated-list->string form))))) (hash-special 'macroexpand sp-macroexpand)) - ;; ---------------- deprecated funcs ---------------- + ;; ---------------- deprecated funcs ---------------- (let ((deprecated-ops '((global-environment . rootlet) (current-environment . curlet) (make-procedure-with-setter . dilambda) @@ -10754,8 +10769,8 @@ ;; ---------------- eq null eqv equal ---------------- (let () (define sp-null - (let ((spellings - '((null . null?) (eq . eq?) (eqv . eqv?) (equal . equal?) (not? . not) ; (null (cdr...)) + (let ((spellings + '((null . null?) (eq . eq?) (eqv . eqv?) (equal . equal?) (not? . not) ; (null (cdr...)) (set-car . set-car!) (set-cdr . set-cdr!) (list-set . list-set!) (vector-set . vector-set!) (string-set . string-set!)))) (lambda (caller head form env) (if (not (var-member head env)) ; (if (null (cdr x)) 0) @@ -10764,7 +10779,7 @@ (hash-special f sp-null)) '(null eq eqv equal set-car set-cdr list-set vector-set string-set))) ;; memq? is in scheme48 - + (hash-special 'nth (lambda (caller head form env) (if (not (var-member head env)) @@ -10772,7 +10787,7 @@ (lint-format "perhaps use list-ref here: ~A" caller form) (if (integer? (cadr form)) (lint-format "perhaps ~A" caller (lists->string form (cons 'list-ref (reverse (cdr form)))))))))) - + (hash-special 'sort (lambda (caller head form env) (if (and (= (length form) 3) @@ -10804,12 +10819,12 @@ (unless (var-member 'cons env) (case (length form) ((2) (lint-format "perhaps ~A" caller (lists->string form (cadr form)))) - ((3) (lint-format "perhaps ~A" caller + ((3) (lint-format "perhaps ~A" caller (lists->string form ; cons* x y) -> (cons x y) (if (any-null? (caddr form)) (list 'list (cadr form)) (cons 'cons (cdr form)))))) - ((4) (lint-format "perhaps ~A" caller + ((4) (lint-format "perhaps ~A" caller (lists->string form ; (cons* (symbol->string v) " | " (w)) -> (cons (symbol->string v) (cons " | " (w))) (if (any-null? (cadddr form)) (list 'list (cadr form) (caddr form)) @@ -10820,15 +10835,15 @@ (let ((other-names '((->string . object->string) (any . any?) (arithmetic-shift . ash) - (bit-and . logand) + (bit-and . logand) (bit-not . lognot) - (bit-or . logior) - (bit-xor . logxor) - (bitwise-and . logand) + (bit-or . logior) + (bit-xor . logxor) + (bitwise-and . logand) (bitwise-bit-set? . logbit?) - (bitwise-ior . logior) + (bitwise-ior . logior) (bitwise-not . lognot) - (bitwise-xor . logxor) + (bitwise-xor . logxor) (bytevector . byte-vector) (bytevector-copy . copy) (bytevector-fill! . fill!) @@ -10913,7 +10928,7 @@ (the-environment . curlet) (truncate-quotient . quotient) (truncate-remainder . remainder) - (u8-ready? . char-ready?) + (u8-ready? . char-ready?) (u8vector . byte-vector) (u8vector-copy . copy) (u8vector? . byte-vector?) @@ -10948,7 +10963,7 @@ (hash-special (car f) sp-other-names)) other-names)) - (hash-special '1+ + (hash-special '1+ (lambda (caller head form env) (if (and (not (var-member '1+ env)) (pair? (cdr form))) @@ -10969,7 +10984,7 @@ (lint-format "perhaps ~A" caller (lists->string form (simplify-boolean (undumb form) env () ()))))) - (for-each (lambda (f) + (for-each (lambda (f) (hash-special f sp-dumb-relop)) '(fix:= fx= flo:= fl= fix:< fx< flo:< fl< fix:> fx> flo:> fl> fix:<= fx<= flo:<= fl<= fix:>= fx>= flo:>= fl>= bignum= bignum< bignum<= bignum> bignum>= bignum-negative? bignum-zero?))) @@ -10979,32 +10994,32 @@ (if (not (var-member (car form) env)) (lint-format "perhaps ~A" caller (lists->string form (undumb form))))) - (for-each (lambda (f) + (for-each (lambda (f) (hash-special f sp-dumb-fop)) '(flo:sin flsin flo:cos flcos flo:tan fltan flo:atan flatan flo:exp flexp flo:log fllog flo:sqrt flsqrt fxlogand fxlogior fxlogxor fxlognot bignum-expt bignum-quotient bignum-magnitude bignum-abs bignum-remainder))) - ;; ---------------- push! pop! ---------------- - (hash-special 'push! + ;; ---------------- push! pop! ---------------- + (hash-special 'push! (lambda (caller head form env) ; not predefined (if (= (length form) 3) (set-set (caddr form) caller form env)))) - - (hash-special 'pop! + + (hash-special 'pop! (lambda (caller head form env) ; also not predefined (if (len=2? form) (set-set (cadr form) caller form env)))) - + ;; ---------------- receive ---------------- - (hash-special 'receive + (hash-special 'receive (lambda (caller head form env) ; this definition comes from Guile (if (and (> (length form) 3) (not (var-member 'receive env))) - ((hash-table-ref special-case-table 'call-with-values) + ((hash-table-ref special-case-table 'call-with-values) caller 'call-with-values - `(call-with-values + `(call-with-values (lambda () ,(caddr form)) (lambda ,(cadr form) ,@(cdddr form))) env)))) @@ -11015,7 +11030,7 @@ (when (and (= (length form) 3) (not (var-member 'and=> env))) (lint-format "perhaps ~A" caller (lists->string form `(cond (,(cadr form) => ,(caddr form)) (else #f))))))) - + ;; ---------------- and-let* ---------------- (let () (define (sp-and-let caller head form env) @@ -11029,7 +11044,7 @@ (lint-format "~A variable list is not a proper list? ~S" caller 'and-let* bindings)) ((and (len=1? (cadr form)) ; (and-let* ((x (f y))) (abs x)) -> (cond ((f y) => abs)) (pair? (cddr form))) - (lint-format "perhaps ~A" caller + (lint-format "perhaps ~A" caller (lists->string form ; (and-let* ((x (f y))) (abs x)) -> (cond ((f y) => abs)) (if (and (null? (cdddr form)) (len=2? (caddr form)) @@ -11041,15 +11056,15 @@ special-case-table)) ;; end special-case-functions ;; ---------------------------------------- - + (define (unused-parameter? x) #t) (define (unused-set-parameter? x) #t) - - (define check-args + + (define check-args ;; check for obvious argument type problems ;; caller = overall caller, head = current caller, checkers = proc or list of procs for checking args - (letrec ((every-compatible? + (letrec ((every-compatible? (lambda (type1 type2) (if (symbol? type1) (if (symbol? type2) @@ -11060,14 +11075,14 @@ (and (pair? type1) ; here any match is good (or (compatible? (car type1) type2) (any-compatible? (cdr type1) type2)))))) - - (check-checker + + (check-checker (lambda (checker at-end) - (case checker + (case checker ((integer:real?) (if at-end 'real? 'integer?)) ((integer:any?) (or at-end 'integer?)) (else)))) - + (any-checker? (lambda (types arg) (if (and (symbol? types) @@ -11076,8 +11091,8 @@ (and (pair? types) (or (any-checker? (car types) arg) (any-checker? (cdr types) arg)))))) - - (report-arg-trouble + + (report-arg-trouble (lambda (caller form head arg-number checker arg uop env) (when (and (or arg (not (eq? checker 'output-port?))) (not (and (eq? checker 'string?) @@ -11126,7 +11141,7 @@ (prettify-checker-unq checker) (truncated-list->string arg) (prettify-checker op))))))))) - + (lambda (caller head v form checkers env max-arity) (when (and *report-func-as-arg-arity-mismatch* v @@ -11138,13 +11153,13 @@ (let ((vhead (cddr source)) (head-arglist (var-arglist v)) (arg-number 1)) - + (when (pair? vhead) - (for-each + (for-each (lambda (arg) ;; only check func if head is var-member and has procedure-source (var-[initial-]value?) ;; and arg has known arity, and check only if arg(par) is car, not (for example) cadr of apply - + (let ((ari (if (symbol? arg) (arg-arity arg env) (and (len>1? arg) @@ -11159,25 +11174,25 @@ (pair? ari) (or (> (car ari) 0) (< (cdr ari) 20))) - + ;; fwalk below needs to be smart about tree walking so that ;; it does not confuse (c) in (lambda (c)...) with a call on the function c. ;; check only if current parameter name is not shadowed - + (let fwalk ((sym par) (tree vhead)) (when (pair? tree) (if (eq? (car tree) sym) (let ((args (- (length tree) 1))) (if (> (car ari) args) (lint-format "~A's parameter ~A is passed ~A and called ~A, but ~A needs ~A argument~P" caller - head par + head par (truncated-list->string arg) (truncated-list->string tree) (truncated-list->string arg) (car ari) (car ari)) (if (> args (cdr ari)) (lint-format "~A's parameter ~A is passed ~A and called ~A, but ~A takes only ~A argument~P" caller - head par + head par (truncated-list->string arg) (truncated-list->string tree) (truncated-list->string arg) @@ -11188,44 +11203,44 @@ (let ((vs ((if (symbol? (cadr tree)) caddr cadr) tree))) (if (not (lint-any? (lambda (a) (or (not (pair? a)) (eq? sym (car a)))) vs)) (fwalk sym ((if (symbol? (cadr tree)) cdddr cddr) tree)))))) - + ((do letrec letrec*) (if (and (len>1? (cdr tree)) (not (lint-any? (lambda (a) (or (not (pair? a)) (eq? sym (car a)))) (cadr tree)))) (fwalk sym (cddr tree)))) - + ((lambda lambda*) (if (and (len>1? (cdr tree)) (not (lint-any? (lambda (a) (eq? sym a)) (args->proper-list (cadr tree))))) (fwalk sym (cddr tree)))) - + ((define define-constant) (if (and (not (eq? sym (cadr tree))) (pair? (cadr tree)) (not (lint-any? (lambda (a) (eq? sym a)) (args->proper-list (cdadr tree))))) (fwalk sym (cddr tree)))) - + ((define* define-macro define-macro* define-expansion define-bacro define-bacro*) (if (and (len>1? (cdr tree)) (pair? (cadr tree)) (not (lint-any? (lambda (a) (eq? sym a)) (args->proper-list (cdadr tree))))) (fwalk sym (cddr tree)))) - + ((quote) #f) - + ((case) (if (len>1? (cdr tree)) (for-each (lambda (c) (fwalk sym (cdr c))) (cddr tree)))) - - (else + + (else (if (pair? (car tree)) (fwalk sym (car tree))) (if (pair? (cdr tree)) (for-each (lambda (p) (fwalk sym p)) (cdr tree)))))))))) - + (set! arg-number (+ arg-number 1))) (cdr form))))))) - + (when (pair? checkers) (let ((arg-number 1) (flen (- (length form) 1))) @@ -11240,21 +11255,21 @@ (if (not (or (memq op '(#f #t values)) (every-compatible? checker op))) (report-arg-trouble caller form head arg-number checker expr op env))))) - + (call-with-exit (lambda (done) - (for-each + (for-each (lambda (arg) (let ((checker (check-checker (if (pair? checkers) (car checkers) checkers) (= arg-number flen)))) ;; check-checker only fixes up :at-end cases - + (define (check-arg expr) (unless (symbol? expr) (let ((op (->lint-type expr))) (if (not (or (memq op '(#f #t values)) (every-compatible? checker op))) (report-arg-trouble caller form head arg-number checker expr op env))))) - + ;; special case checker? (if (and (symbol? checker) (not (memq checker '(unused-parameter? unused-set-parameter?))) @@ -11272,7 +11287,7 @@ (lint-format "~A's argument, ~A, should be ~A" caller head arg res))))) (lambda (type info) (set! checker #t)))))) - + (if (and (pair? arg) (pair? (car arg))) (let ((rtn (return-type (caar arg) env))) @@ -11281,20 +11296,20 @@ head (truncated-list->string arg) (caar arg) rtn)))) - + (when (or (pair? checker) (symbol? checker)) ; otherwise ignore type check on this argument (#t -> anything goes) (if arg - (case checker + (case checker ((unused-parameter?) ; (define (f5 a . b) a) (f5 1 2) (lint-format "~A's parameter ~A is not used, but a value is passed: ~A" caller head arg-number (truncated-list->string arg))) ((unused-set-parameter?) ; (define (f21 x y) (set! x 3) (+ y 1)) (f21 (+ z 1) z) - (lint-format "~A's parameter ~A's value is not used, but a value is passed: ~A" caller + (lint-format "~A's parameter ~A's value is not used, but a value is passed: ~A" caller head arg-number (truncated-list->string arg))))) - + (if (not (pair? arg)) (let ((val (cond ((not (symbol? arg)) arg) @@ -11311,11 +11326,11 @@ (let ((op (->lint-type val))) (unless (memq op '(#f #t values)) (report-arg-trouble caller form head arg-number checker arg op env))))) - - (case (car arg) + + (case (car arg) ((quote) ; '1 -> 1 (when (pair? (cdr arg)) - (let ((op (if (pair? (cadr arg)) 'list? + (let ((op (if (pair? (cadr arg)) 'list? (if (symbol? (cadr arg)) 'symbol? (->lint-type (cadr arg)))))) @@ -11323,21 +11338,21 @@ (if (not (or (memq op '(#f #t values)) (every-compatible? checker op))) (report-arg-trouble caller form head arg-number checker arg op env))))) - + ;; arg is an expression ((begin let let* letrec letrec* with-let) (let ((len (length arg))) (if (> len 1) (check-arg (and (pair? (cdr arg)) (list-ref arg (- len 1))))))) - + ((if) (if (len>1? (cdr arg)) (let ((f (if (pair? (cdddr arg)) (cadddr arg)))) (check-arg (caddr arg)) (when (and f (not (symbol? f))) (check-arg f))))) - + ((dynamic-wind catch) (if (= (length arg) 4) (let ((f (caddr arg))) @@ -11346,7 +11361,7 @@ (let ((len (length f))) (if (> len 2) (check-arg (list-ref f (- len 1))))))))) - + ((do) (if (len>1? (cdr arg)) (let ((end+res (caddr arg))) @@ -11362,7 +11377,7 @@ (not (eq? (cadr clause) '=>))) (check-arg (last-ref clause)))) (cddr arg)))) - + ((cond) (when (pair? (cdr arg)) (for-each @@ -11374,7 +11389,7 @@ (check-arg (last-ref clause))) (check-cond-arg (car clause) checker)))) (cdr arg)))) - + ((call/cc call-with-exit call-with-current-continuation) ;; find func in body (as car of list), check its arg as return value (when (and (pair? (cdr arg)) @@ -11384,7 +11399,7 @@ (when (and (pair? f) (len=1? (car f)) (symbol? (caar f))) - (define c-walk + (define c-walk (let ((rtn (caar f))) (lambda (tree) (if (len>1? tree) @@ -11394,17 +11409,17 @@ (c-walk (car tree)) (for-each (lambda (x) (if (pair? x) (c-walk x))) (cdr tree)))))))) (for-each c-walk (cdr f)))))) - - ((values) + + ((values) (cond ((not (positive? (length arg)))) - + ((null? (cdr arg)) ; #<unspecified> (if (not (any-checker? checker #<unspecified>)) (report-arg-trouble caller form head arg-number checker arg 'unspecified? env))) - + ((null? (cddr arg)) (check-arg (cadr arg))) - + (else (for-each (lambda (expr rest) @@ -11417,26 +11432,26 @@ (set! checkers (cdr checkers))))) (cdr arg) (cddr arg)) (check-arg (last-ref arg))))) - - (else + + (else (let ((op (return-type (car arg) env))) (let ((v (var-member (car arg) env))) (when (and v (not (memq form (var-history v)))) (set! (var-history v) (cons form (var-history v))) (set! (var-refenv v) env))) - + ;; checker is arg-type, op is expression type (can also be a pair) (if (and (not (memq op '(#f #t values))) (not (memq checker '(unused-parameter? unused-set-parameter?))) (or (not (every-compatible? checker op)) (and (just-constants? arg env) ; try to eval the arg - (catch #t + (catch #t (lambda () (not (any-checker? checker (eval arg)))) (lambda ignore-catch-error-args #f))))) (report-arg-trouble caller form head arg-number checker arg op env))))))) - + (if (pair? checkers) (if (null? (cdr checkers)) (done) @@ -11446,20 +11461,20 @@ (set! arg-number (+ arg-number 1)) (if (> arg-number max-arity) (done)))) (cdr form))))))))) - + (define check-unordered-exprs (let ((changers (let ((h (make-hash-table))) - (for-each (lambda (s) + (for-each (lambda (s) (hash-table-set! h s #t)) '(set! - read read-byte read-char read-line read-string + read read-byte read-char read-line read-string write write-byte write-char write-string format display newline - reverse! set-cdr! sort! string-fill! vector-fill! fill! + reverse! set-cdr! sort! string-fill! vector-fill! fill! emergency-exit exit error throw)) h))) (lambda (caller form vals env) (define (report-trouble) ; (let ((x (read-byte)) (y (read-byte))) (- x y)) - (lint-format "order of evaluation of ~A's ~A is unspecified, so ~A is trouble" caller + (lint-format "order of evaluation of ~A's ~A is unspecified, so ~A is trouble" caller (car form) (if (memq (car form) '(let letrec do)) "bindings" "arguments") (truncated-list->string form))) @@ -11476,7 +11491,7 @@ (return (report-trouble))) (case (car p) - + ((read read-char read-line read-byte) (cond ((pair? (cdr p)) (if (memq (cadr p) reads) @@ -11498,7 +11513,7 @@ (return (report-trouble))) (else (set! writes (cons () writes))))) - + ((read-string) (if (not (len>1? (cdr p))) (if (memq () reads) @@ -11507,7 +11522,7 @@ (if (memq (caddr p) reads) (return (report-trouble)) (set! reads (cons (caddr p) reads))))) - + ((display write write-char write-string write-byte) (if (pair? (cdr p)) (if (null? (cddr p)) @@ -11518,7 +11533,7 @@ (memq (caddr p) writes)) (return (report-trouble)) (set! writes (cons (caddr p) writes)))))) - + ((format) (if (and (pair? (cdr p)) (not (string? (cadr p))) @@ -11544,7 +11559,7 @@ (set! jumps (cons p jumps))))))) vals))))))) - (denote check-call + (denote check-call (let ((repeated-args-table (let ((h (make-hash-table))) (for-each (lambda (op) @@ -11578,7 +11593,7 @@ (sig (var-signature data))) (when (pair? ary) (let ((opt (cdr ary)) - (pargs (if (pair? args) + (pargs (if (pair? args) (proper-list args) (if (symbol? args) (list args) @@ -11598,9 +11613,9 @@ (if (not (or (>= call-args req) (tree-memq 'values (cdr form)) (tree-memq 'dilambda (let-ref fdata 'initial-value)))) - (lint-format "~A needs ~D argument~A: ~A" - caller head - req (if (> req 1) "s" "") + (lint-format "~A needs ~D argument~A: ~A" + caller head + req (if (> req 1) "s" "") (truncated-list->string form)))) (if (> (- call-args (keywords (cdr form) 0)) opt) ; multiple-values can make this worse, (values)=nothing doesn't apply here (lint-format "~A has too many arguments: ~A" caller head (truncated-list->string form))))) @@ -11616,10 +11631,10 @@ (not last-was-key)) ; keyarg might have key value (begin (set! have-keys (+ have-keys 1)) - (if (not (member (keyword->symbol arg) pargs + (if (not (member (keyword->symbol arg) pargs (lambda (a b) (eq? a (if (pair? b) (car b) b))))) - (lint-format "~A keyword argument ~A (in ~A) does not match any argument in ~S" caller + (lint-format "~A keyword argument ~A (in ~A) does not match any argument in ~S" caller head arg (truncated-list->string form) pargs)) (if (memq arg rest) (lint-format "~W is repeated in ~A" caller arg (cdr form))) @@ -11634,23 +11649,23 @@ (if (pair? rest) (set! rest (cdr rest)))) (cdr form)))) - + (check-args caller head data form (if (pair? sig) (cdr sig) ()) env opt) - + ;; for a complete var-history, we could run through the args here even if no type info ;; also if var passed to macro -- what to do? - + ;; look for problematic macro expansion (when (memq (let-ref fdata 'ftype) '(define-macro define-macro* defmacro defmacro*)) - + (unless (list? (let-ref fdata 'macro-ops)) (let ((syms (list () ()))) - (tree-symbol-walk ((if (memq (let-ref fdata 'ftype) '(define-macro define-macro*)) + (tree-symbol-walk ((if (memq (let-ref fdata 'ftype) '(define-macro define-macro*)) cddr cdddr) (let-ref fdata 'initial-value)) syms) (varlet fdata 'macro-locals (car syms) 'macro-ops (cadr syms)))) - + (when (or (pair? (let-ref fdata 'macro-locals)) (pair? (let-ref fdata 'macro-ops))) (let ((bad-locals ()) @@ -11676,16 +11691,16 @@ (defined? op (rootlet)))) (set! bad-ops (cons op bad-ops))))) (let-ref fdata 'macro-ops)) - + (if (equal? bad-quoted-locals '(quote)) (set! bad-quoted-locals ())) (when (or (pair? bad-locals) - (pair? bad-quoted-locals) + (pair? bad-quoted-locals) ;; (define-macro (mac8 b) `(let ((a 12)) (+ (symbol->value ,b) a))) ;; (let ((a 1)) (mac8 'a)) ;; far-fetched! (pair? bad-ops)) - (lint-format "possible problematic macro expansion:~% ~A ~A collide with subsequently defined ~A~A~A" - caller + (lint-format "possible problematic macro expansion:~% ~A ~A collide with subsequently defined ~A~A~A" + caller (truncated-list->string form) (if (or (pair? bad-locals) (pair? bad-ops)) @@ -11712,22 +11727,22 @@ (min-arity (car ary)) (max-arity (cdr ary))) (if (< args min-arity) - (lint-format "~A needs ~A~D argument~A: ~A" - caller head + (lint-format "~A needs ~A~D argument~A: ~A" + caller head (if (= min-arity max-arity) "" "at least ") min-arity - (if (> min-arity 1) "s" "") + (if (> min-arity 1) "s" "") (truncated-list->string form)) (if (and (not (setter head-value)) (> (- args (keywords (cdr form) 0)) max-arity)) (lint-format "~A has too many arguments: ~A" caller head (truncated-list->string form)))) - + (when (and (procedure? head-value) (pair? (cdr form))) ; there are args (the not-enough-args case is checked above) (if (zero? max-arity) - (lint-format "too many arguments: ~A" caller (truncated-list->string form)) + (lint-format "too many arguments: ~A" caller (truncated-list->string form)) (begin - + (for-each (lambda (arg) (if (pair? arg) (if (negative? (length arg)) @@ -11735,7 +11750,7 @@ (if (eq? (car arg) 'unquote) (lint-format "stray comma? ~A in ~A" caller arg form))))) (cdr form)) - + ;; if keywords, check that they are acceptable ;; this only applies to lambda*'s that have been previously loaded (lint doesn't create them) (let ((source (procedure-source head-value))) @@ -11747,13 +11762,13 @@ (lambda (arg) (if (and (keyword? arg) (not (eq? arg :rest)) - (not (member arg decls - (lambda (a b) + (not (member arg decls + (lambda (a b) (eq? (keyword->symbol a) (if (pair? b) (car b) b)))))) - (lint-format "~A keyword argument ~A (in ~A) does not match any argument in ~S" caller + (lint-format "~A keyword argument ~A (in ~A) does not match any argument in ~S" caller head arg (truncated-list->string form) decls))) (cdr form)))))) - + ;; we've already checked for head in the current env above (if (and (or (memq head '(eq? eqv?)) (and (= (length form) 3) @@ -11775,7 +11790,7 @@ (if (and (hash-table-ref repeated-args-table-2 head) (repeated-member? (cdr form) env)) (lint-format "it looks odd to have repeated arguments in ~A" caller (truncated-list->string form)))) - + (when (memq head '(eq? eqv?)) (define (repeated-member-with-not? lst env) (and (pair? lst) @@ -11789,19 +11804,19 @@ (repeated-member-with-not? (cdr lst) env))))) (if (repeated-member-with-not? (cdr form) env) (lint-format "this looks odd: ~A" caller (truncated-list->string form)))) - - ;; now try to check arg types + + ;; now try to check arg types (let ((arg-data (cond ((signature head-value) => cdr) (else #f)))) (if (pair? arg-data) (check-args caller head data form arg-data env max-arity)) )))))))))))))) - + (define (indirect-set? vname func arg1) (case func - ((set-car! set-cdr! vector-set! list-set! string-set!) + ((set-car! set-cdr! vector-set! list-set! string-set!) (eq? arg1 vname)) - ((set!) - (and (pair? arg1) + ((set!) + (and (pair? arg1) (eq? (car arg1) vname))) (else #f))) @@ -11810,12 +11825,12 @@ (null? e2) (eq? (car e1) (car e2))) (reverse lst) - (env-difference name (cdr e1) e2 + (env-difference name (cdr e1) e2 (if (eq? name (var-name (car e1))) lst (cons (car e1) lst))))) - (denote report-usage + (denote report-usage (let ((unwrap-cxr (hash-table 'caar '(car) 'cadr '(cdr) 'cddr '(cdr) 'cdar '(car) 'caaar '(caar car) 'caadr '(cadr cdr) 'caddr '(cddr cdr) 'cdddr '(cddr cdr) 'cdaar '(caar car) 'cddar '(cdar car) 'cadar '(cadr car) 'cdadr '(cadr cdr) @@ -11854,7 +11869,7 @@ (let ((type (if (eq? (var-definer repeat) 'parameter) 'parameter 'variable))) (case (var-definer (car cur)) ((define) - (lint-format "~A ~A ~A is redefined ~A" caller head type vn + (lint-format "~A ~A ~A is redefined ~A" caller head type vn (if (equal? head "") (if (not (tree-memq vn (var-initial-value (car cur)))) "at the top level." @@ -11864,9 +11879,9 @@ head (truncated-list->string (list 'set! vn (var-initial-value (car cur)))))))) ((define-constant) (lint-format "~A ~A ~A is later redefined as a constant" caller head type vn)) - (else + (else (lint-format "~A ~A ~A is declared twice" caller head type vn))))))))))) - + ;; -------- set->let (define (set->let caller outer-form local-var env) ;; (let ((x 0)...) ... (set! x 1)...) -> move the set! value to let init value @@ -11919,9 +11934,9 @@ (let ((sv (let ((s (copy vstr))) (set! (s (+ pos 1)) #\s) (string->symbol s)))) (set! setv (or (var-member sv vars) (var-member sv env))) - (set! newv (symbol (substring vstr 0 pos) + (set! newv (symbol (substring vstr 0 pos) (substring vstr (+ pos 4))))))))) ; +4 to include #\- - (when (and setv + (when (and setv (not (var-member newv vars)) (not (var-member newv env))) (let ((getter init) @@ -11960,31 +11975,31 @@ (var-name setv) setdots setvalue newv setdots setvalue (+ lint-left-margin 4) #\space - (lint-pp `(define ,newv (dilambda - (lambda ,getargs ,@(cddr getter)) + (lint-pp `(define ,newv (dilambda + (lambda ,getargs ,@(cddr getter)) (lambda ,setargs ,@(cddr setter))))))))))))))))))) - + ;; -------- bad-name (denote (bad-name caller head local-var otype) (let ((vname (var-name local-var))) (cond ((hash-table-ref syntaces vname) (lint-format "~A ~A named ~A is asking for trouble" caller head otype vname)) - + ((eq? vname 'l) (lint-format "\"l\" is a really bad variable name" caller)) - + ((and *report-built-in-functions-used-as-variables* (hash-table-ref built-in-functions vname)) - (lint-format "~A ~A named ~A is asking for trouble" caller + (lint-format "~A ~A named ~A is asking for trouble" caller (if (and (len=1? (var-scope local-var)) (symbol? (car (var-scope local-var)))) (car (var-scope local-var)) head) otype vname)) - + ((symbol? vname) (check-for-bad-variable-name caller vname))))) - + ;; -------- wrappable-var (define (wrappable-var caller local-var otype outer-form env) (let ((hist (var-history local-var)) @@ -12005,7 +12020,7 @@ (cdr first)) (or (code-constant? (var-initial-value local-var)) (= (tree-count vname first 2) 1)) - (lint-every? (lambda (a) + (lint-every? (lambda (a) (and (pair? a) (or (equal? first a) (and (eq? (hash-table-ref reversibles (car first)) (car a)) @@ -12028,7 +12043,7 @@ (if (> (var-ref local-var) 2) (lint-format "parameter ~A is always accessed (~A times) via ~S" caller vname (var-ref local-var) (cons new-op (cdr first)))) - (lint-format "~A is not set, and is always accessed via ~A~%~NCso its binding could probably be ~A in ~A" caller + (lint-format "~A is not set, and is always accessed via ~A~%~NCso its binding could probably be ~A in ~A" caller ;; "probably" here because the accesses could have hidden protective assumptions ;; i.e. full accessor is not valid at point of let binding vname @@ -12042,7 +12057,7 @@ (let ((hist (var-history local-var))) (when (> (length hist) 2) ; an experiment -- if all refs are by list-ref (in effect) suggest a vector (let ((init (var-initial-value local-var)) - (vname (var-name local-var))) + (vname (var-name local-var))) (when (and (pair? init) ;; list->vector (or (memq (car init) '(list make-list string->list vector->list)) @@ -12058,7 +12073,7 @@ list->vector list->string list? pair? null? quote))))) hist)) (lint-format "~A could be a vector, rather than a list" caller vname)))))) - + ;; -------- parlous-port (denote (parlous-port caller local-var outer-form) ;; look for port opened but not closed, or not used @@ -12088,7 +12103,7 @@ hist) (if (not (tree-set-memq '(close-input-port close-output-port close-port close current-output-port current-input-port) hist)) (lint-format "in ~A~% perhaps ~A is opened via ~A, but never closed" caller - (truncated-list->string outer-form) + (truncated-list->string outer-form) vname open-form) (if (= (length hist) 2) (lint-format "in ~A~% ~A is opened and closed, but never used" caller @@ -12128,7 +12143,7 @@ (eq? (caddr writer) vname) (equal? writer (caddr outer-form))) ; all this is sloppy -- maybe not worth this effort (lint-format "perhaps ~A" vname - (lists->string outer-form + (lists->string outer-form (cons 'object->string (if (eq? (car writer) 'display) (list (cadr writer) #f) @@ -12152,15 +12167,15 @@ (search (cdr e))))))) (not (and (memq (var-ftype local-var) '(define lambda define* lambda*)) (> (tree-leaves (var-initial-value local-var)) 80)))) - (format outport "~NC~A~A is ~A only in ~A~%" - lint-left-margin #\space + (format outport "~NC~A~A is ~A only in ~A~%" + lint-left-margin #\space (if (eq? caller top-level:) "top-level: " "") - vname + vname (if (memq (var-ftype local-var) '(define lambda define* lambda*)) "called" "used") (car scope)))))) - + ;; -------- unused-var ;; (eval ...) in the form may have hidden var refs confusing this check (define (unused-var caller head local-var otype) @@ -12180,17 +12195,17 @@ (var-history local-var)))) (if (pair? sets) (if (null? (cdr sets)) - (lint-format "~A set, but not used: ~A" caller + (lint-format "~A set, but not used: ~A" caller vname (truncated-list->string (car sets))) - (lint-format "~A set, but not used: ~{~S~^ ~}" caller + (lint-format "~A set, but not used: ~{~S~^ ~}" caller vname sets)) - (lint-format "~A set, but not used: ~A from ~A" caller + (lint-format "~A set, but not used: ~A from ~A" caller vname (truncated-list->string (var-initial-value local-var)) (var-definer local-var)))) - + ;; not ref'd or set (unless (memq vname '(+documentation+ +signature+ +setter+ +iterator+ define-animal)) (let ((val (truncated-list->string - (if (pair? (var-history local-var)) + (if (pair? (var-history local-var)) (car (var-history local-var)) (var-initial-value local-var)))) (def (var-definer local-var))) @@ -12223,18 +12238,18 @@ (if (keyword? (caar ref)) (set! local-env ref) (crawler (cdr ref)))))) - + (when (and (pair? reflet) (pair? deflet) (not (eq? local-env reflet)) - (or deffunc + (or deffunc (code-constant? source)) ;; code-constant? is very restrictive, but side-effect? leaves too many complications: ;; (let ((a (car b))) (set! b c) (let ...)) (let ((target (car deflet))) ; the enclosing env (let crawler ((ref reflet)) ; the var's restricted env (and (pair? ref) - (or (eq? (car ref) target) + (or (eq? (car ref) target) (and (not (eq? (caar ref) :do)) ; try not to move the variable inside a loop (not (and (eq? (caar ref) :let) (symbol? (cadr (var-initial-value (car ref)))))) @@ -12259,7 +12274,7 @@ (not (tree-set-memq (let remove-args ((args let-args) (nargs ())) (if (null? args) nargs - (remove-args (cdr args) + (remove-args (cdr args) (if (memq (car args) source-args) nargs (cons (car args) nargs))))) @@ -12275,6 +12290,8 @@ (or (memq (car makval) '(define define* lambda lambda*)) (and (memq (car makval) '(let let*)) ; check last var in let*, any var in let (pair? (cadr makval)) ; not a named let + (or (eq? (caddr makval) refval) ; not a triply nested let + (not (memq (caaddr makval) '(let let*)))) (not (and (pair? (caddr makval)) ; not lambda's closure (null? (cdddr makval)) (memq (caaddr makval) '(lambda lambda*))))))) @@ -12287,7 +12304,7 @@ ((if (pair? (caadr makval)) caadr cadr) makval) makval))) (local-line-number (caadr refval)) - (truncated-lists->string + (truncated-lists->string makval (let ((new-var&val (list vname (if (not deffunc) @@ -12337,9 +12354,9 @@ (and (pair? (cadr call)) (eq? (caadr call) 'not) (eq? (cadadr call) vname)))) - (lint-format "~A is never #f, so ~A" caller - vname - (lists->string + (lint-format "~A is never #f, so ~A" caller + vname + (lists->string call (if (eq? vname (cadr call)) (case func @@ -12350,10 +12367,10 @@ ((if) (if (pair? (cdddr call)) (cadddr call))) ((when) #<unspecified>) ((unless) (if (pair? (cdddr call)) (cons 'begin (cddr call)) (caddr call))))))))) - + ;; -------- arg-mismatch (define (arg-mismatch caller vname vtype func call e) - (let ((p (memq vname (cdr call)))) + (let ((p (memq vname (cdr call)))) (when (pair? p) (let ((sig (arg-signature func e)) (pos (- (length call) (length p)))) @@ -12369,9 +12386,9 @@ (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) + 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 @@ -12380,13 +12397,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))) (lint-format "~A is ~A, so use ~A, not ~A" caller @@ -12408,7 +12425,7 @@ (unless (compatible? vtype func) (lint-format "~A is ~A, so ~A is #f" caller vname (prettify-checker-unq vtype) call))) - + (case func ;; need a way to mark exported variables so they won't be checked in this process ;; case can happen here, but it never seems to trigger a type error @@ -12420,7 +12437,7 @@ (code-constant? (caddr call)) (not (compatible? vtype (->lint-type (caddr call)))))) (lint-format "~A is ~A, so ~A is #f" caller vname (prettify-checker-unq vtype) call))) - + ((and or) (when (let amidst? ((lst call)) (and (len>1? lst) @@ -12428,14 +12445,14 @@ (amidst? (cdr lst))))) ; don't clobber possible trailing vname (returned by expression) (lint-format "~A is ~A, so ~A" caller ; (let ((x 1)) (and x (< x 1))) -> (< x 1) vname (prettify-checker-unq vtype) - (lists->string call + (lists->string call (simplify-boolean (remove-one vname call) () () vars))))) ((not) (if (eq? vname (cadr call)) (lint-format "~A is ~A, so ~A" caller vname (prettify-checker-unq vtype) (lists->string call #f)))) - + ((/) (if (and (number? (var-initial-value local-var)) (zero? (var-initial-value local-var)) (zero? (var-set local-var)) @@ -12443,12 +12460,12 @@ (lint-format "~A is ~A, so ~A is an error" caller vname (var-initial-value local-var) call)))))) - + ;; -------- eqx-type-check (define (eqx-type-check caller local-var vtype func call call-arg1) (let ((vname (var-name local-var))) (if (memq func '(eq? equal?)) - (lint-format "~A is ~A, so ~A ~A be eqv? in ~A" caller + (lint-format "~A is ~A, so ~A ~A be eqv? in ~A" caller vname (prettify-checker-unq vtype) func (if (eq? func 'eq?) "should" "could") call)) @@ -12458,10 +12475,10 @@ (eq? vname call-arg1) (null? (cddr call)) (hash-table-ref booleans func)) - (let ((val (catch #t + (let ((val (catch #t (lambda () ((symbol->value func (rootlet)) (var-initial-value local-var))) - (lambda args + (lambda args 'error)))) (if (boolean? val) (lint-format "~A is ~A, so ~A is ~A" caller vname (var-initial-value local-var) call val)))))) @@ -12478,27 +12495,27 @@ (lint-format "~A is ~A, but the index ~A is ~A" caller vname (prettify-checker-unq vtype) call-arg1 (prettify-checker (->lint-type call-arg1)))) - + (if (integer? call-arg1) (if (negative? call-arg1) (lint-format "~A's index ~A is negative" caller vname call-arg1) (if (zero? (var-set local-var)) (let ((lim (cond ((code-constant? init) (length init)) - + ((memq (car init) '(vector float-vector int-vector string list byte-vector)) (- (length init) 1)) - + (else (and (pair? (cdr init)) (integer? (cadr init)) - (memq (car init) '(make-vector make-float-vector make-int-vector + (memq (car init) '(make-vector make-float-vector make-int-vector make-string make-list make-byte-vector)) (cadr init)))))) (if (and (real? lim) (>= call-arg1 lim)) (lint-format "~A has length ~A, but index is ~A" caller vname lim call-arg1)))))))) - + (when (eq? func 'implicit-set) ;; ref is already checked in other history entries (let ((ref-type (case vtype @@ -12511,9 +12528,9 @@ (if (not (compatible? val-type ref-type)) (lint-format "~A wants ~A, but the value in ~A is ~A" caller vname (prettify-checker-unq ref-type) - (cons 'set! (cdr call)) + (cons 'set! (cdr call)) (prettify-checker val-type)))))))))) - + ;; -------- duplicated-calls (define (duplicated-calls caller local-var env) (let ((vname (var-name local-var))) @@ -12547,8 +12564,8 @@ (eq? p vname))) (cdar call)))) (unless intro - (let ((str (format #f "~NC~A: ~A is not set, but " - lint-left-margin #\space + (let ((str (format #f "~NC~A: ~A is not set, but " + lint-left-margin #\space caller vname))) (set! column (length str)) (display str outport)) @@ -12561,12 +12578,12 @@ (set! calls 1)) (set! calls (+ calls 1))) (set! column (+ column (length str) 12)) - (format outport "~A~A occurs ~A times" + (format outport "~A~A occurs ~A times" (if (> calls 1) ", " "") str (cdr call))))) h) (if intro (newline outport))))))) - + ;; -------- repeated-args (define (repeated-args caller local-var) ;; check for function parameters whose values never change and are not just symbols @@ -12628,8 +12645,8 @@ (set! unused new-unused))))) (cddr p)))) (lint-format "~A parameter ~A is a function whose parameter~P ~{~A~^, ~} ~A never used" caller - vname (car p) - (length unused) + vname (car p) + (length unused) (map (lambda (p) (+ p 1)) (reverse unused)) (if (> (length unused) 1) "are" "is"))))))))) pars))))) @@ -12642,13 +12659,13 @@ ;; and any definition wipes out the accumulated pre-def uses -- this should be by closed-body and ;; ignore local defines (i.e. really only define[x] propagates backwards) -- changing this is ;; tricky (fools current unused func arg + value message for example). - + (defined-twice caller head vars) ;; main loop -- goes to end (let ((old-line-number line-number) (outer-form (cond ((var-member :let env) => var-initial-value) (else #f)))) - (for-each + (for-each (lambda (local-var) (let ((otype (if (eq? (var-definer local-var) 'parameter) 'parameter 'variable))) ;; (var-name local-var) can be a pair (probably a bug): '(setter object-info) @@ -12680,19 +12697,19 @@ (reducible-scope caller local-var otype env) (if (and (eq? (var-ftype local-var) 'define-expansion) (not (eq? caller top-level:))) - (format outport "~NCdefine-expansion for ~A is not at the top-level, so it is simply define-macro~%" + (format outport "~NCdefine-expansion for ~A is not at the top-level, so it is simply define-macro~%" lint-left-margin #\space (var-name local-var))) - + ;; define* -> define is tricky: multiple-values, renaming possibilities, etc ;; redundant vars are hard to find -- tons of false positives - + (parlous-port caller local-var outer-form) (parlous-output-string local-var outer-form) - + (if (zero? (var-ref local-var)) (unused-var caller head local-var otype) - (let ((vtype #f)) + (let ((vtype #f)) (move-var-inward caller local-var) (when (and (not (memq (var-definer local-var) '(parameter named-let named-let*))) @@ -12705,25 +12722,25 @@ (let ((lit? (and (code-constant? (var-initial-value local-var)) (not (quoted-null? (var-initial-value local-var)))))) ; something fishy is going on... - + ;; check each use of the local var (do ((clause (var-history local-var) (cdr clause))) ((null? (cdr clause))) ; ignore the initial value which depends on a different env (let ((call (car clause))) (if (pair? call) (set! line-number (or (pair-line-number call) (max line-number 0)))) - + (when (pair? call) (let ((func (car call)) (vname (var-name local-var)) (call-arg1 (and (pair? (cdr call)) (cadr call)))) - + ;; check for assignments into constants (if (and lit? (indirect-set? vname func call-arg1)) - (lint-format "~A's value, ~S, is a literal constant, so this set! is trouble: ~A" caller + (lint-format "~A's value, ~S, is a literal constant, so this set! is trouble: ~A" caller vname (var-initial-value local-var) (truncated-list->string call))) - + (when (symbol? vtype) (pointless-if caller vname vtype func call) @@ -12739,13 +12756,13 @@ (memq vtype '(char? number? integer? real? float? rational? complex?))) (eqx-type-check caller local-var vtype func call call-arg1))) - ;; (x 1) where x is not a sequence is tricky: + ;; (x 1) where x is not a sequence is tricky: ;; problem here is that e.g. let-values|fluid-let|define-record-structure name|field list becomes a call! (implicit-type-checks caller local-var vtype func call call-arg1))))))) - + (duplicated-calls caller local-var env) (repeated-args caller local-var))))) - + ;; vars with multiple incompatible ascertainable types don't happen much and obvious type errors are extremely rare (parlous-return caller local-var env)))) vars) @@ -12816,11 +12833,11 @@ (cond ((side-effect? last-expr env) (if (pair? last-expr) (check-returns caller last-expr env))) - + (has-else (if (or (pair? (cddr c)) (eq? (car f) 'cond)) - (lint-format "this ~A clause's result could be omitted" caller + (lint-format "this ~A clause's result could be omitted" caller (truncated-list->string c)) (if (not (memq last-expr '(#f #t #<unspecified>))) ; it's not already obvious (lint-format "this ~A clause's result could be simply #f" caller @@ -12830,19 +12847,19 @@ (not (lint-any? (lambda (p) (side-effect? p env)) (cdr c))))) (lint-format "this case clause can be omitted: ~A" caller (truncated-list->string c))) - + (else (lint-format "this is pointless: ~A in ~A" caller (truncated-list->string last-expr) (truncated-list->string c))))))) ((if (eq? (car f) 'cond) cdr cddr) f))))) - + ((let let*) (if (and (len>1? (cdr f)) (not (symbol? (cadr f)))) (let ((last-expr (last-ref f))) (if (side-effect? last-expr env) (if (pair? last-expr) - (check-returns caller last-expr env)) + (check-returns caller last-expr env)) (lint-format "this is pointless~A: ~A in ~A" caller (local-line-number last-expr) (truncated-list->string last-expr) @@ -12891,8 +12908,8 @@ (side-effect? returned env)) (check-returns caller returned env) ;; (begin (do ((i 0 (+ i 1))) ((= i 10) i) (display i)) x) - (lint-format "~A: result ~A~A is not used" caller - (truncated-list->string f) + (lint-format "~A: result ~A~A is not used" caller + (truncated-list->string f) (truncated-list->string returned) (local-line-number returned)))))) ((call-with-exit) @@ -12909,7 +12926,7 @@ (pair? (cddr tree)))) ;; (begin (call-with-exit (lambda (quit) (if (< x 0) (quit (+ x 1))) (display x))) (+ x 2)) (lint-format "th~A call-with-exit return value~A will be ignored: ~A" caller - (if (pair? (cddr tree)) + (if (pair? (cddr tree)) (values "ese" "s") (values "is" "")) tree)) @@ -12930,7 +12947,7 @@ ((format) (if (and (pair? (cdr f)) (eq? (cadr f) #t)) ; (let () (format #t "~A" x) x) - (lint-format "perhaps use () with format since the string value is discarded:~% ~A" + (lint-format "perhaps use () with format since the string value is discarded:~% ~A" caller (cons 'format (cons () (cddr f)))))))))) (define lint-current-form #f) @@ -12972,9 +12989,9 @@ (reverse args) (loop (cdr pars) (if (pair? vals) - (values (cdr vals) + (values (cdr vals) (cons (list ((if (pair? (car pars)) caar car) pars) (car vals)) args)) - (values () + (values () (cons (if (pair? (car pars)) (car pars) (list (car pars) #f)) args)))))))) (new-let (if (eq? (caar body) 'define) 'let 'let*))) (if (and (len>1? fbody) @@ -12990,7 +13007,7 @@ `(... ,@(tree-subst `(let () ,@fbody) call (cdr body)))) `(... ,@(tree-subst `(let ,new-args ,@fbody) call (cdr body)))) `(... ,@(tree-subst `(,new-let ,fname ,new-args ,@fbody) call (cdr body)))))))))))) - + ;; look for non-function defines at the start of the body and use let(*) instead ;; we're in a closed body here, so the define can't propagate backwards (let ((first-expr (car body))) @@ -13023,7 +13040,7 @@ ;; define acts like letrec(*), not let -- reference to name in lambda body is current name (let ((expr (cdar p))) (set! vars&vals (cons (if (< (tree-leaves (cdr expr)) 12) - expr + expr (list (car expr) '...)) vars&vals)) (if (tree-set-memq names (cdr expr)) @@ -13079,7 +13096,7 @@ (p (cdr q) (cdr p)) (i (+ k 1) (+ i 1))) ((null? p) - (if (and (< k lastref (+ k 2)) + (if (and (< k lastref (+ k 2)) (pair? (list-ref body (+ k 1)))) (let ((end-dots (if (< lastref (- len 1)) '(...) ())) (letx (if (tree-memq name (cddr expr)) 'letrec 'let)) @@ -13091,14 +13108,14 @@ (tree-memq name (car s)))) (not (eq? s q))))))) (cond (seen-earlier) - + ((not (eq? (car use-expr) 'define)) (let-temporarily ((target-line-length 120)) ;; (... (define f14 (lambda (x y) (if (positive? x) (+ x y) y))) (+ (f11 1 2) (f14 1 2))) -> ;; (... (let ((f14 (lambda (x y) (if (positive? x) (+ x y) y)))) (+ (f11 1 2) (f14 1 2)))) (lint-format "the scope of ~A could be reduced: ~A" caller name (truncated-lists->string (cons '... (cons expr (cons use-expr end-dots))) - (cons '... (cons (list letx + (cons '... (cons (list letx (list (list name (caddr expr))) use-expr) end-dots)))))) @@ -13163,7 +13180,7 @@ (lint-format "the scope of ~A could be reduced: ~A" caller name (let-temporarily ((target-line-length 120)) (truncated-lists->string `(... ,expr ,use-expr1 ,use-expr2 ,@end-dots) - `(... (,letx ((,name ,(caddr expr))) + `(... (,letx ((,name ,(caddr expr))) ,use-expr1 ,use-expr2) ,@end-dots))))))))))) @@ -13214,14 +13231,14 @@ (not (tree-memq (cadr prev-f) (cadr f)))) (eq? (car f) 'let*))) (lint-format "perhaps ~A" caller - (lists->string + (lists->string `(... ,prev-f ,f ,@(if (null? (cdr fs)) () '(...))) `(... (,(car f) (,(cdr prev-f) ,@(cadr f)) ...) ,@(if (null? (cdr fs)) () '(...)))))))) (set! prev-f f)))))))) - + ;; definer as last in body is rare outside let-syntax, and tricky -- only one clear optimizable case found (lint-walk-open-body caller head body env)) - + (define lint-walk-open-body (let () @@ -13233,7 +13250,7 @@ (memq (cadr tree) set)) (tree-change-member set (car tree)) (tree-change-member set (cdr tree))))) - + ;; -------- combine-successive-ifs (define (combine-successive-ifs caller fs prev-f f env) (let ((test1 (cadr prev-f)) @@ -13242,13 +13259,13 @@ ;; (if A...) (if (not A)...) happens very rarely -- only two rewritable hits (let ((equal-tests ; test1 = test2 [check for side-effects already] (lambda () - + (if (and (pair? (caddr prev-f)) (escape? (caddr prev-f) env)) ;; (begin (if x (error 'oops)) (if x y)) -> begin: x is #f in (if x y) -- this never happens - (lint-format "~A is #f in ~A" caller + (lint-format "~A is #f in ~A" caller test2 (truncated-list->string f))) - + ;; (... (if (and A B) (f C)) (if (and B A) (g E) (h F)) ...) -> (... (if (and A B) (begin (f C) (g E)) (begin (h F))) ...) (lint-format "perhaps ~A" caller (lists->string @@ -13277,7 +13294,7 @@ `(,f-func ,test1 ; f-func = when|unless ,@(cddr prev-f) ,@(cddr f))))))) - (test1-in-test2 + (test1-in-test2 (lambda () (if (null? (cddr test2)) (set! test2 (cadr test2))) @@ -13289,7 +13306,7 @@ `(... (when ,test1 ,@(cddr prev-f) (when ,test2 - ,@(cddr f))) + ,@(cddr f))) ,@(if (null? (cdr fs)) () '(...))) ;; prev-f is 2-arm if and f is when or 1-arm if (the other case is too ugly) `(... (if ,test1 @@ -13298,8 +13315,8 @@ (when ,test2 ,@(cddr f))) ,@(cdddr prev-f)) ...)))))) - - (test2-in-test1 + + (test2-in-test1 (lambda () (if (null? (cddr test1)) (set! test1 (cadr test1))) @@ -13329,9 +13346,9 @@ (equal-tests) ;; (if A b) (if A c) -> (when A b (if A c))) ;; (when A b) (when A c) -> (when A b (when A c)) - (if (and (or (not (eq? (car prev-f) 'if)) + (if (and (or (not (eq? (car prev-f) 'if)) (= (length prev-f) 3)) - (or (not (eq? f-func 'if)) + (or (not (eq? f-func 'if)) (= (length f) 3))) (lint-format "perhaps ~A" caller (lists->string (list '... prev-f f '...) @@ -13347,9 +13364,9 @@ ...)))))))) ((or (eq? f-func 'unless) (eq? (car prev-f) 'unless))) ; too hard! - + ;; look for test1 as member of test2 (so we can use test1 as the outer test) - ((and (pair? test2) + ((and (pair? test2) (eq? (car test2) 'and) (member test1 (cdr test2)) (or (eq? f-func 'when) ; f has to be when or 1-arm if @@ -13361,9 +13378,9 @@ (not (tree-change-member (gather-symbols test1) (cddr prev-f)))) (set! test2 (remove-one test1 test2)) (test1-in-test2)) - + ;; look for test2 as member of test1 - ((and (pair? test1) + ((and (pair? test1) (eq? (car test1) 'and) (member test2 (cdr test1)) (or (eq? (car prev-f) 'when) ; prev-f has to be when or 1-arm if @@ -13372,7 +13389,7 @@ (not (tree-change-member (gather-symbols test2) (cddr prev-f)))) (set! test1 (remove-one test2 test1)) (test2-in-test1)) - + ;; look for some intersection of test1 and test2 ((and (pair? test1) (pair? test2) @@ -13413,7 +13430,7 @@ (set! test2 (cons 'and (reverse intersection))) (set! test1 (cons 'and (reverse new-test1))) (test2-in-test1)) - + (when (and (or (eq? f-func 'when) (null? (cdddr f))) (or (eq? (car prev-f) 'when) @@ -13423,10 +13440,10 @@ (let ((outer-test (if (null? (cdr intersection)) (car intersection) (cons 'and (reverse intersection))))) - (set! new-test1 (if (null? (cdr new-test1)) + (set! new-test1 (if (null? (cdr new-test1)) (car new-test1) (cons 'and (reverse new-test1)))) - (set! new-test2 (if (null? (cdr new-test2)) + (set! new-test2 (if (null? (cdr new-test2)) (car new-test2) (cons 'and (reverse new-test2)))) (lists->string (list '... prev-f f '...) @@ -13436,7 +13453,7 @@ (when ,new-test2 ,@(cddr f))) ,@(if (null? (cdr fs)) () '(...)))))))))))))))) - + ;; -------- ifs->case -------- (define (ifs->case caller fs prev-f f) ;; successive if's that can be combined into case @@ -13487,12 +13504,12 @@ (let ((step 'i)) (if (tree-memq step prev-f) (set! step (find-unique-name prev-f))) - (lint-format "perhaps ~A... ->~%~NC(do ((~A 0 (+ ~A 1))) ((= ~A ~D)) ~A)" caller + (lint-format "perhaps ~A... ->~%~NC(do ((~A 0 (+ ~A 1))) ((= ~A ~D)) ~A)" caller (truncated-list->string prev-f) pp-left-margin #\space step step step (+ repeats 1) ; only use of repeats prev-f)) - + (let ((args ()) (constants? #t) (func-name (car prev-f)) @@ -13503,7 +13520,7 @@ ((eq? p fs-end)) (set! args (cons (list-ref (car p) repeat-arg) args)) (if constants? (set! constants? (code-constant? (car args))))) - + (let ((func (if (and (= repeat-arg 1) (null? (cddar start-repeats))) func-name @@ -13524,7 +13541,7 @@ (procedure? (symbol->value func-name *e*))) ;; (let () (write-byte 0) (write-byte 1) (write-byte 2) (write-byte 3) (write-byte 4)) -> ;; (for-each write-byte '(0 1 2 3 4)) - (lint-format "perhaps ~A... ->~%~NC(for-each ~S (vector ~{~S~^ ~}))" caller + (lint-format "perhaps ~A... ->~%~NC(for-each ~S (vector ~{~S~^ ~}))" caller ;; vector rather than list because it is easier on the GC (list copies in s7) (truncated-list->string (car start-repeats)) pp-left-margin #\space @@ -13535,9 +13552,9 @@ ;; (let () (writ 0) (writ 1) (writ 2) (writ 3) (writ (* x 2))) -> (for-each writ (vector 0 1 2 3 (* x 2))) (lint-format "assuming ~A is not a macro, perhaps ~A" caller func-name - (lists->string (list '... (car start-repeats) '...) + (lists->string (list '... (car start-repeats) '...) (list 'for-each func (cons 'vector (reverse args))))))))))))) - + ;; -------- set-cxr->copy -------- (define (set-cxr->copy caller prev-f f ctr len) ;; set-car! + set-cdr! here is usually "clever" code assuming eq?ness, so we can't rewrite it using cons @@ -13554,19 +13571,19 @@ (pair? ncdr) (eq? (car ncdr) 'cdr) (equal? (cadr ncar) (cadr ncdr))) - (lint-format "perhaps ~A~A ~A~A -> ~A" caller - (if (= ctr 0) "" "...") + (lint-format "perhaps ~A~A ~A~A -> ~A" caller + (if (= ctr 0) "" "...") (truncated-list->string prev-f) (truncated-list->string f) (if (= ctr (- len 1)) "" "...") (list 'copy (cadr ncar) (cadr f)))))))) - + ;; -------- combine-sets -------- (define (combine-sets caller prev-f f env) (let ((arg1 (caddr prev-f)) (arg2 (caddr f)) (settee (cadr f))) - + (if (and (or (and (equal? settee arg1) ; (set! x y) (set! y x) (equal? arg2 (cadr prev-f))) (and (equal? settee (cadr prev-f)) ; (set! x y) (set! x y) @@ -13574,7 +13591,7 @@ (not (tree-equal-member settee arg2))) (lint-format "this pair of set!s looks odd: ~A" caller (list '... prev-f f '...))) - + (cond ((not (eq? settee (cadr prev-f))) (if (and (symbol? (cadr prev-f)) ; (set! x (A)) (set! y (A)) -> (set! x (A)) (set! y x) (unquoted-pair? arg1) ; maybe more trouble than it's worth @@ -13584,15 +13601,15 @@ (not (side-effect? arg1 env)) (not (maker? arg1))) (lint-format "perhaps ~A" caller (lists->string f (list 'set! settee (cadr prev-f)))))) - + ((not (and (pair? arg2) ; (set! x 0) (set! x 1) -> "this could be omitted: (set! x 0)" (tree-memq settee arg2))) (if (not (or (side-effect? arg1 env) (side-effect? arg2 env))) (lint-format "this could be omitted: ~A" caller prev-f))) - + ((not (pair? arg2))) - + ((and (pair? arg1) ; (set! x (cons 1 z)) (set! x (cons 2 x)) -> (set! x (cons 2 (cons 1 z))) (eq? (car arg1) 'cons) (eq? (car arg2) 'cons) @@ -13601,7 +13618,7 @@ (lint-format "perhaps ~A ~A -> ~A" caller prev-f f `(set! ,settee (cons ,(cadr arg2) (cons ,@(cdr arg1)))))) - + ((and (pair? arg1) ; (set! x (append x y)) (set! x (append x z)) -> (set! x (append x y z)) (eq? (car arg1) 'append) (eq? (car arg2) 'append) @@ -13612,14 +13629,14 @@ (lint-format "perhaps ~A ~A -> ~A" caller prev-f f `(set! ,settee (append ,settee ,@(cddr arg1) ,@(cddr arg2))))) - + ((and (= (tree-count settee arg2 2) 1) ; (set! x y) (set! x (+ x 1)) -> (set! x (+ y 1)) (or (not (pair? arg1)) (< (tree-leaves arg1) 5))) - (lint-format "perhaps ~A ~A ->~%~NC~A" caller + (lint-format "perhaps ~A ~A ->~%~NC~A" caller prev-f f pp-left-margin #\space (object->string (list 'set! settee (tree-subst arg1 settee arg2)))))))) - + ;; -------- redundant-set -------- (define (redundant-set caller prev-f f env) (cond ((and (eq? f #t) @@ -13632,12 +13649,12 @@ (if (not (or (memq (car sig) '(#t values boolean)) (and (pair? (car sig)) (memq 'boolean (car sig))))) - (lint-format "#t is probably redundant; ~A can't return #f" caller + (lint-format "#t is probably redundant; ~A can't return #f" caller ((if (eq? (car prev-f) 'set!) caaddr car) prev-f))))) ((and (member f '(#<unspecified> (values))) (memq (car prev-f) '(for-each newline close-input-port close-output-port close-port))) (lint-format "~A is redundant; ~A returns #<unspecified>" caller f (car prev-f))))) - + ;; -------- redundant-return -------- (define (redundant-return caller body prev-f f env) (case (car prev-f) @@ -13645,13 +13662,13 @@ (if (and (equal? f (cadr prev-f)) (not (side-effect? f env))) ;; (cond ((= x y) y) (else (begin (display x) x))) - (lint-format "~A returns its first argument, so this could be omitted: ~A" caller + (lint-format "~A returns its first argument, so this could be omitted: ~A" caller (car prev-f) (truncated-list->string f)))) - + ((vector-set! float-vector-set! int-vector-set! string-set! list-set! hash-table-set! let-set! set-car! set-cdr!) (if (equal? f (last-ref prev-f)) ;; (begin (vector-set! x 0 (* y 2)) (* y 2)) - (lint-format "~A returns the new value, so this could be omitted: ~A" caller + (lint-format "~A returns the new value, so this could be omitted: ~A" caller (car prev-f) (truncated-list->string f))) (if (and (len>1? f) (eq? (cadr prev-f) (cadr f)) @@ -13679,17 +13696,17 @@ ;; (let ((x (list 1 2))) (set-car! x 3) (car x)) (lint-format "~A returns the new value, so this could be omitted: ~A" caller (car prev-f) (truncated-list->string f)))) - + ((copy) (if (or (and (null? (cddr prev-f)) (equal? (cadr prev-f) f)) (and (len=1? (cddr prev-f)) (equal? (caddr prev-f) f))) - (lint-format "~A returns the new value, so ~A could be omitted" caller + (lint-format "~A returns the new value, so ~A could be omitted" caller (truncated-list->string prev-f) (truncated-list->string f)))) - - ((set! define define* define-macro define-constant define-macro* + + ((set! define define* define-macro define-constant define-macro* defmacro defmacro* define-expansion define-bacro define-bacro*) (cond ((not (and (pair? (cddr prev-f)) ; (set! ((L 1) 2)) an error, but lint should keep going (or (and (equal? (caddr prev-f) f) ; (begin ... (set! x (...)) (...)) @@ -13699,16 +13716,16 @@ (and (not (eq? (car prev-f) 'set!)) (pair? (cadr prev-f)) ; (begin ... (define (x...)...) x) (eq? f (caadr prev-f))))))) - + ((not (memq (car prev-f) '(define define*))) (lint-format "~A returns the new value, so this could be omitted: ~A" caller (car prev-f) (truncated-list->string f))) - + ((symbol? (cadr prev-f)) (lint-format "perhaps omit ~A and return ~A" caller (cadr prev-f) (caddr prev-f))) - + ((= (tree-count f body 3) 2) ;; (let () (define (f1 x) (+ x 1)) f1) -> (lambda (x) ...) (lint-format "perhaps omit ~A, and change ~A" caller @@ -13717,15 +13734,15 @@ (list (if (eq? (car prev-f) 'define) 'lambda 'lambda*) (cdadr prev-f) '...)))) - + (else (lint-format "~A returns the new value, so this could be omitted: ~A" caller ; possibly still not right if letrec? (car prev-f) f)))))) - + ;; -------- check-shadows -------- (define (check-shadows caller head f env) ;; mid-body defines happen by the million, so resistance is futile - (let ((vname (if (symbol? (cadr f)) - (cadr f) + (let ((vname (if (symbol? (cadr f)) + (cadr f) (and (pair? (cadr f)) (symbol? (caadr f)) (caadr f))))) @@ -13752,7 +13769,7 @@ (lint-format "~A makes the rest of the body unreachable: ~A" caller (truncated-list->string f) (truncated-list->string (list '... (cadr fs) '...)))))) - + ;; -------- displays->format -------- (define (displays->format caller prev-f f dpy-f dpy-case dpy-len) ;; display sequence starts at dpy-start, goes to ctr (prev-f) unless not dpy-case @@ -13762,11 +13779,11 @@ (dpy-last (if (not dpy-case) prev-f f)) (op (write-port (car dpy-f))) (exprs (make-list (if dpy-case (+ dpy-len 1) dpy-len) ()))) - + (define* (gather-format str (arg :unset)) (set! ctrl-string (string-append ctrl-string str)) (unless (eq? arg :unset) (set! args (cons arg args)))) - + (call-with-exit (lambda (done) (for-each @@ -13812,7 +13829,7 @@ (truncated-list->string `(let ((,new-var ,(if (pair? (cadr f)) (cons (if (eq? (car f) 'define) 'lambda 'lambda*) - (cons (cdadr f) + (cons (cdadr f) (cddr f))) (caddr f)))) ,@(cdr fs))))))) @@ -13823,7 +13840,7 @@ ;; walk a body (a list of forms, the value of the last of which might be returned) (if (not (proper-list? body)) (lint-format "stray dot? ~A" caller (truncated-list->string body)) - + (let ((len (length body)) (old-current-form lint-current-form) (old-mid-form lint-mid-form) @@ -13844,7 +13861,7 @@ ((not (pair? fs))) (let ((f (car fs))) (when (len>1? f) - + ;; successive combinable conds/cases/dos are tricky and rare (when (and *report-shadowed-variables* (eq? (car f) 'define)) @@ -13857,7 +13874,7 @@ (when (and (pair? prev-f) (memq (car f) '(define define*))) (define->let caller fs prev-f f)))) - + (let ((feq (and (pair? prev-f) (pair? f) (eq? (car f) (car prev-f)) @@ -13865,7 +13882,7 @@ (do ((fp (cdr f) (cdr fp)) (pp (cdr prev-f) (cdr pp)) (i 1 (+ i 1))) - ((or (and (null? pp) + ((or (and (null? pp) (null? fp)) (not (pair? pp)) (not (pair? fp)) @@ -13888,7 +13905,7 @@ (set! repeats 0) (set! repeat-arg 0) (set! start-repeats fs))) - + (if (pair? f) (begin (set! f-len (length f)) @@ -13898,21 +13915,21 @@ (if (symbol? f) (set-ref f caller f env)) (set! f-len 0))) - + (when (= f-len prev-len 3) (set-cxr->copy caller prev-f f ctr len) (if (not rewrote-already) (set! rewrote-already (ifs->case caller fs prev-f f))) - + (when (and (eq? (car f) 'set!) ; other such funcs like fill! don't seem to happen (eq? (car prev-f) 'set!)) (combine-sets caller prev-f f env))) - (if (< ctr (- len 1)) + (if (< ctr (- len 1)) (begin ; f is not the last form, so its value is ignored (check-escape caller fs f (= ctr (- len 2)) env) (check-returns caller f env)) ; look for code that has no effect (not returned, no side-effect) - + ;; here f is the last form in the body (when (pair? prev-f) (redundant-set caller prev-f f env) @@ -13934,15 +13951,15 @@ (displays->format caller prev-f f dpy-f dpy-case (- ctr dpy-start)) (set! dpy-start #f)) (unless dpy-case (set! dpy-start #f))) - + (if (and macdef (pair? f) (tree-memq 'unquote f)) (lint-format "~A probably has too many unquotes: ~A" caller head (truncated-list->string f))) - + (set! prev-f f) (set! prev-len f-len) - + (set! lint-current-form f) (if (= ctr (- len 1)) (set! env (lint-walk caller f env)) @@ -13954,7 +13971,7 @@ (set! env e))))) (set! lint-current-form #f) (set! lint-mid-form #f) - + ;; need to put off this ref tick until we have a var for it (lint-walk above) (when (and (= ctr (- len 1)) (len>1? f)) @@ -13967,38 +13984,38 @@ (set! lint-mid-form old-mid-form) (set! lint-current-form old-current-form))) env))) - - + + (define (return-walker last func) (if (not (and (pair? last) (proper-list? last))) (func last) (case (car last) - + ((begin let let* letrec letrec* when unless with-baffle with-let) (when (pair? (cdr last)) (return-walker (last-ref last) func))) - + ((if) (when (len>1? (cdr last)) (return-walker (caddr last) func) (if (pair? (cdddr last)) (return-walker (cadddr last) func)))) - + ((cond) (when (pair? (cdr last)) (for-each (lambda (c) (when (pair? c) (return-walker (last-ref c) func))) (cdr last)))) - + ((case) (when (len>1? (cdr last)) (for-each (lambda (c) (when (pair? c) (return-walker (last-ref c) func))) (cddr last)))) - + ((do) (if (and (len>1? (cdr last)) (proper-list? (caddr last)) @@ -14033,14 +14050,14 @@ ;; call-with-exit: walker on last on body, and scan for return func, walker on arg(s...)->values? ))) - + (define (check-sequence-constant function-name last) (return-walker last (lambda (in-seq) (when (or (not (pair? in-seq)) (eq? (car in-seq) 'quote)) (let ((seq (if (len>1? in-seq) ; (quote . 1)?? - (cadr in-seq) + (cadr in-seq) in-seq))) (when (and (sequence? seq) (not (zero? (length seq)))) @@ -14069,7 +14086,7 @@ (eq? (hash-table-ref notables (caadr b)) (car a)) (equal? (cdr a) (cdadr b))))))) - + (define lint-function-body #f) ; a momentary kludge?? (define lint-function-name #f) ; and another! @@ -14077,11 +14094,11 @@ ;; look for outer let with var value constant, not set in func body -- ;; suggest moving it to closure, modulo endless quibbles of course. ;; ignore nested lets because there we assume locality is more important. - ;; we get here if (eq? form lint-function-body) and (symbol? lint-function-name) + ;; we get here if (eq? form lint-function-body) and (symbol? lint-function-name) ;; and not named-let (can this happen?) and only this expr in body ;; currently called only in let-walker, but might make sense in let*-walker and letrec-walker. ;; in letrec-walker it got only 1 hit. - + (when (and (pair? lint-function-body) ; (let ((v 3)) v)? (eq? form (car lint-function-body)) (symbol? lint-function-name) @@ -14089,7 +14106,7 @@ (null? (cdr lint-function-body)) ;(not (tree-set-memq definers (cdr form))) ) - (for-each + (for-each (lambda (local-var) (let ((vname (var-name local-var)) (vvalue (var-initial-value local-var))) @@ -14098,7 +14115,7 @@ (or (constant-expression? vvalue env) (and (pair? vvalue) (memq (car vvalue) '(list vector float-vector int-vector byte-vector)) - (not (lint-any? (lambda (x) + (not (lint-any? (lambda (x) (or (and (pair? x) (not (eq? (car x) 'quote))) (and (symbol? x) ; (list 1 x 2) @@ -14106,7 +14123,7 @@ (cdr vvalue))))) (not (lint-any? (lambda (p) (and (pair? p) - (or (memq (car p) '(vector-set! float-vector-set! int-vector-set! + (or (memq (car p) '(vector-set! float-vector-set! int-vector-set! string-set! list-set! hash-table-set! let-set! set-car! set-cdr!)) ;; maybe check for anything ending in ! here @@ -14114,7 +14131,7 @@ (eq? vname (cadr p)))) (var-history local-var)))) (lint-format "~A can ~Abe moved to ~A's closure" lint-function-name - vname + vname (if (lint-any? (lambda (p) (and (pair? p) (side-effect? p env))) @@ -14132,7 +14149,7 @@ (car body) (+ lint-left-margin 4) #\space (lint-pp `(define ,function-name (let ((+documentation+ ,(car body))) - (,(case definer + (,(case definer ((define) 'lambda) ((define*) 'lambda*) (else)) @@ -14159,7 +14176,7 @@ (lint-format "perhaps ~A" function-name (lists->string (car body) `(let ((,(cadar body) ,(caddar body))) ...)))) ;; as first in let of body, maybe a half-dozen - + (let ((tag 'yup)) (catch 'sequence-constant-done (lambda () @@ -14171,7 +14188,7 @@ (if (and v (symbol? (var-ftype v))) (set! (var-retcons v) #t))))) - + (let-temporarily ((lint-function-body (and (not (eq? definer 'definstrument)) body)) (lint-function-name (and (null? (cdr body)) function-name))) (lint-walk-body function-name definer body env))) @@ -14184,7 +14201,7 @@ (string? (car body))) (cdr body) ; strip away the (old-style) documentation string body))) - + (cond ((not (and (len=1? bval) ; not (define (hi a) . 1)! (pair? (car bval)) (symbol? (caar bval))))) ; not (define (hi) ((if #f + abs) 0)) @@ -14202,9 +14219,9 @@ (let ((e (var-member cval env) )) (and e (symbol? (var-ftype e)) - (let ((def (var-initial-value e)) + (let ((def (var-initial-value e)) (e-args (var-arglist e))) - (and + (and (pair? def) (memq (var-ftype e) '(define lambda)) (or (and (null? args) @@ -14214,7 +14231,7 @@ (and (pair? args) (pair? e-args) (= (length args) (length e-args))))))))) - (lint-format "~A~A could be (define ~A ~A)" function-name + (lint-format "~A~A could be (define ~A ~A)" function-name (if (and (procedure? p) (not (= (car ary) (cdr ary))) (not (= (length args) (cdr ary)))) @@ -14226,8 +14243,8 @@ ;; (object->string (define (f5 x y) (+ x y)) :readable) returns "+" ;; and undoubtedly many more "") - function-name - function-name + function-name + function-name (if (equal? args (cdar bval)) cval (hash-table-ref reversibles (caar bval)))) @@ -14237,7 +14254,7 @@ (lint-format "~A could probably be ~A" function-name (truncated-list->string form) (truncated-list->string (list 'define function-name cval))))))) - + ((and (or (symbol? args) (and (pair? args) (negative? (length args)))) @@ -14251,14 +14268,14 @@ (equal? (cddar bval) (proper-list args))))) ;; (define (f1 . x) (apply + x)) -> (define f1 +) (lint-format "~A could be (define ~A ~A)" function-name function-name function-name (cadar bval))) - + ((and (hash-table-ref combinable-cxrs (caar bval)) (pair? (cdar bval)) (pair? (cadar bval))) ((lambda* (cr arg) (and cr (< (length cr) 5) - (len=1? args) + (len=1? args) (eq? (car args) arg) (let ((f (symbol "c" cr "r"))) (if (eq? f function-name) @@ -14272,27 +14289,27 @@ (memq (caar bval) '(list-ref list-tail)) (len=1? args) (eq? (car args) (cadar bval))))) - + ((eq? (caar bval) 'list-ref) (case (caddar bval) ((0) (lint-format "~A could be (define ~A car)" function-name function-name function-name)) ((1) (lint-format "~A could be (define ~A cadr)" function-name function-name function-name)) ((2) (lint-format "~A could be (define ~A caddr)" function-name function-name function-name)) ((3) (lint-format "~A could be (define ~A cadddr)" function-name function-name function-name)))) - + (else (case (caddar bval) ((1) (lint-format "~A could be (define ~A cdr)" function-name function-name function-name)) ((2) (lint-format "~A could be (define ~A cddr)" function-name function-name function-name)) ((3) (lint-format "~A could be (define ~A cdddr)" function-name function-name function-name)) ((4) (lint-format "~A could be (define ~A cddddr)" function-name function-name function-name))))))) - + (let ((fvar (and (symbol? function-name) - (let ((fname (case definer + (let ((fname (case definer ((lambda lambda*) :lambda) ((dilambda) :dilambda) (else function-name))) - (fargs ((case definer + (fargs ((case definer ((lambda lambda*) cadr) ((defmacro defmacro*) caddr) (else cdadr)) @@ -14311,7 +14328,7 @@ (else (or (not (memq definer '(define-macro* define-bacro*))) (eq? (last-ref (cdadr form)) :allow-other-keys)))))) - + (if (null? args) (begin (if (memq definer '(define* lambda* defmacro* define-macro* define-bacro*)) @@ -14325,13 +14342,13 @@ (if (pair? nvars) (report-usage function-name definer nvars cur-env))) cur-env)) - + (if (not (or (symbol? args) (pair? args))) (begin (lint-format "strange ~A parameter list ~A" function-name definer args) env) - (let ((args-as-vars + (let ((args-as-vars (if (symbol? args) ; this is getting arg names to add to the environment (begin (if (memq definer '(define* lambda* defmacro* define-macro* define-bacro*)) @@ -14371,7 +14388,7 @@ ;; look for unused parameters that are passed a value other than #f (let ((set ()) (unused ())) - (for-each + (for-each (lambda (arg-var) (if (zero? (var-ref arg-var)) (if (positive? (var-set arg-var)) @@ -14399,25 +14416,25 @@ proper-args)) (set! (var-signature fvar) sig)))))) (cons fvar env)))))))) - + (define (check-bool-cond caller form c1 c2 env) ;; (cond (x #f) (#t #t)) -> (not x) ;; c1/c2 = possibly combined, so in (cond (x #t) (y #t) (else #f)), c1: ((or x y) #t), so -> (or x y) - (and (len=2? c1) - (len>1? c2) + (and (len=2? c1) + (len>1? c2) (memq (car c2) '(#t else)) (or (and (boolean? (cadr c1)) (or (and (null? (cddr c2)) (boolean? (cadr c2)) (not (equal? (cadr c1) (cadr c2))) ; handled elsewhere - (lint-format "perhaps ~A" caller - (lists->string form (if (eq? (cadr c1) #t) + (lint-format "perhaps ~A" caller + (lists->string form (if (eq? (cadr c1) #t) (car c1) (simplify-boolean (list 'not (car c1)) () () env))))) (and (not (cadr c1)) ; (cond (x #f) (else y)) -> (and (not x) y) (let ((cc1 (simplify-boolean (list 'not (car c1)) () () env))) - (lint-format "perhaps ~A" caller - (lists->string form + (lint-format "perhaps ~A" caller + (lists->string form (list 'and cc1 (if (null? (cddr c2)) (cadr c2) @@ -14425,9 +14442,9 @@ (and (pair? (car c1)) ; (cond ((null? x) #t) (else y)) -> (or (null? x) y) (eq? (return-type (caar c1) env) 'boolean?) (lint-format "perhaps ~A" caller - (lists->string form + (lists->string form (list 'or (car c1) - (if (null? (cddr c2)) + (if (null? (cddr c2)) (cadr c2) (cons 'begin (cdr c2))))))))) (and (boolean? (cadr c2)) @@ -14442,7 +14459,7 @@ (eq? (caar c1) 'and)) (append (car c1) (cdr c1)) (cons 'and c1))))))))) - + (define (case-branch test eqv-select exprs) (cons (case (car test) ((eq? eqv? = equal? char=?) @@ -14457,10 +14474,10 @@ (if (equal? eqv-select (cadr test)) (list (caddr test) (other-case (caddr test))) (list (cadr test) (other-case (cadr test))))) - (else + (else (map (lambda (p) (case (car p) - ((eq? eqv? = equal? char=?) + ((eq? eqv? = equal? char=?) (unquoted ((if (equal? eqv-select (cadr p)) caddr cadr) p))) ((memq memv member) (apply values (caddr p))) ((not) #f) @@ -14468,8 +14485,8 @@ ((eof-object?) #<eof>) ((zero?) (values 0 0.0)) ((boolean?) (values #t #f)) - ((char-ci=?) - (if (equal? eqv-select (cadr p)) + ((char-ci=?) + (if (equal? eqv-select (cadr p)) (values (caddr p) (other-case (caddr p))) (values (cadr p) (other-case (cadr p))))) (else (error 'wrong-type-arg "oops")))) @@ -14486,10 +14503,10 @@ (list '=> (caar exprs))) (else exprs)))) - + (define (cond->case eqv-select new-clauses) - (cons 'case - (cons eqv-select + (cons 'case + (cons eqv-select (map (lambda (clause) (let ((test (car clause)) (exprs (cdr clause))) @@ -14510,7 +14527,7 @@ (else (cons 'else exprs))))) new-clauses)))) - + (define (eqv-code-constant? x) (or (number? x) (char? x) @@ -14533,7 +14550,7 @@ (equal? eqv-select (caddr clause)) (and (eqv-code-constant? (caddr clause)) (equal? eqv-select (cadr clause)))))) - + ((memq memv member) (and (pair? (cddr clause)) (equal? eqv-select (cadr clause)) @@ -14554,9 +14571,9 @@ ((not null? eof-object? zero? boolean?) (equal? eqv-select (cadr clause))) - + (else #f)))) - + (define (partition-form start len) (let ((ps (make-vector len)) (qs (make-vector len))) @@ -14586,7 +14603,7 @@ (not (pair? q)) (not (equal? (car q) (car f)))) (set! trailer-len k)))) - + (when (= result-min-len header-len) (set! header-len (- header-len 1)) (set! trailer-len 0)) @@ -14649,8 +14666,8 @@ (lint-format "~A ~A" caller (if (null? a) "perhaps" "a toss-up -- perhaps") (lists->string form - `(,definer (,outer-name - ,@(if args-match + `(,definer (,outer-name + ,@(if args-match outer-args (do ((result ()) (p outer-args (cdr p)) @@ -14660,7 +14677,7 @@ (set! result (cons (caar a) result)))) ,@extras) ,@(tree-subst outer-name inner-name inner-body)))))))))))))) - + (denote (set-target name form env) (and (pair? form) (or (and (pair? (cdr form)) @@ -14675,10 +14692,10 @@ (define (check-definee caller sym form env) (cond ((not (pair? (cddr form)))) - + ((keyword? sym) ; (define :x 1) (lint-format "keywords are constants ~A" caller sym)) - + ((and (eq? sym 'pi) ; (define pi (atan 0 -1)) (member (caddr form) '((atan 0 -1) (acos -1) @@ -14686,19 +14703,19 @@ (* 4 (atan 1)) (* 4 (atan 1 1))))) (lint-format "~A is one of its many names, but pi is a predefined constant" caller (caddr form))) - + ((constant? sym) ; (define most-positive-fixnum 432) (if (memv sym '(pi +nan.0 -nan.0 +inf.0 -inf.0 *unbound-variable-hook* *missing-close-paren-hook* *read-error-hook* *load-hook* *error-hook* *rootlet-redefinition-hook*)) (lint-format "~A is a constant: ~A" caller sym form))) - + ((eq? sym 'quote) (lint-format "either a stray quote, or a really bad idea: ~A" caller (truncated-list->string form))) - + ((pair? sym) (check-definee caller (car sym) form env)) - + ((var-member sym env) => (lambda (v) (if (and (eq? (var-definer v) 'define-constant) (len>2? form) @@ -14712,11 +14729,11 @@ ((memq sym '(else =>)) ; also in r7rs ... and _, but that is for syntax-rules (lint-format "redefinition of ~A is a bad idea: ~A" caller sym (truncated-list->string form))))) - + (define walker-functions (let ((binders '(let let* letrec letrec* do - lambda lambda* define define* - call/cc call-with-current-continuation + lambda lambda* define define* + call/cc call-with-current-continuation define-macro define-macro* define-bacro define-bacro* define-constant define-expansion load eval eval-string require)) (walker-table (make-hash-table)) @@ -14740,7 +14757,7 @@ (lint-format "in ~A this let binding is pointless: ~A" caller (truncated-list->string form) v)))))))) - + (define (local-movable-funcs body largs) (let ((ok-funcs ()) (bad-funcs ()) @@ -14763,11 +14780,11 @@ (values) f)) (reverse ok-funcs)))) - + ;; -------- local-funcs->closure -------- - (define local-funcs->closure + (define local-funcs->closure (let* ((rewrite-funcs - (let* ((funcs->list + (let* ((funcs->list (lambda (ok-funcs) (map (lambda (f) (let ((def (cdr f))) @@ -14775,7 +14792,7 @@ def (list (car def) (cadr def) '...)))) ok-funcs))) - + (rewrite-define (lambda (form ok-funcs outer-args let-case) `(define ,(caadr form) ; define* -> lambda* below @@ -14784,19 +14801,19 @@ (,(if (eq? (car form) 'define*) 'lambda* 'lambda) ,(cdr outer-args) ...))))) - - (rewrite-lambda + + (rewrite-lambda (lambda (form ok-funcs outer-args let-case) `(,(or let-case 'let) ,(if let-case (funcs->list ok-funcs) ()) ,@(if let-case () (funcs->list ok-funcs)) (,(car form) ,outer-args ...))))) - + (lambda (caller form ok-funcs outer-args define-case let-case) - (let ((msg (string-append "the " - (if let-case "local" "inner") + (let ((msg (string-append "the " + (if let-case "local" "inner") " function~A ~{~A~^, ~} could be moved " - (if define-case - "to ~A's closure: ~A" + (if define-case + "to ~A's closure: ~A" "outside the ~A: ~A"))) (rewriter (if define-case rewrite-define rewrite-lambda)) (fname ((if define-case caadr car) form))) @@ -14805,8 +14822,8 @@ (map car ok-funcs) fname (lists->string form (rewriter form ok-funcs outer-args let-case))))))) - - (largs->let + + (largs->let (lambda (caller form body largs outer-args define-case) (let ((ok-funcs (local-movable-funcs body largs))) (when (pair? ok-funcs) @@ -14814,7 +14831,7 @@ (set! last-lambda-let-funcs ok-funcs) (rewrite-funcs caller form ok-funcs outer-args define-case #f))))) - (ok-func? + (ok-func? (lambda (var&val let-case largs) (and (len=1? (cdr var&val)) (len>2? (cadr var&val)) @@ -14826,12 +14843,12 @@ (not (tree-set-memq (let remove-shadows ((args largs) (nargs ())) (if (null? args) nargs - (remove-shadows (cdr args) + (remove-shadows (cdr args) (if (memq (car args) fargs) nargs (cons (car args) nargs))))) (cdr val)))))))) - + (lambda (caller form outer-args define-case) (let ((largs (args->proper-list outer-args)) (body ((if (string? (caddr form)) cdddr cddr) form))) @@ -14845,11 +14862,11 @@ (just-pairs? (cadar body)) (pair? (cddar body))) (if (func-definer? (caddar body)) - (largs->let caller form + (largs->let caller form (cddar body) (if define-case (cons (caadr form) (append largs (map car (cadar body)))) - (append largs (map car (cadar body)))) + (append largs (map car (cadar body)))) outer-args define-case)) (let ((let-case (caar body))) ; if not 'let, add locals to outer-args (unless (or (eq? let-case 'let) @@ -14869,10 +14886,10 @@ (if (ok-func? (car p) let-case largs) (set! ok-funcs (cons (cons (caar p) (car p)) ok-funcs)))))))))))) - + ;; ---------------- define and defmacro ---------------- (let () - + (define (check-define-macro caller form env) ;; used in define-walker and defmacro-walker (let ((val (cddr form)) @@ -14890,10 +14907,10 @@ (not (unquoted-pair? (cadr body)))) (not (or (memq (car body) '(quote quasiquote list cons append)) (tree-set-memq '(list-values apply-values append) body))))) - (lint-format "perhaps ~A or ~A" caller + (lint-format "perhaps ~A or ~A" caller (lists->string form (list 'define outer-name (unquoted body))) (truncated-list->string (list 'define (list outer-name) (unquoted body))))) - + (when (pair? body) (let ((args (cdr body))) (case (car body) @@ -14906,19 +14923,19 @@ (memq (cadar args) '(set! define)))) (lint-format "perhaps ~A" caller ; (define-macro (fx x) `(abs ,x)) -> (define fx abs) (lists->string form (list 'define outer-name (cadar args)))) - + (if (and (not (hash-table-ref syntaces (cadar args))) (not (any-macro? (cadar args) env)) (lint-every? (lambda (a) (or (code-constant? a) (and (memq a outer-args) (= (tree-count a (cdr args) 2) 1)))) - (cdr args))) + (cdr args))) ;; marginal -- there are many debatable cases here (lint-format "perhaps ~A" caller (lists->string form `(define (,outer-name ,@outer-args) (,(cadar args) ,@(map unquoted (cdr args)))))))) - + (if (or (and (symbol? outer-args) ; (define-macro (f . x) `(+ ,@x)) -> (define f +) (len=2? args) (len=2? (cadr args)) @@ -14932,44 +14949,44 @@ (eq? (cadr (caddr args)) (cdr outer-args)))) (lint-format "perhaps ~A" caller (lists->string form (list 'define outer-name (cadar args))))))) - + (let ((pargs (args->proper-list outer-args))) (for-each (lambda (p) (if (and (quoted-pair? p) (tree-set-memq pargs (cadr p))) (lint-format "missing comma? ~A" caller form))) args))) - + ((quote) ;; extra comma (unquote) is already caught elsewhere (if (and (pair? args) (pair? (car args)) (tree-set-memq (args->proper-list outer-args) (car args))) (lint-format "missing comma? ~A" caller form)))))))))) - - + + ;; -------- uncurry -------- (define (uncurry caller form env) (let ((sym (cadr form)) (val (cddr form)) (head (car form))) (let ((outer-args (cdr sym)) - (outer-name (if (eq? head 'define*) + (outer-name (if (eq? head 'define*) (remove-one :optional (car sym)) (car sym)))) (if (symbol? (car outer-name)) ;; perhaps a curried definition -- as a public service, we'll rewrite the dumb thing (begin (lint-format "perhaps ~A" caller - (lists->string form `(,head ,outer-name - (lambda ,outer-args + (lists->string form `(,head ,outer-name + (lambda ,outer-args ,@(cddr form))))) (lint-walk-function head (car outer-name) (cdr outer-name) val form env)) (when (pair? (car outer-name)) (if (symbol? (caar outer-name)) (begin (lint-format "perhaps ~A" caller - (lists->string form `(,head ,(car outer-name) + (lists->string form `(,head ,(car outer-name) (lambda ,(cdr outer-name) (lambda ,outer-args ,@(cddr form)))))) @@ -14978,7 +14995,7 @@ (symbol? (caaar outer-name))) (begin (lint-format "perhaps ~A" caller - (lists->string form `(,head ,(caar outer-name) + (lists->string form `(,head ,(caar outer-name) (lambda ,(cdar outer-name) (lambda ,(cdr outer-name) (lambda ,outer-args @@ -14986,7 +15003,7 @@ (lint-walk-function head (caaar outer-name) (cdaar outer-name) val form env)) ;; no hits beyond that case env))))))) - + ;; --------check-built-in-used-as-parameter -------- (define (check-built-in-used-as-parameter caller form) ;; look for a built-in name used as a parameter name and used as a function internally(!) @@ -14995,7 +15012,7 @@ (let ((par (if (pair? p) (car p) p))) (when (or (hash-table-ref built-in-functions par) (hash-table-ref syntaces par)) - (let ((call (call-with-exit + (let ((call (call-with-exit (lambda (return) (let loop ((tree (cddr form))) (if (pair? tree) @@ -15018,7 +15035,7 @@ (if (and (len>1? (cdr tree)) (not (tree-memq par (cadr tree)))) (loop (cdddr tree)))) - (else + (else (if (pair? (cdr tree)) (for-each loop (cdr tree))) (if (pair? (car tree)) @@ -15028,7 +15045,7 @@ (lint-format "~A's parameter ~A is called ~A: find a less confusing parameter name!" caller (caadr form) par (truncated-list->string call))))))) (cdadr form))) - + ;; -------- inner-define->let -------- (define (inner-define->let caller form) ;; perhaps this block should be on a *report-* switch -- @@ -15069,13 +15086,13 @@ (if (null? (cdr inner-body)) (car (tree-subst outer-name inner-name inner-body)) (cons 'begin (tree-subst outer-name inner-name inner-body))) - (cons 'let - (cons (map list inner-args (cdr call)) + (cons 'let + (cons (map list inner-args (cdr call)) inner-body)))))) ;; (define (f11 a b) (define (f12 a b) (if (positive? a) (+ a b) b)) (f12 a b)) -> ;; (define (f11 a b) (if (positive? a) (+ a b) b)) (lint-format "perhaps ~A" caller - (lists->string form + (lists->string form (cons (car form) (cons (cadr form) (let ((p (tree-subst new-call call outer-body))) @@ -15148,8 +15165,8 @@ (not (if (pair? (car sig)) (tree-set-member '(boolean? #t values) (car sig)) (memq (car sig) '(boolean? #t values)))))))) - (lint-format "~A looks boolean, but it can return ~A" caller - sym + (lint-format "~A looks boolean, but it can return ~A" caller + sym (truncated-list->string last)) (throw 'one-is-enough))))) (lambda args #f))))) @@ -15161,13 +15178,13 @@ (lint-every? len=2? (caddar val))) ; some seem to include a type check? (lint-format "perhaps ~A" caller (lists->string form - `(define* (,outer-name + `(define* (,outer-name ,@(copy args (make-list (- (length args) 1))) ,@(map (lambda (p) (if (cadr p) p (car p))) ; remove #f default vals (caddar val))) ...)))))) - + ;; -------- define-walker -------- (define (define-walker caller form env) (if (< (length form) 2) @@ -15180,8 +15197,8 @@ (if (symbol? sym) (begin (check-definee caller sym form env) - (if (memq head '(define define-constant define-envelope - define-public define*-public defmacro-public define-inlinable + (if (memq head '(define define-constant define-envelope + define-public define*-public defmacro-public define-inlinable define-integrable define^)) (let ((len (length form))) (if (not (= len 3)) ; (define a b c) @@ -15191,14 +15208,14 @@ (values "no" "") (values "too many" "s"))))) (lint-format "~A is messed up" caller (truncated-list->string form))) - + (if (not (pair? val)) env (begin (if (and (null? (cdr val)) (equal? sym (car val))) ; (define a a) (lint-format "this ~A is either not needed, or is an error: ~A" caller head (truncated-list->string form))) - + (if (not (pair? (car val))) (begin (cond ((and (not (memq caller '(module cond-expand))) @@ -15206,7 +15223,7 @@ => (lambda (p) (lint-format "~A is used before it is defined: ~A" caller sym form)))) (cons (make-lint-var sym (car val) head) env)) - + (let ((e (lint-walk (if (and (pair? (car val)) (eq? (caar val) 'letrec)) 'define sym) @@ -15217,13 +15234,13 @@ (cons (make-lint-var sym (car val) head) env) (begin (if (eq? (var-name (car e)) :lambda) - (recursion->iteration sym + (recursion->iteration sym (var-ftype (car e)) (var-arglist (car e)) (var-initial-value (car e)) e)) (set! (var-name (car e)) sym) - + (let ((val (caddr form))) (when (and (eq? (car val) 'lambda) ; (define sym (lambda args (let name...))), let here happens rarely (proper-list? (cadr val)) @@ -15232,10 +15249,10 @@ (eq? (caaddr val) 'let) (symbol? (cadr (caddr val)))) (replace-redundant-named-let caller form sym (cadr val) (caddr val)))) - + (letrec->define caller form) e))))))) ; symbol? sym - + (begin ; not (symbol? sym) (when (and (memq head '(define define*)) ; can't include define-macro et al because we use lambda(*) as rewrite @@ -15246,33 +15263,33 @@ (cond ((not (and (pair? sym) (pair? val))) (lint-format "strange form: ~A" head (truncated-list->string form))) - + ((pair? (car sym)) (uncurry caller form env)) ; curried func info thrown away (not included in returned env) - + (else (cond ((not *report-forward-functions*)) ;; need to ignore macro usages here -- this happens ca 20000 times! ((hash-table-ref other-identifiers (car sym)) => (lambda (p) (lint-format "~A is used before it is defined" caller (car sym))))) - + (if *report-boolean-functions-misbehaving* (check-boolean-function caller form env)) - + (check-definee caller (car sym) form env) - + (let ((outer-args (cdr sym)) (outer-name (car sym))) (when (len>1? (car val)) (when (eq? (caar val) 'let) (check-pointless-let caller form (car val) outer-args) - + ;; define + redundant named-let -- sometimes rewrites to define* (when (and (symbol? (cadar val)) (null? (cdr val))) (replace-redundant-named-let caller form outer-name outer-args (car val)))) - + (inner-define->let caller form) (if (memq (caar val) '(let-optionals let-optionals*)) @@ -15281,33 +15298,33 @@ (when (pair? outer-args) (if (repeated-member? (proper-list outer-args) env) (lint-format "~A parameter is repeated: ~A" caller head (truncated-list->string sym))) - + (cond ((memq head '(define* define-macro* define-bacro* define*-public)) (check-star-parameters outer-name outer-args env)) ((any-keywords? outer-args) (lint-format "~A parameter can't be a keyword: ~A" caller outer-name sym)) ((memq 'pi outer-args) (lint-format "~A parameter can't be a constant: ~A" caller outer-name sym))) - + (check-built-in-used-as-parameter caller form)) - + (when (eq? head 'define-macro) (check-define-macro caller form env)) (if (and (eq? head 'definstrument) (string? (car val))) (set! val (cdr val))) - + (if (not (keyword? outer-name)) (set! env (lint-walk-function head outer-name outer-args val form env)))))) env))))) (for-each (lambda (op) (hash-walker op define-walker)) - '(define define* define-constant + '(define define* define-constant define-macro define-macro* define-bacro define-bacro* define-expansion definstrument define-animal define-envelope ; for clm - define-public define*-public defmacro-public define-inlinable + define-public define*-public defmacro-public define-inlinable define-integrable define^)) ; these give more informative names in Guile and scmutils (MIT-scheme)) @@ -15330,9 +15347,9 @@ (repeated-member? args env)) ; (defmacro hi (a b a) a) (lint-format "~A parameter is repeated: ~A" caller head (truncated-list->string args)) (lint-format "~A is deprecated; perhaps ~A" caller head ; (defmacro hi (a b) `(+ ,a ,b)) - (truncated-lists->string form - (cons (if (eq? head 'defmacro) 'define-macro 'define-macro*) - (cons (cons sym + (truncated-lists->string form + (cons (if (eq? head 'defmacro) 'define-macro 'define-macro*) + (cons (cons sym (let no-key ((lst args)) ; remove :key and :optional (if (not (pair? lst)) lst @@ -15344,16 +15361,16 @@ (if (eq? head 'defmacro) (check-define-macro caller (cons 'define-macro - (cons (cons sym args) + (cons (cons sym args) body)) env)) - + (lint-walk-function head sym args body form env) (cons (make-lint-var sym form head) env)))) - + (hash-walker 'defmacro defmacro-walker) (hash-walker 'defmacro* defmacro-walker)) - + ;; ---------------- dilambda ---------------- (let () @@ -15376,9 +15393,9 @@ (hash-walker 'dilambda dilambda-walker)) - ;; ---------------- lambda, lambda* ---------------- + ;; ---------------- lambda, lambda* ---------------- (let () - + ;; -------- lambda-walker -------- (define (lambda-walker caller form env) (let ((len (length form)) @@ -15404,7 +15421,7 @@ (if (and (eq? head 'lambda*) ; (lambda* ()...) -> (lambda () ...) (null? args)) ; (lambda* args ...) is caught elsewhere (lint-format "lambda* could be lambda ~A" caller form)) - + (when (pair? (cddr form)) (local-funcs->closure caller form args #f)) @@ -15426,52 +15443,52 @@ (equal? (cddr body) (proper-list args))))) ;; (lambda args (apply + args)) -> + (lint-format "perhaps ~A" caller (lists->string form (cadr body)))) - + (when (list? args) ;; complain if let rebinds parameter uselessly (when (and (len>1? body) (eq? (car body) 'let)) (check-pointless-let caller form body (cadr form))) - + ;; lambda -> body when args are straightforward ;; (lambda () (f)) -> f, (lambda (a b) (f a b)) -> f (cond ((not (and (pair? body) (symbol? (car body)) (not (memq (car body) '(and or)))))) - + ((equal? args (cdr body)) ; (lambda (a b) (> a b)) -> > (lint-format "perhaps ~A" caller (lists->string form (car body)))) - + ((and (eq? (car body) 'not) (pair? (cdr body)) (pair? (cadr body)) (hash-table-ref notables (caadr body)) (equal? args (cdadr body))) ; (lambda (a b) (not (> a b))) -> <= (lint-format "perhaps ~A" caller (lists->string form (hash-table-ref notables (caadr body))))) - + ((equal? (reverse args) (cdr body)) ; (lambda (a b) (> b a)) -> < (let ((rf (hash-table-ref reversibles (car body)))) (if rf (lint-format "perhaps ~A" caller (lists->string form rf))))) - + ((and (= arglen 1) ; (lambda (x) (cdr (cdr (car x)))) -> cddar (hash-table-ref combinable-cxrs (car body))) ((lambda* (cr arg) ; lambda* not lambda because combine-cxrs might return just #f (and cr - (< (length cr) 5) + (< (length cr) 5) (eq? (car args) arg) - (lint-format "perhaps ~A" caller + (lint-format "perhaps ~A" caller (lists->string form (symbol "c" cr "r"))))) (combine-cxrs body)))))))) - + (lint-walk-function head caller args (cddr form) form env) ;; not env as return value here -- return the lambda+old env via lint-walk-function )))) - + (hash-walker 'lambda lambda-walker) (hash-walker 'lambda* lambda-walker)) - - - ;; ---------------- set! ---------------- + + + ;; ---------------- set! ---------------- (let () (define (set-walker caller form env) (if (not (= (length form) 3)) @@ -15504,17 +15521,17 @@ ((or (hash-table-ref syntaces settee) (memq settee '(else => ... _))) ; r7rs says (set! else #f) is an error (lint-format "bad idea: ~A" caller (truncated-list->string form))))))) - + ((not (pair? settee)) ; (set! 3 1) (lint-format "can't set! ~A" caller (truncated-list->string form))) - + (else (when (proper-list? settee) (let ((target (car settee))) (cond ((memq target '(vector-ref list-ref string-ref hash-table-ref int-vector-ref float-vector-ref byte-vector-ref let-ref)) ;; (set! (vector-ref v 0) 3) - (lint-format "perhaps ~A" caller - (truncated-lists->string + (lint-format "perhaps ~A" caller + (truncated-lists->string form (cons (case target ((vector-ref) 'vector-set!) @@ -15526,20 +15543,20 @@ ((hash-table-ref) 'hash-table-set!) ((let-ref) 'let-set!)) (append (cdadr form) (cddr form)))))) - + ((and (eq? target 'setter) (len>1? setval) (eq? (car setval) 'lambda) (list? (cadr setval)) (not (= (length (cadr setval)) 2))) (lint-format "setter function should take 2 arguments: ~A" caller (truncated-list->string form))) - + ((or (string? target) (vector? target)) (lint-format "~S is a constant so ~A is problematic" caller target (truncated-list->string form)))))) - + (lint-walk caller settee env) ; this counts as a reference since it's by reference so to speak - + ;; try type check (dilambda signatures) (when (symbol? (car settee)) (let ((f (symbol->value (car settee) *e*))) @@ -15553,33 +15570,33 @@ (arg-type (->lint-type setval))) (when (and (symbol? checker) (not (compatible? checker arg-type))) ; (set! (print-length) "asd") - (lint-format "~A: new value should be a~A ~A: ~S: ~A" + (lint-format "~A: new value should be a~A ~A: ~S: ~A" caller (car settee) (if (char=? (string-ref (object->string checker #f) 0) #\i) "n" "") checker arg-type (truncated-list->string form))))))))) (set! settee (do ((sym (car settee) (car sym))) ((not (pair? sym)) sym))))) - + (if (symbol? (cadr form)) ; see do directly above -- sets settee so we have to go back to (cadr form) (set-set (cadr form) caller form env) (if (and (pair? (cadr form)) (symbol? settee)) (set-ref settee caller (cons 'implicit-set (cdr form)) env))) - + (if (equal? (cadr form) setval) ; not settee here! ; (set! a a) (lint-format "pointless set! ~A" caller (truncated-list->string form))) - (when (and (pair? setval) + (when (and (pair? setval) (symbol? settee)) (case (car setval) ((if) ; (set! x (if y x 1)) -> (if (not y) (set! x 1)) (if (= (length setval) 4) (if (eq? settee (caddr setval)) - (lint-format "perhaps ~A" caller + (lint-format "perhaps ~A" caller (lists->string form `(if (not ,(cadr setval)) (set! ,settee ,(cadddr setval))))) (if (eq? settee (cadddr setval)) - (lint-format "perhaps ~A" caller + (lint-format "perhaps ~A" caller (lists->string form `(if ,(cadr setval) (set! ,settee ,(caddr setval))))))))) ((cond) ; (set! x (cond (z w) (else x))) -> (if z (set! x w)) -- this never happens @@ -15596,7 +15613,7 @@ (lists->string form `(if (not ,(caadr setval)) (set! ,(cadr form) ,(cadr (caddr setval)))))))))) ((append) ; in do loop, (set! sym (append sym ...)) -> (set! sym (cons ... sym)) + reverse later - (cond ((var-member :do env) => + (cond ((var-member :do env) => (lambda (v) (let search ((tree (cddr (var-initial-value v)))) (and (pair? tree) @@ -15612,26 +15629,26 @@ caller (cadr tree) (cadr tree) (cadr tree) (cadr tree) (cadr tree)) (or (search (car tree)) (search (cdr tree)))))))))) - + ((or) ; (set! x (or x y)) -> (if (not x) (set! x y)) (if (and (= (length setval) 3) ; the other case here is not improved by using 'if (eq? settee (cadr setval))) - (lint-format "perhaps ~A" caller + (lint-format "perhaps ~A" caller (lists->string form `(if (not ,settee) (set! ,settee ,(caddr setval))))))) - + ((and) (if (= (length setval) 3) ; (set! x (and x y)) -> (if x (set! x y)) (if (eq? settee (cadr setval)) - (lint-format "perhaps ~A" caller + (lint-format "perhaps ~A" caller (lists->string form `(if ,settee (set! ,settee ,(caddr setval))))) (if (eq? settee (caddr setval)) - (lint-format "perhaps ~A" caller + (lint-format "perhaps ~A" caller (lists->string form `(if (not ,(cadr setval)) (set! ,settee #f)))))))))) result)))) (hash-walker 'set! set-walker)) - - - ;; ---------------- quote ---------------- + + + ;; ---------------- quote ---------------- (let () (define (quote-walker caller form env) (let ((len (length form))) @@ -15647,7 +15664,7 @@ (if (> (length arg) 8) (hash-table-set! big-constants arg (+ 1 (or (hash-table-ref big-constants arg) 0)))) (unless (or (>= quote-warnings 20) - (and (symbol? arg) + (and (symbol? arg) (not (keyword? arg)))) (set! quote-warnings (+ quote-warnings 1)) ; (char? '#\a) (lint-format "quote is not needed here: ~A~A" caller ; this is by far the most common message from lint @@ -15656,7 +15673,7 @@ env) (hash-walker 'quote quote-walker)) - + ;; ---------------- if ---------------- (let () @@ -15670,7 +15687,7 @@ (lint-format "if test is never false: ~A" caller (truncated-list->string form)) (if (and (never-true test) true) ; complain about (if #f #f) later, (if #f x y) (lint-format "if test is never true: ~A" caller (truncated-list->string form)))) - + (if (and (symbol? test) (pair? true) (memq test true)) @@ -15720,14 +15737,14 @@ (or (not (hash-table-ref syntaces true-op)) (memq true-op '(let let* set! and or begin)))) - (define (tree-subst-eq new old tree) + (define (tree-subst-eq new old tree) ;; tree-subst above substitutes every occurence of 'old with 'new, so we check ;; in advance that 'old only occurs once in the tree (via tree-count). Here ;; 'old may occur any number of times, but we want to change it only once, ;; so we keep the actual pointer to it and use eq?. (This assumes no shared code?) (cond ((eq? old tree) (cons new (cdr tree))) - ((not (pair? tree)) + ((not (pair? tree)) tree) ((eq? (car tree) 'quote) (copy tree)) @@ -15735,7 +15752,7 @@ (tree-subst-eq new old (cdr tree)))))) (when (and (case true-op ; (if old (list form) (cons form old)) -> (cons form (if old () old)) etc - ((list) (eq? false-op 'cons)) + ((list) (eq? false-op 'cons)) ((cons) (eq? false-op 'list)) (else #f)) (pair? true-rest) @@ -15752,8 +15769,8 @@ (set! false `(cons ,(car false-rest) ())) (set! false-op 'cons) (set! false-rest (list (car false-rest) ())))))) - - ;; maybe move the unless before this + + ;; maybe move the unless before this ;; reversible ops here got no real hits (test case junk) (let ((diff (let differ-in-one ((p true) (q false)) @@ -15781,7 +15798,7 @@ (eq? subst-loc true-rest))) ; avoid confusion about the vars list (let ((vars (car true-rest))) ;; (if x (let ((y (abs x))) (display z) y) (let ((y (log x))) (display z) y)) -> (let ((y ((if x abs log) x))) (display z) y) - (lint-format "perhaps ~A" caller + (lint-format "perhaps ~A" caller (lists->string form (if (and (pair? vars) (case true-op @@ -15791,7 +15808,7 @@ (tree-subst-eq (cons 'if (cons test (cadr diff))) subst-loc true) `(let ((<1> ,test)) ,(tree-subst-eq `(if <1> ,@(cadr diff)) subst-loc true))))))) - + ;; also not any-macro? (car true|false) probably ;; (if x (set! y #t) (set! y #f)) -> (set! y x) (let ((nform (cond ((eq? true-op (caadr diff)) ; very common! @@ -15802,56 +15819,56 @@ (list 'or test false-op) (list 'if test true-op false-op)) true-rest)) - + ((and (eq? (caadr diff) #t) (not (cadadr diff))) ;; (if x (set! y #t) (set! y #f)) -> (set! y x) (tree-subst-eq test subst-loc true)) - + ((and (not (caadr diff)) (eq? (cadadr diff) #t)) ;; (if x (set! y #f) (set! y #t)) -> (set! y (not x)) (tree-subst-eq (simplify-boolean (list 'not test) () () env) subst-loc true)) - + ((equal? (caadr diff) test) ;; (if x (set! y x) (set! y 21)) -> (set! y (or x 21)) (tree-subst-eq (simplify-boolean (cons 'or (cadr diff)) () () env) subst-loc true)) - + ((and (len=2? test) (eq? (car test) 'not) (equal? (cadadr diff) (cadr test))) ;; (if (not x) (set! y z) (set! y x)) -> (set! y (or x z)) (tree-subst-eq (simplify-boolean (cons 'or (reverse (cadr diff))) () () env) subst-loc true)) - + ((or (memq true-op '(set! begin and or)) (let list-memq ((a subst-loc) (lst true)) (and (pair? lst) (or (eq? a lst) (list-memq a (cdr lst))))) - + ;; (if x (set! y z) (set! y w)) -> (set! y (if x z w)) ;; true op moved out, if test moved in ;; (if A (and B C) (and B D)) -> (and B (if A C D)) ;; here differ-in-one means that preceding/trailing stuff must subst-loc exactly - + (not (and (pair? test) (or (side-effect? test env) (memq (car test) '(list-values apply-values append unquote)))))) (tree-subst-eq (cons 'if (cons test (cadr diff))) subst-loc true)) - + (else #f)))) - + (if (pair? nform) (lint-format "perhaps ~A" caller (lists->string form nform))))))) - + ;; else not pair? diff (unless (memq true-op '(let let* format)) ;; differ-in-trailers can (sometimes) take advantage of values - (let ((enddiff + (let ((enddiff (let ((op (if (memq true-op '(and or + * begin max min)) true-op 'values))) (let differ-in-trailers ((p true) (q false) @@ -15861,7 +15878,7 @@ (if (equal? (car p) (car q)) (differ-in-trailers (cdr p) (cdr q) (+ c 1)) (and (> c (if (eq? op 'values) (max 2 (/ (length true) 2)) 1)) - (list p + (list p (if (null? (cdr p)) (car p) (cons op p)) (if (null? (cdr q)) (car q) (cons op q)))))))))) @@ -15872,7 +15889,7 @@ (if (pair? enddiff) (lint-format "perhaps ~A" caller (lists->string form (tree-subst `((if ,test ,@(cdr enddiff))) (car enddiff) true))) - + ;; differ-in-headers looks for equal trailers ;; (if A (+ B B E C) (+ D D E C)) -> (+ (if A (+ B B) (+ D D)) E C) ;; these are not always (read: almost never) an improvement @@ -15888,7 +15905,7 @@ (and (pair? p) (pair? q) (if (equal? p q) - (and (< 0 c) + (and (< 0 c) (<= c (length p)) (list p (reverse rp) (reverse rq))) (differ-in-headers (cdr p) (cdr q) @@ -15896,16 +15913,16 @@ (cons (car p) rp) (cons (car q) rq))))))) (when (pair? headdiff) (let ((op (if (memq true-op '(and or + * begin max min)) true-op 'values))) - (let ((tp (if (null? (cdadr headdiff)) + (let ((tp (if (null? (cdadr headdiff)) (caadr headdiff) (cons op (cadr headdiff)))) - (tq (if (null? (cdaddr headdiff)) - (caaddr headdiff) + (tq (if (null? (cdaddr headdiff)) + (caaddr headdiff) (cons op (caddr headdiff))))) ;; (if A (+ B B E C) (+ D D E C)) -> (+ (if A (+ B B) (+ D D)) E C) (lint-format "perhaps ~A" caller - (lists->string form - (cons true-op + (lists->string form + (cons true-op (cons (list 'if test tp tq) (car headdiff)))))))))))))))))) @@ -15924,7 +15941,7 @@ (set! last-if-line-number line-number) ;; (if a b (if c d (if e f g))) -> (cond (a b) (c d) (e f) (else g)) -- what about *report-nested-if*? (lint-format "perhaps use cond: ~A" caller - (lists->string form + (lists->string form `(cond ,@(do ((iff form (cadddr iff)) (clauses ())) ((not (and (pair? iff) @@ -15935,32 +15952,32 @@ (eq? (car iff) 'if)) `((,(cadr iff) ,@(unbegin (caddr iff)))) `((else ,@(unbegin iff)))))) - (set! clauses (cons (cons (cadr iff) + (set! clauses (cons (cons (cadr iff) (unbegin (caddr iff))) clauses)))))))))) - + ;; -------- if->or/and -------- (define (if->or/and caller form test true false env) (cond ((side-effect? test env)) - + ((equal? test true) ; (if x x y) -> (or x y) - (lint-format "perhaps ~A" caller - (lists->string form + (lint-format "perhaps ~A" caller + (lists->string form (simplify-boolean (list 'or test (if (eq? false 'no-false) #<unspecified> false)) () () env)))) ((or (equal? test (list 'not true)) ; (if x (not x) y) -> (and (not x) y) (equal? (list 'not test) true)) ; (if (not x) x y) -> (and x y) - (lint-format "perhaps ~A" caller - (lists->string form + (lint-format "perhaps ~A" caller + (lists->string form (simplify-boolean (list 'and true (if (eq? false 'no-false) #<unspecified> false)) () () env)))) ((equal? test false) ; (if x y x) -> (and x y) - (lint-format "perhaps ~A" caller + (lint-format "perhaps ~A" caller (lists->string form (simplify-boolean (list 'and test true) () () env)))) - + ((or (equal? (list 'not test) false) ; (if x y (not x)) -> (or (not x) y) (equal? test (list 'not false))) ; (if (not x) y x) -> (or x y) - (lint-format "perhaps ~A" caller + (lint-format "perhaps ~A" caller (lists->string form (simplify-boolean (list 'or false true) () () env)))))) ;; -------- if->when -------- @@ -15977,15 +15994,15 @@ "this one-armed if is too big" "") (local-line-number test) - (if (and (integer? *report-one-armed-if*) + (if (and (integer? *report-one-armed-if*) (not (and (pair? true) (eq? (car true) 'begin)))) ";" "") - (truncated-lists->string + (truncated-lists->string form (if (and (pair? expr) (eq? (car expr) 'not)) (cons 'unless (cons (cadr expr) (unbegin true))) (cons 'when (cons expr (unbegin true)))))))) - + ;; -------- move-cond-outward -------- (define (move-cond-outward caller form expr true false env) ;; true-op = case happens a lot, but never in a way that (not expr)->false can be combined in the case @@ -16009,7 +16026,7 @@ (list (list (caar false) '...)) (list (car false) '...))))))) (lists->string form (cons 'cond (cons (cons nexpr nfalse) (cdr true)))))))) - + ;; -------- if->cond -------- (define (if->cond caller form env) ;; unravel complicated if-then-else nestings into a single cond, if possible. @@ -16026,7 +16043,7 @@ ;; the shortest clause is at the start -- especially in a nested if where ;; it can be nearly impossible to see which dangling one-liner matches ;; which if (this even in emacs because it unmarks or doesn't remark the matching - ;; paren as you're trying to scroll up to it). + ;; paren as you're trying to scroll up to it). ;; ;; the cond form is not always an improvement: ;; (if A (if B (if C a b) (if C c d)) (if B (if C e f) (if C g h))) @@ -16038,25 +16055,25 @@ ;; the len>2 below could be len>1 + handling of empty false branch, but ;; I don't like the rewrites (using cond). There are a lot of hits here but they ;; need special-case handling, perhaps. - + (define (swap-clauses form) (if (not (len>2? (cdr form))) form (let ((expr (cadr form)) (ltrue (caddr form)) (lfalse (cadddr form))) - + (if (or (and (pair? ltrue) (not (proper-list? ltrue))) (and (pair? lfalse) (not (proper-list? lfalse)))) form - + (let ((true-n (tree-leaves ltrue)) - (false-n (if (not (pair? lfalse)) + (false-n (if (not (pair? lfalse)) 1 (tree-leaves lfalse)))) - + (if (< false-n (/ true-n 4)) (let ((new-expr (simplify-boolean (list 'not expr) () () env))) (if (and (pair? ltrue) @@ -16072,14 +16089,14 @@ (if (and (pair? lfalse) (eq? (car lfalse) 'if)) (set! lfalse (swap-clauses lfalse))) - + (if (and (pair? lfalse) (eq? (car lfalse) 'cond)) `(cond (,expr ,@(unbegin ltrue)) ,@(cdr lfalse)) `(cond (,expr ,@(unbegin ltrue)) (else ,@(unbegin lfalse))))))))))) - + (let ((new-if (swap-clauses form))) (when (and (eq? (car new-if) 'cond) (> (length new-if) *report-nested-if*)) @@ -16090,16 +16107,16 @@ (define (if->bool caller form expr true false env no-suggestion) (cond ((eq? expr #t) ; (if #t #f) -> #f (lint-format "perhaps ~A" caller (lists->string form true))) - + ((not expr) (if (eq? false 'no-false) (if true ; (if #f x) as a kludgey #<unspecified> (lint-format "perhaps ~A" caller (lists->string form #<unspecified>))) ;; (if (negative? (gcd x y)) a b) -> b (lint-format "perhaps ~A" caller (lists->string form false)))) - + ((code-equal? true false) ; (if x (+ y 1) (+ y 1)) -> (+ y 1) - (lint-format "if is not needed here: ~A" caller + (lint-format "if is not needed here: ~A" caller (lists->string form (if (not (side-effect? expr env)) true (list 'begin expr true))))) @@ -16107,10 +16124,10 @@ ((boolean? true) (if (boolean? false) ; ! (if expr #t #f) turned into something less verbose ;; (if x #f #t) -> (not x) - (lint-format "perhaps ~A" caller + (lint-format "perhaps ~A" caller (lists->string form (if true expr (simplify-boolean (list 'not expr) () () env)))) (when no-suggestion ; (if x #f y) -> (and (not x) y) - (lint-format "perhaps ~A" caller + (lint-format "perhaps ~A" caller (lists->string form (if true (if (eq? false 'no-false) expr @@ -16120,7 +16137,7 @@ (eq? (car expr) 'not)) (cons 'when (cons (cadr expr) (unbegin false))) (cons 'unless (cons expr (unbegin false)))) - (simplify-boolean + (simplify-boolean (if (eq? false 'no-false) (list 'not expr) (list 'and (list 'not expr) false)) @@ -16128,8 +16145,8 @@ ((and (boolean? false) no-suggestion) ; (if x y #t) -> (or (not x) y) (lint-format "perhaps ~A" caller - (let ((nexpr (cond (false - (list 'or (if (and (len>1? expr) + (let ((nexpr (cond (false + (list 'or (if (and (len>1? expr) (eq? (car expr) 'not)) (cadr expr) (list 'not expr)) @@ -16140,7 +16157,7 @@ (eq? (car expr) 'not)) (cons 'unless (cons (cadr expr) (unbegin true)))) (else (cons 'when (cons expr (unbegin true))))))) - (lists->string form + (lists->string form (if (and (eq? form lint-mid-form) (eq? (car nexpr) 'when)) nexpr @@ -16193,7 +16210,7 @@ ;; (if (> (+ a b) 3) (let ((a x) (c y)) (* a (log c))) (let ((b z) (c y)) (+... -> ;; (let ((c y)) (if (> (+ a b) 3) (let ((a x)) (* a (log c))) (let ((b z)) (+ b (log c))))) (lint-format "perhaps ~A" caller - (lists->string form + (lists->string form (if (not (or (side-effect? expr env) (tree-set-memq (map car sv) expr))) (list 'let (reverse sv) (list 'if expr ntv nfv)) @@ -16210,7 +16227,7 @@ ((cond) ; (if a A (cond...)) -> (cond (a A) ...) (when (proper-list? false-rest) (lint-format "perhaps ~A" caller (lists->string form (cons 'cond (cons (list expr true) false-rest)))))) - + ((if) (unless (= last-if->case-line-number line-number) (let ((eqv-select (eqv-selector expr))) ; this is just an accessor -- no check for case compatibility of expr @@ -16233,20 +16250,20 @@ (not (eq? (caar clauses) 'else))) (set! last-if->case-line-number line-number) (lint-format "perhaps ~A" caller - (lists->string form + (lists->string form (cond->case eqv-select (reverse clauses))))))))) - + (when (= (length false) 4) (let ((false-test (car false-rest)) (false-true (cadr false-rest)) (false-false (caddr false-rest))) (if (equal? true false-true) ;; (if a A (if b A B)) -> (if (or a b) A B) - (lint-format "perhaps ~A" caller + (lint-format "perhaps ~A" caller (if (and (pair? false-false) (eq? (car false-false) 'if) (equal? true (caddr false-false))) - (lists->string form + (lists->string form (let ((nexpr (simplify-boolean (list 'or expr false-test (cadr false-false)) () () env))) @@ -16254,22 +16271,22 @@ (if true (let ((nexpr (simplify-boolean (list 'or expr false-test) () () env))) (lists->string form (list 'if nexpr true false-false))) - (lists->string form - (simplify-boolean + (lists->string form + (simplify-boolean `(and (not (or ,expr ,false-test)) ,false-false) () () env))))) (when (equal? true false-false) ;; (if a A (if b B A)) -> (if (or a (not b)) A B) - (lint-format "perhaps ~A" caller + (lint-format "perhaps ~A" caller (if true (let ((nexpr (simplify-boolean `(or ,expr (not ,false-test)) () () env))) (lists->string form (list 'if nexpr true false-true))) - (lists->string form + (lists->string form (simplify-boolean `(and (not (or ,expr (not ,false-test))) ,false-true) () () env)))))))) ;; (if (and x y) ... (if (and x z) ...)) gets 3 hits (one tricky) - + (when (and (len=3? true) (eq? (car true) 'if) (= (length false) 3) @@ -16284,7 +16301,7 @@ `(let ((<1> (if ,expr ,(car true-rest) ,(car false-rest)))) (if <1> ,@(cdr true-rest))) `(if (if ,expr ,(car true-rest) ,(car false-rest)) ,@(cdr true-rest))))))) - + ((map) ; (if (null? x) () (map abs x)) -> (map abs x) (when (and (len>1? expr) (eq? (car expr) 'null?) @@ -16294,7 +16311,7 @@ (or (null? (cddr false-rest)) (not (side-effect? (cddr false-rest) env)))) (lint-format "perhaps ~A" caller (lists->string form false)))) - + ((case) (if (and (pair? expr) (pair? false-rest) @@ -16305,11 +16322,11 @@ (lists->string form `(case ,(car false-rest) ,(case-branch expr (car false-rest) (list true)) ,@(cdr false-rest)))))) - + ((else) ; (if x (f y) (else z)) ! -- this gets 3 hits (if (not (var-member 'else env)) (lint-format "else (as car of false branch of if) makes no sense: ~A" caller form)))) - + (let ((false-test (and (pair? false-rest) (car false-rest)))) (if (and (eq? (car false) 'if) ; (if x 3 (if (not x) 4)) -> (if x 3 4) (> (or (length false-rest) 0) 1) ; proper-list and len>1? @@ -16320,12 +16337,12 @@ (eq? (car false-test) 'not) (equal? expr (cadr false-test))) (lint-format "perhaps ~A" caller (lists->string form (list 'if expr true (cadr false-rest))))))) - - (if (and (eq? (car false) 'if) ; (if test0 expr (if test1 expr)) -> if (or test0 test1) expr) + + (if (and (eq? (car false) 'if) ; (if test0 expr (if test1 expr)) -> if (or test0 test1) expr) (len=2? false-rest) ; other case is dealt with above (equal? true (cadr false-rest))) (let ((test1 (simplify-boolean (list 'or expr false-test) () () env))) - (lint-format "~Aperhaps ~A" caller + (lint-format "~Aperhaps ~A" caller (if (equal? expr false-test) "weird repetition! " "") (lists->string form (list 'if test1 true)))))))) @@ -16340,9 +16357,9 @@ (len=2? (cdr test))) (let ((rel-arg1 (cadr test)) (rel-arg2 (caddr test))) - + ;; (if (< x y) (set! x y) -> (set! x (max x y)) - (case true-op + (case true-op ((set!) (when (len>1? true-rest) (let ((settee (car true-rest)) @@ -16352,11 +16369,11 @@ (let ((f (if (equal? settee (if (memq test-op '(< <=)) rel-arg1 rel-arg2)) 'max 'min))) (lint-format "perhaps ~A" caller (lists->string form (list 'set! settee (cons f true-rest))))))))) - + ;; (if (<= (list-ref ind i) 32) (list-set! ind i 32)) -> (list-set! ind i (max (list-ref ind i) 32)) ((list-set! vector-set!) (when (len>1? (cdr true-rest)) - (let ((settee (car true-rest)) + (let ((settee (car true-rest)) (index (cadr true-rest)) (setval (caddr true-rest))) (let ((mx-op (if (and (equal? setval rel-arg1) @@ -16385,7 +16402,7 @@ (let ((f (if (equal? (cadr test) (if (memq (car test) '(< <=)) true false)) 'min 'max))) (lint-format "perhaps ~A" caller (lists->string form (list f true false))))))) - + ;; -------- if+if->and -------- (define (if+if->and caller form expr true env) (let ((true-op (car true)) @@ -16398,8 +16415,8 @@ (list 'not (car true-rest)))) () () env))) ;; (if (and (< x 1) y) (when z (display z) x)) -> (when (and (< x 1) y z) (display z) x) - (lint-format "perhaps ~A" caller - (lists->string form + (lint-format "perhaps ~A" caller + (lists->string form (if (and (len>1? test1) (eq? (car test1) 'not)) (cons 'unless (cons (cadr test1) (cdr true-rest))) @@ -16407,15 +16424,15 @@ ((len=1? (cdr true-rest)) (let ((test1 (simplify-boolean (list 'and expr (car true-rest)) () () env))) (lint-format "perhaps ~A" caller (lists->string form (list 'if test1 (cadr true-rest)))))) - + ((equal? expr (car true-rest)) (lint-format "perhaps ~A" caller (lists->string form true))) - + ((and (equal? (car true-rest) (list 'not expr)) (len>1? (cdr true-rest))) - (lint-format "perhaps ~A" caller + (lint-format "perhaps ~A" caller (lists->string form (caddr true-rest))))))) - + ;; -------- combine-if -------- (define (combine-if caller form expr true false env) (let ((true-op (and (pair? true) (car true))) @@ -16438,8 +16455,8 @@ (lists->string form (list 'if expr true-true false)))) (if (equal? false true-false) ;; (if a (if b B A) A) -> (if (and a b) B A) - (lint-format "perhaps ~A" caller - (lists->string form + (lint-format "perhaps ~A" caller + (lists->string form (simplify-boolean (if (not false) (list 'and expr true-test true-true) @@ -16447,14 +16464,14 @@ () () env))) (if (equal? false true-true) ;; (if a (if b A B) A) -> (if (and a (not b)) B A) - (lint-format "perhaps ~A" caller - (lists->string form + (lint-format "perhaps ~A" caller + (lists->string form (simplify-boolean (if (not false) (list 'and expr (list 'not true-test) true-false) (list 'if (list 'and expr (list 'not true-test)) true-false false)) () () env))))) - + ;; (if a (if b d e) (if c d e)) -> (if (if a b c) d e)? reversed does not happen. ;; (if a (if b d) (if c d)) -> (if (if a b c) d) ;; (if a (if b d e) (if (not b) d e)) -> (if (eq? (not a) (not b)) d e) @@ -16471,7 +16488,7 @@ (equal? (cadr true-test) false-test)) (cons 'if (cons (list 'not (list 'eq? (list 'not expr) true-test)) (cdr true-rest)))) - + ((and (len>1? false-test) (eq? (car false-test) 'not) (equal? true-test (cadr false-test))) @@ -16484,7 +16501,7 @@ 12) `(let ((<1> (if ,expr ,true-test ,false-test))) (if <1> ,@(cdr true-rest)))) - + (else (cons 'if (cons (list 'if expr true-test false-test) (cdr true-rest)))))))))) (begin ; (length true) != 4 @@ -16492,13 +16509,13 @@ (lint-format "perhaps ~A" caller ; (if a (if (not a) B) A) -> (if (not a) A) (lists->string form (list 'if (list 'not expr) false)))) (if (equal? expr true-test) ; (if x (if x z) w) -> (if x z w) - (lint-format "perhaps ~A" caller + (lint-format "perhaps ~A" caller (lists->string form (list 'if expr true-true false)))) (if (equal? false true-true) ; (if a (if b A) A) (lint-format "perhaps ~A" caller (let ((nexpr (simplify-boolean (list 'or (list 'not expr) true-test) () () env))) (lists->string form (list 'if nexpr false))))))))))) - + ;; -------- evert-if -------- (define (evert-if caller form expr true false env) ;; move repeated start/end statements out of the if @@ -16524,7 +16541,7 @@ (let ((new-true (cdr ltrue)) (new-false (cdr lfalse))) (when (pair? end) - (set! new-true (copy new-true (make-list (- true-len 2)))) ; (copy lst ()) -> () + (set! new-true (copy new-true (make-list (- true-len 2)))) ; (copy lst ()) -> () (set! new-false (copy new-false (make-list (- false-len 2))))) (when (pair? start) (if (pair? new-true) (set! new-true (cdr new-true))) @@ -16533,16 +16550,16 @@ (and (pair? new-true) (pair? new-false))) ; otherwise the rewrite changes the returned value (if (pair? new-true) - (set! new-true (if (null? (cdr new-true)) + (set! new-true (if (null? (cdr new-true)) (car new-true) (cons 'begin new-true)))) (if (pair? new-false) - (set! new-false (if (null? (cdr new-false)) + (set! new-false (if (null? (cdr new-false)) (car new-false) (cons 'begin new-false)))) ;; (if x (display y) (begin (set! z y) (display y))) -> (begin (if (not x) (set! z y)) (display y)) (lint-format "perhaps ~A" caller - (lists->string form + (lists->string form (let ((body (if (null? new-true) (list 'if (list 'not expr) new-false) (if (null? new-false) @@ -16551,7 +16568,7 @@ `(begin ,@start ,body ,@end)))))))))))) - + ;; -------- if+let->when -------- (define (if+let->when caller form expr true false) ;; if+let() -> when: about a dozen hits @@ -16600,16 +16617,16 @@ (len=1? (cdr true)) (equal? expr (cadr true))) (lint-format "perhaps ~A" caller - (lists->string form + (lists->string form (if (eq? false 'no-false) (list 'cond (list expr '=> (car true))) (list 'cond (list expr '=> (car true)) (list 'else false))))))) - + ;; -------- unrepeat-test -------- (define (unrepeat-test caller form expr true false) ;; move repeated test to top, if no inner false branches -- aren't we assuming A does not affect B? yes, but this never happens. ;; (if A (if B C) (if B D)) -> (if B (if A C D)) - (when (and (len=3? true) + (when (and (len=3? true) (len=3? false) (eq? (car true) 'if) (eq? (car false) 'if) @@ -16629,7 +16646,7 @@ (equal? (cadr true) (cadr false))) (let ((true-rest (and (pair? true) (cdr true))) (false-rest (and (pair? false) (cddr false)))) - (if (and (equal? (cadr true-rest) (cadr false-rest)) ; (if A (if B a b) (if B b a)) -> (if (eq? (not A) (not B)) a b) + (if (and (equal? (cadr true-rest) (cadr false-rest)) ; (if A (if B a b) (if B b a)) -> (if (eq? (not A) (not B)) a b) (equal? (caddr true-rest) (car false-rest))) (let* ((switch #f) (a (if (and (pair? expr) @@ -16641,7 +16658,7 @@ (begin (set! switch (not switch)) (car true-rest)) (simplify-boolean (list 'not (car true-rest)) () () env)))) (lint-format "perhaps ~A" caller - (lists->string form + (lists->string form (if switch `(if (eq? ,a ,b) ,(car false-rest) ,(cadr true-rest)) `(if (eq? ,a ,b) ,(cadr true-rest) ,(car false-rest)))))) @@ -16650,7 +16667,7 @@ (if (equal? (cadr true-rest) (car false-rest)) ; (if A (if B a b) (if B a c)) -> (if B a (if A b c)) (lint-format "perhaps ~A" caller (lists->string form - `(if ,(car true-rest) ,(cadr true-rest) + `(if ,(car true-rest) ,(cadr true-rest) (if ,expr ,(caddr true-rest) ,(cadr false-rest))))) (if (equal? (caddr true-rest) (cadr false-rest)) ; (if A (if B a b) (if B c b)) -> (if B (if A a c) b) (lint-format "perhaps ~A" caller @@ -16658,7 +16675,7 @@ `(if ,(car true-rest) (if ,expr ,(cadr true-rest) ,(car false-rest)) ,(caddr true-rest))))))))))) - + ;; -------- if->case-else -------- (define (if->case-else caller form test true false) ; (if (eq? (caddr x) 'a) b (caddr x)) -> (case (caddr x) ((a) b) (else)) (when (and (not (= last-let->case-line-number line-number)) @@ -16693,10 +16710,10 @@ (if (or (member false test) (and (len=2? false) (member (cadr false) test))) - `(case ,selector + `(case ,selector ((,key) ,true) (else ,@(if (member false test) () (list '=> (car false))))) - `(case ,selector + `(case ,selector ((,key) ,@(if (member true test) () (list '=> (car true)))) (else ,false)))))))) @@ -16718,7 +16735,7 @@ ,(if (pair? (cdddr false)) (cons 'or (cddr false)) (caddr false)))) - `(begin ,true (when ,(simplify-boolean (list 'not expr) () () env) + `(begin ,true (when ,(simplify-boolean (list 'not expr) () () env) ,@(cddr false)))))) (if (and (len>2? true) (memq (car true) '(or begin)) ; (if A (or (f x)...) (f x)) -> (or (f x) (and A (or ...))) @@ -16746,7 +16763,7 @@ (let ((test (cadr form))) (unless (equal? expr test) ; (or (not (pair? x)) (not (pair? z))) -> (not (and (pair? x) (pair? z))) ; (and (equal? (car x) (car orig)) (equal? (cdr x) (cdr orig))) -> (equal? x orig) - (lint-format "perhaps ~A" caller (lists->string test expr))) + (lint-format "perhaps ~A" caller (lists->string test expr))) ;; (if (cond...)...) doesn't happen much and is tricky to rewrite ;; (if ([=] x y) (f x) (f y)) gets only 2 hits, (if ([=] x y) x y) gets 1 hit -- are these so dumb we can't ignore them? @@ -16761,25 +16778,25 @@ (if->or/and caller form test true false env) (if->when caller form test expr true false) ; test is for a reasonable line number, expr is for a corrected test (sigh) (move-cond-outward caller form expr true false env) - + (when (= len 4) (combine-if caller form expr true false env) (when (pair? false) (move-false-outward caller form expr true false env))) - + (when (and (eq? false 'no-false) (pair? true)) (if->min/max caller form test true) (if+if->and caller form expr true env)) (inverted-if->min/max caller form test true false) (if->bool caller form expr true false env (= suggestion made-suggestion)) - + (when (pair? true) (repeated-test->cond caller form expr true false) (simplify-if+ifs caller form expr true false env)) #| ;; (if (not (eq? x y)) (set! x y)) -> (set! x y) - (if (and (= len 3) + (if (and (= len 3) (pair? test) (eq? (car test) 'not) (eq? (car true) 'set!) @@ -16789,7 +16806,7 @@ (lint-format "perhaps ~A -> ~A" caller (truncated-list->string form) true)) ;; (if (eq? x y) (not (eq? x y))) (if (and (eq? (car true) 'not) - (pair? (cdr true)) + (pair? (cdr true)) (pair? (cadr true)) (equal? test (cadr true))) (lint-format "perhaps ~A -> ~A" caller (truncated-list->string form) `(if ,test #f)))) @@ -16799,7 +16816,7 @@ (not (= line-number last-if-line-number))) (if->cond caller form env) (if+let->when caller form expr true false) - + (when (= len 4) (when (= suggestion made-suggestion) ; not redundant (if->cond above) (shorter-branch-first caller form expr true false env)) @@ -16818,15 +16835,15 @@ (lint-walk caller expr env)) (if (symbol? true) (set-ref true caller form env) - (set! env (lint-walk caller true env))) + (set! env (lint-walk caller true env))) (if (symbol? false) (if (not (eq? false 'no-false)) (set-ref false caller form env)) (set! env (lint-walk caller false env)))))) env)) (hash-walker 'if if-walker)) - - + + ;; -------- when, unless -------- (let () (define (when-walker caller form env) @@ -16836,12 +16853,12 @@ env) (let ((test (cadr form)) (head (car form))) - + ;; when->unless and vice versa (if (and (pair? test) (eq? (car test) 'not)) ; (when (not a) (set! x y)) -> (unless a (set! x y)) (lint-format "perhaps ~A" - caller + caller (truncated-lists->string form (cons (if (eq? head 'when) 'unless 'when) (cons (cadr test) @@ -16850,7 +16867,7 @@ (lint-format "~A test is never false: ~A" caller head (truncated-list->string form)) (if (never-true test) ; (unless #f...) (lint-format "~A test is never true: ~A" caller head (truncated-list->string form)))) - + (if (symbol? test) (begin (set-ref test caller form env) @@ -16859,7 +16876,7 @@ (pair? (caddr form))) (if (memq test (caddr form)) (and-incomplete form head test (caddr form) env) - (do ((p (caddr form) (cdr p))) + (do ((p (caddr form) (cdr p))) ((or (not (pair? p)) (and (pair? (car p)) (memq test (car p)))) @@ -16920,23 +16937,23 @@ (lint-walk-open-body caller head (cddr form) env)))) (hash-walker 'when when-walker) (hash-walker 'unless when-walker)) - - + + ;; -------- check-results -------- ;; called in cond, case, and do for => primarily (define (check-results caller syn clause sequel env) (cond ((not (pair? sequel)) (if (not (null? sequel)) ; (not (null?...)) here is correct -- we're looking for stray dots (lint-format "~A clause is messed up: ~A" caller syn (truncated-list->string clause)))) - + ((not (eq? (car sequel) '=>)) (lint-walk-open-body caller syn sequel env)) - + ((or (not (pair? (cdr sequel))) (pair? (cddr sequel))) ;; (cond (x =>)) (lint-format "~A => target is messed up: ~A" caller syn (truncated-list->string clause))) - + (else (let ((f (cadr sequel))) (if (symbol? f) (let ((val (symbol->value f *e*))) @@ -16946,7 +16963,7 @@ (lint-format "=> target (~A) may be unhappy: ~A" caller f clause)) (let ((sig (signature val))) (if (len>1? sig) - (let ((from-type (->lint-type ((if (or (memq syn '(cond do-result)) + (let ((from-type (->lint-type ((if (or (memq syn '(cond do-result)) (not (pair? (car clause)))) car caar) clause))) (to-type (cadr sig))) @@ -16964,7 +16981,7 @@ (not (= (length (cadr f)) 1))) (lint-format "=> target (~A) may be unhappy: ~A" caller f clause))) (lint-walk caller f env))))) - + ;; ---------------- cond ---------------- (let () @@ -17034,7 +17051,7 @@ (lists->string form (append header (cons (list 'if (car first-clause) fmid emid) trailer)))))))) ;; len > 2 so use cond in the revision (let ((middle (map (lambda (c) - (if (and else-error + (if (and else-error (eq? c else-clause)) else-clause (let ((test (car c)) @@ -17048,7 +17065,7 @@ (lint-format "perhaps ~A" caller (lists->string form (append header (cons (cons 'cond middle) trailer))))))))) (partition-form (cdr form) (if else-error (- len 1) len))))) - + ;; not escaping else here because the trailing args might be evaluated first (when (and (not (hash-table-ref syntaces (car first-result))) (lint-every? (lambda (c) @@ -17073,7 +17090,7 @@ (list (car c) (caadr c))) (cdr form))) (cdr first-result))))))))))))) - + ;; -------- cond->or -------- (define (cond->or caller form all-eqv eqv-select simplifications env) (do ((new-clauses ()) @@ -17084,12 +17101,12 @@ (unless (and len2 ; i.e. don't go to check-bool-cond (check-bool-cond caller form (cadr new-clauses) (car new-clauses) env)) ;; (cond ((= x 3) 3) ((= x 2) 4) ((= x 1) 4)) -> (case x ((3) 3) ((2 1) 4)) - (lint-format "perhaps ~A" caller - (lists->string + (lint-format "perhaps ~A" caller + (lists->string form (cond (all-eqv (cond->case eqv-select (reverse new-clauses))) - ((not (and len2 + ((not (and len2 (memq (caar new-clauses) '(else #t)) (len=1? (cadr new-clauses)) (pair? (caadr new-clauses)) @@ -17098,7 +17115,7 @@ ((null? (cddar new-clauses)) ; (cond (A) (B) (else C)) -> (or A B C) `(or ,@(cdaadr new-clauses) ,(cadar new-clauses))) (else `(or ,@(cdaadr new-clauses) (begin ,@(cdar new-clauses)))))))))) - + (let* ((clause (car clauses)) (result (cdr clause))) ; can be null in which case the test is the result (cond ((and (pair? simplifications) @@ -17111,7 +17128,7 @@ (if (pair? current-clauses) (begin (set! current-clauses (cons clause current-clauses)) - (set! new-clauses (cons + (set! new-clauses (cons (cons (simplify-boolean (cons 'or (map car (reverse current-clauses))) () () env) result) new-clauses)) @@ -17126,9 +17143,9 @@ (sym-access #f) (start #f) (changed #f)) - + ;; extending this to memx possibilities got only 1 hit and involved ca. 20 lines - + (define (car-with-expr cls) (cond ((and (pair? simplifications) (assq cls simplifications)) @@ -17136,22 +17153,22 @@ (set! changed #t) (cons (cdr e) (cdr cls)))) (else cls))) - + (define (start-search clauses test) (if (code-constant? (cadr test)) - (if (memq (car test) '(= string=? string-ci=? eq? eqv? equal? char=? char-ci=?)) + (if (memq (car test) '(= string=? string-ci=? eq? eqv? equal? char=? char-ci=?)) (set! sym-access caddr)) (if (code-constant? (caddr test)) (set! sym-access cadr))) - (if sym-access + (if sym-access (begin (set! start clauses) (set! op (car test))) (set! nc (cons (car-with-expr (car clauses)) nc)))) - + (do ((clauses (cdr form) (cdr clauses))) ((null? clauses) - (if (and changed + (if (and changed (null? clauses)) ;; (cond ((< x 2) 3) ((> x 0) 4) ((< x 2) 5)) -> (cond ((< x 2) 3) ((> x 0) 4)) (lint-format "perhaps ~A" caller @@ -17173,13 +17190,13 @@ (not (null? (cdr clauses)))) (start-search clauses test) (set! nc (cons (car-with-expr (car clauses)) nc))) - + (unless (and looks-ok (eq? (car test) op) (equal? (sym-access test) (sym-access (caar start))) (code-constant? ((if (eq? sym-access cadr) caddr cadr) test)) (not (set! ok-but-at-end (null? (cdr clauses))))) - + (if (eq? (cdr start) clauses) ; only one item in the block, or two but it's just two at the end (begin (set! nc (cons (car start) nc)) @@ -17189,7 +17206,7 @@ (begin (set! start #f) (set! nc (cons (car-with-expr (car clauses)) nc))))) - + ;; multiple hits -- can we combine them? (let ((alist ()) (cc (if (eq? sym-access cadr) caddr cadr))) @@ -17199,27 +17216,27 @@ (null? sc) (eq? sc clauses)) (case op - ((eq?) + ((eq?) (set! nc (cons `((assq ,(sym-access (caar start)) ',(reverse alist)) => cdr) nc))) - - ((eqv? char=?) + + ((eqv? char=?) (set! nc (cons `((assv ,(sym-access (caar start)) ',(reverse alist)) => cdr) nc))) - - ((equal?) + + ((equal?) (set! nc (cons `((assoc ,(sym-access (caar start)) ',(reverse alist)) => cdr) nc))) - + ((string=?) ;; this is probably faster than assoc + string=?, but it creates symbols (let ((nlst (map (lambda (c) (cons (string->symbol (car c)) (cdr c))) alist))) (set! nc (cons `((assq (string->symbol ,(sym-access (caar start))) ',(reverse nlst)) => cdr) nc)))) - - (else + + (else (set! nc (cons `((assoc ,(sym-access (caar start)) ',(reverse alist) ,op) => cdr) nc))))) - + (set! alist (cons (cons (unquoted (cc (caar sc))) (unquoted (cadar sc))) alist))) - + (if (and looks-ok (not (null? (cdr clauses)))) (start-search clauses test) @@ -17242,7 +17259,7 @@ (equal? (cdr c1) (cdr c2))) (lint-format "perhaps ~A" caller (lists->string form - `(if (or ,(car c1) ,(car c2)) + `(if (or ,(car c1) ,(car c2)) ,(if (null? (cddr c1)) (cadr c1) (cons 'begin (cdr c1))))))) @@ -17255,7 +17272,7 @@ (when (and (< (+ c1-len c2-len) 100) (> (* c1-len 4) c2-len)) ; maybe 4 is too much (lint-format "perhaps ~A" caller - (lists->string form + (lists->string form (if (or (pair? (cddr c1)) (pair? (cddr c2))) `(cond (,(cadar c1) ,@(cdr c2)) (else ,@(cdr c1))) @@ -17274,16 +17291,16 @@ (boolean? (cadr first-clause)))) (or (null? (cdr last-clause)) (null? (cddr last-clause)))) - + (if (and (pair? (cdr first-clause)) (not (cadr first-clause)) ; (cond (A #f) (B #t) (else C)) -> (and (not A) (or B C)) (or (null? (cdr last-clause)) (eq? (cadr last-clause) #t))) (lint-format "perhaps ~A" caller - (lists->string form - (simplify-boolean + (lists->string form + (simplify-boolean `(and (not ,(car first-clause)) - (or ,(car last-clause) + (or ,(car last-clause) ,@(if (null? (cdr else-clause)) else-clause (cons 'begin else-clause)))) @@ -17293,10 +17310,10 @@ (not (car else-clause)) (null? (cdr else-clause))) (lint-format "perhaps ~A" caller - (lists->string form + (lists->string form `(or ,(car first-clause) (and ,@last-clause))))))) - + (when (and (proper-list? else-clause) (equal? (cdr first-clause) else-clause) ; a = else result (pair? (cdr last-clause)) ; b does exist @@ -17312,20 +17329,20 @@ (cond ((not (and (null? (cdr a)) (null? (cdr b)))) `(cond (,nexpr ,@a) (else ,@b))) - + ((eq? (car a) #t) (if (not (car b)) nexpr (simplify-boolean (list 'or nexpr (car b)) () () env))) - + ((car a) ; i.e a is not #f (list 'if nexpr (car a) (car b))) - + ((eq? (car b) #t) (simplify-boolean (list 'not nexpr) () () env)) - + (else (simplify-boolean `(and (not ,nexpr) ,(car b)) () () env))))))))))) - + ;; -------- simple-cond->if -------- (define (simple-cond->if caller form suggest) (let ((clause (cadr form))) ; (cond (a)) -> a, (cond (a b)) -> (if a b) etc @@ -17336,8 +17353,8 @@ (or (pair? (cddr clause)) (= suggest made-suggestion))) ;; (cond ((= x 1) 32)) -> (if (= x 1) 32) - (lint-format "perhaps ~A" caller - (lists->string form + (lint-format "perhaps ~A" caller + (lists->string form (if (null? (cddr clause)) (list 'if (car clause) (cadr clause)) (if (and (pair? (car clause)) @@ -17360,7 +17377,7 @@ (let ((expr (simplify-boolean `(or ,(car a) (not ,(car b))) () () env))) (lint-format "perhaps ~A" caller (lists->string form `(cond ,(if (> len 4) '... (cadr form)) - (,expr ,@(cdr a)) + (,expr ,@(cdr a)) (else ,@(cdr b))))))))) ;; -------- combine-repeated-tests -------- @@ -17378,20 +17395,20 @@ (cond ((memq (car c) '(#t else)) (set! else-result (cdr c)) (set! else-leaves (tree-leaves else-result))) - + ((not (and (pair? (car c)) (or (eq? (caar c) 'and) (member (car c) reps)))) (set! exprs ()) (set! reps ()) (set! ctr 0)) - + ((null? exprs) (set! head-len pos) (set! exprs (cdar c)) (set! reps exprs) (set! ctr 1)) - + (else (set! ctr (+ ctr 1)) (set! reps (remove-if (lambda (rc) @@ -17406,7 +17423,7 @@ ;; (cond ((pair? z) 32) ((not (pair? x)) 0) ((pair? w) 12) (else 2)) (lint-format "perhaps ~A" caller (lists->string form - (let ((not-reps + (let ((not-reps (simplify-boolean (list 'not (if (null? (cdr reps)) (car reps) (cons 'and reps))) @@ -17465,7 +17482,7 @@ `(if ,@(cadr form) ,else-case)) `(cond ,@(copy (cdr form) (make-list (- elen ctr))) (else ,else-case)))))))))))) - + ;; -------- combine-conds -------- (define (combine-conds caller form has-else len env) (let ((last-clause (list-ref form (if has-else (- len 1) len)))) ; not the else branch! -- just before it. @@ -17473,10 +17490,10 @@ (pair? (cadr last-clause)) (memq (caadr last-clause) '(if cond))) (let ((new-test (simplify-boolean (list 'not (car last-clause)) () () env)) - (new-result (if has-else + (new-result (if has-else (cdr (list-ref form len)) - (if (eq? form lint-mid-form) - () + (if (eq? form lint-mid-form) + () (list #<unspecified>))))) (if (and (eq? (caadr last-clause) 'cond) (proper-list? (cdadr last-clause))) @@ -17506,7 +17523,7 @@ ((or (not (pair? p)) (= i lim))) (let ((nc (car p))) - (if (and (len=2? nc) + (if (and (len=2? nc) (pair? (cadr nc)) (eq? (caadr nc) 'cond) (>= (length (cdadr nc)) (* 2 k)) @@ -17585,14 +17602,14 @@ ;; (cond ((and A B) c) (B d) (else e)) -> (cond (B (if A c d)) (else e)) (lint-format "perhaps ~A" caller (lists->string form - (cons 'cond + (cons 'cond (cons (list (car arg2) - (list 'if + (list 'if ((if (equal? (car arg2) (cadar arg1)) caddar cadar) arg1) (cadr arg1) (cadr arg2))) (cdddr form)))))))) - + ;; -------- cond-combine-into-else -------- (define (cond-combine-into-else caller form last-clause len) (if (and (len=1? last-clause) ; (cond ... ((or ...)) (else ...)) -> (cond ... (else (or ... ...))) @@ -17626,10 +17643,10 @@ (lint-format "perhaps ~A" caller (lists->string form (append (copy form (make-list (- len 1))) - (list (list 'else (if (car else-clause) + (list (list 'else (if (car else-clause) (list 'not (car last-clause)) (car last-clause))))))))))) - + ;; -------- cond-scan-clauses -------- (define (cond-scan-clauses caller form len env) (let ((ctr 0) @@ -17656,7 +17673,7 @@ (eq? (cadr clause) '=>))) ; case sends selector, but cond sends test result (cond-eqv? (car clause) eqv-select #t))) (when (and (not all-eqv) - eqv-select + eqv-select (pair? (car clause)) (eq? (caar clause) 'not) (pair? (cdar clause)) @@ -17674,17 +17691,17 @@ (equal? (cadar prev-clause) (cadar clause)) ; args match (subsumes? prev-bool (caar clause))) ; previous test already included this case (lint-format "~A makes ~A pointless in ~A~A" caller - (car prev-clause) + (car prev-clause) (car clause) (truncated-list->string form) (if (eq? prev-bool 'list?) (format #f "~%~NC(r5rs list? is proper-list? in s7)" (+ lint-left-margin 4) #\space) ""))) (set! prev-bool (caar clause)))) - + (if (and (pair? prev-clause) ; i.e. not #f (not has-combinations) - (> len 2) + (> len 2) (equal? (cdr clause) (cdr prev-clause))) (if (memq (car clause) '(else #t)) ; (cond ... (x z) (else z)) -> (cond ... (else z)) (unless (side-effect? (car prev-clause) env) @@ -17692,14 +17709,14 @@ (lint-format "this clause could be omitted: ~A" caller (truncated-list->string prev-clause))) (set! has-combinations #t))) ; handle these later (set! prev-clause clause) - + (let ((expr (simplify-boolean (car clause) trues falses env)) (test (car clause)) (sequel (cdr clause)) (first-sequel (and (pair? (cdr clause)) (cadr clause)))) (if (not (equal? expr test)) (set! simplifications (cons (cons clause expr) simplifications))) - + (when (and (pair? falses) ; (cond ((not x) y) ((string=? x z)...)) (pair? (car falses)) (eq? (caar falses) 'not) @@ -17707,13 +17724,13 @@ (pair? test) (memq (cadar falses) test)) (and-incomplete form 'if2 (cadar falses) test env)) - + (if (symbol? test) (if (and (not (eq? test 'else)) (pair? first-sequel)) (if (memq test first-sequel) (and-incomplete form 'cond test first-sequel env) - (do ((p first-sequel (cdr p))) + (do ((p first-sequel (cdr p))) ((or (not (pair? p)) (and (pair? (car p)) (memq test (car p)))) @@ -17724,43 +17741,43 @@ (hash-table-ref bools (car test))) (if (member (cadr test) first-sequel) (and-forgetful form 'cond test first-sequel env) - (do ((p first-sequel (cdr p))) + (do ((p first-sequel (cdr p))) ((or (not (pair? p)) (and (pair? (car p)) (member (cadr test) (car p)))) (if (pair? p) (and-forgetful form 'cond test (car p) env))))))) ;; code here to check every arg against its use in the sequel found no problems?!? - + (if (and (len>1? sequel) (memq '=> (cdr sequel))) (lint-format "'=> has no effect here: ~A~%" caller (truncated-list->string clause))) ;; args>1 never happens so no need for mismatch check - + (cond ((memq test '(else #t)) (set! has-else #t) - + (when (pair? sequel) (if (eq? first-sequel #<unspecified>) ; (cond ((= x y) z) (else #<unspecified>) (lint-format "this #<unspecified> is redundant: ~A" caller clause)) - + (when (and (pair? first-sequel) ; (cond (a A) (else (cond ...))) -> (cond (a A) ...) (memq (car first-sequel) '(if cond when unless))) - + (if (null? (cdr sequel)) (case (car first-sequel) ((cond) ;; (cond ((< x 1) 2) (else (cond ((< y 3) 2) (#t 4)))) - (lint-format "else clause could be folded into the outer cond: ~A" caller - (lists->string form (append (copy form (make-list ctr)) + (lint-format "else clause could be folded into the outer cond: ~A" caller + (lists->string form (append (copy form (make-list ctr)) (cdr first-sequel))))) ((if) ;; (cond (a A) (else (if b B))) (when (and (len>1? (cdr first-sequel)) (proper-list? first-sequel)) - (lint-format "else clause could be folded into the outer cond: ~A" caller - (lists->string form - (append (copy form (make-list ctr)) + (lint-format "else clause could be folded into the outer cond: ~A" caller + (lists->string form + (append (copy form (make-list ctr)) (if (= (length first-sequel) 3) (list (cdr first-sequel)) `((,(cadr first-sequel) ,@(unbegin (caddr first-sequel))) @@ -17768,13 +17785,13 @@ ((when unless) ;; (cond (a A) (else (when b B))) (when (> (length first-sequel) 2) - (lint-format "else clause could be folded into the outer cond: ~A" caller - (lists->string form + (lint-format "else clause could be folded into the outer cond: ~A" caller + (lists->string form (append (copy form (make-list ctr)) (if (eq? (car first-sequel) 'when) `((,(cadr first-sequel) ,@(cddr first-sequel))) `(((not ,(cadr first-sequel)) ,@(cddr first-sequel)))))))))) - + ;; combine else -> cond if the trailing result is very simple (it will be repeated) (when (and (pair? (cdr sequel)) (null? (cddr sequel)) @@ -17783,8 +17800,8 @@ (case (car first-sequel) ((cond) ;; (cond (A a) (B b) (else (cond (C c) (D d)) #t)) -> (cond (A a) (B b) (C c #t) (D d #t) (else #t)) - (lint-format "else clause could be folded into the outer cond: ~A" caller - (lists->string form (append (copy form (make-list ctr)) + (lint-format "else clause could be folded into the outer cond: ~A" caller + (lists->string form (append (copy form (make-list ctr)) (map (lambda (c) (append c (list result))) (cdr first-sequel)) @@ -17795,8 +17812,8 @@ ;; (cond (A a) (B b) (else (if C c d) #t)) -> (cond (A a) (B b) (C c #t) (else d #t) (when (and (len>1? (cdr first-sequel)) (proper-list? first-sequel)) - (lint-format "else clause could be folded into the outer cond: ~A" caller - (lists->string form + (lint-format "else clause could be folded into the outer cond: ~A" caller + (lists->string form (append (copy form (make-list ctr)) (if (= (length first-sequel) 3) `((,@(cdr first-sequel) ,result) @@ -17806,8 +17823,8 @@ ((when unless) ;; (cond (A a) (B b) (else (unless C c d) #t)) -> (cond (A a) (B b) ((not C) c d #t) (else #t)) (when (> (length first-sequel) 2) - (lint-format "else clause could be folded into the outer cond: ~A" caller - (lists->string form + (lint-format "else clause could be folded into the outer cond: ~A" caller + (lists->string form (append (copy form (make-list ctr)) (if (eq? (car first-sequel) 'when) `((,(cadr first-sequel) ,@(cddr first-sequel) ,result) @@ -17815,18 +17832,18 @@ `(((not ,(cadr first-sequel)) ,@(cddr first-sequel) ,result) (else ,result))))))))))))))) ((not (= ctr len))) - + ((equal? test ''else) ;; (cond (x y) ('else z)) (lint-format "odd cond clause test: is 'else supposed to be else? ~A" caller (truncated-list->string clause))) - + ((and (eq? test 't) (not (var-member 't env))) ;; (cond ((= x 1) 1) (t 2) (lint-format "odd cond clause test: is t supposed to be #t? ~A" caller (truncated-list->string clause)))) - + (if (never-false expr) (if (not (= ctr len)) ;; (cond ((getenv s) x) ((= y z) w)) @@ -17837,37 +17854,37 @@ (if (never-true expr) ;; (cond ((< 3 1) 2)) (lint-format "cond test ~A is never true: ~A" caller (car clause) (truncated-list->string form)))) - + (unless (side-effect? test env) (cond ((or (memq test '(else #t)) (not (pair? sequel)) (pair? (cdr sequel)))) - + ((equal? test first-sequel) ;; (cond ((= x 0) x) ((= x 1) (= x 1))) (lint-format "no need to repeat the test: ~A" caller (lists->string clause (list test)))) - + ((and (len=2? first-sequel) (equal? test (cadr first-sequel))) (if (eq? (car first-sequel) 'not) ;; (cond ((> x 2) (not (> x 2)))) (lint-format "perhaps replace ~A with #f" caller first-sequel) ;; (cond (x (abs x))) - (lint-format "perhaps use => here: ~A" caller + (lint-format "perhaps use => here: ~A" caller (lists->string clause (list test '=> (car first-sequel)))))) - + ((and (eq? first-sequel #t) (pair? test) (not (memq (car test) '(or and))) (eq? (return-type (car test) env) 'boolean?)) ;; (cond ((null? x) #t) (else y)) (lint-format "this #t could be omitted: ~A" caller (truncated-list->string clause)))) - + (if (member test exprs) ;; (cond ((< x 2) 3) ((> x 0) 4) ((< x 2) 5)) (lint-format "cond test repeated: ~A" caller (truncated-list->string clause)) (set! exprs (cons test exprs)))) - + (if (boolean? expr) (if (not expr) ;; (cond ((< 3 1) 2)) @@ -17880,20 +17897,20 @@ ;; (cond (else 2) (x 3)) (lint-format "cond else clause is not the last: ~A" caller (truncated-list->string form))) (lint-walk caller test env))) - + (if (and (symbol? expr) (not (var-member expr env)) (procedure? (symbol->value expr *e*))) ;; (cond (< x 1) (else 1)) (lint-format "strange cond test: ~A in ~A is a procedure" caller expr clause)) - + (if (eq? result :unset) (set! result sequel) (if (not (equal? result sequel)) (set! result :unequal))) - + (check-results caller 'cond clause sequel env) - + (if (side-effect? expr env) (begin (set! falses ()) @@ -17907,16 +17924,16 @@ (not (member (cadr expr) trues))) (set! trues (cons (cadr expr) trues))) (if (eq? (car expr) 'or) - (for-each (lambda (p) + (for-each (lambda (p) (if (not (member p falses)) (set! falses (cons p falses)))) (cdr expr)))))))) (cdr form)) ; for-each clause - (if has-else + (if has-else (if (pair? result) ; all result clauses are the same (and not implicit) ;; (cond (x #t) (else #t)) -> #t - (lint-format "perhaps ~A" caller (lists->string form + (lint-format "perhaps ~A" caller (lists->string form (if (null? (cdr result)) (car result) (cons 'begin result))))) @@ -17924,15 +17941,15 @@ (list-ref form len))) (last-res (let ((clen (length last-clause))) (and (integer? clen) - (> clen 1) + (> clen 1) (list-ref last-clause (- clen 1)))))) (if (and (pair? last-res) (memq (car last-res) '(#t else))) ;; (cond (x y) (y z (else 3))) (lint-format "perhaps cond else clause is misplaced: ~A in ~A" caller last-res last-clause)))) - + (values has-else has-combinations simplifications all-eqv eqv-select eqv-change))) - + ;; -------- cond-walker -------- @@ -17942,40 +17959,40 @@ (not (check-bool-cond caller form (cadr form) (caddr form) env))) (cond-remove-not caller form env)) ;; not+repeat got 1 hit - + (when has-combinations (cond->or caller form all-eqv eqv-select simplifications env) (set! simplifications ()) (set! all-eqv #f)) - - ;; cond -> case + + ;; cond -> case (if all-eqv (if (> len (if has-else 2 1)) ; (cond (x y)) -- kinda dumb, but (if x y) isn't much shorter ;; (cond ((= x 0) x) ((= x 1) (= x 1))) -> (case x ((0) x) ((1) (= x 1))) (lint-format "perhaps use case instead of cond: ~A" caller (lists->string form (cond->case eqv-select (cdr form))))) - (when (and eqv-select + (when (and eqv-select (> len 1)) - (if (= len eqv-change) + (if (= len eqv-change) ;; (cond ((= x 0) 0) ((not (= x 1)) 1)) -> (case x ((0) 0) ((1) #<unspecified>) (else 1)) (if (not (equal? (car (list-ref form (- len 1))) (cadar (list-ref form len)))) (let ((new-cond (make-list (+ len 2)))) (copy form new-cond 0 eqv-change) - (list-set! new-cond len + (list-set! new-cond len (list (cadar (list-ref form len)) #<unspecified>)) - (list-set! new-cond (+ len 1) + (list-set! new-cond (+ len 1) (list 'else (cadr (list-ref form len)))) (lint-format "perhaps use case instead of cond: ~A" caller - (lists->string form + (lists->string form (cond->case eqv-select (cdr new-cond)))))) - (if (= len (+ eqv-change 1)) - ;; (cond ((= x 0) 0) ((not (= x 1)) 1) (else 2)) -> (case x ((0) 0) ((1) 2) (else 1)) + (if (= len (+ eqv-change 1)) + ;; (cond ((= x 0) 0) ((not (= x 1)) 1) (else 2)) -> (case x ((0) 0) ((1) 2) (else 1)) (let ((new-cond (make-list (+ len 1))) (last-clause (list-ref form len)) (next-to-last-clause (list-ref form (- len 1)))) (copy form new-cond 0 eqv-change) - (list-set! new-cond (- len 1) + (list-set! new-cond (- len 1) (list (cadar next-to-last-clause) (if (memq (car last-clause) '(#t else)) (cadr last-clause) @@ -17987,10 +18004,10 @@ ;; (cond ((= x 0) 0) ((not (= x 1)) 1) ((= x 2) 2)) -> (case x ((0) 0) ((1) #<unspecified>) (else 1)) ;; (cond ((= x 0) 0) ((not (= x 1)) 1) ((= x 1) 2)) -> (case x ((0) 0) ((1) 2) (else 1)) ;; (cond ((= x 1) 1) ((not (= x 2)) 2) ((not (= x 3)) 3)) -> (case x ((1) 1) ((2) 3) (else 2)) - (list-set! new-cond len + (list-set! new-cond len (list 'else (cadr (list-ref form (- len 1))))) (lint-format "perhaps use case instead of cond: ~A" caller - (lists->string form + (lists->string form (cond->case eqv-select (cdr new-cond))))))))) (if (and (= len 2) has-else @@ -18003,36 +18020,36 @@ ;; (cond ((a)) (else A)) -> (or (a) A) ;; but these two are not currently rewritten using if: (cond (A B) (else)) (cond (A B) (else C)) (lint-format "perhaps ~A" caller (lists->string form `(or ,(caadr form) ,else-clause))))) - + (unless (or has-combinations all-eqv) (cond->assoc caller form simplifications)) - + (when (and (> len 3) (= suggest made-suggestion)) (cond->case-at-end caller form len has-else)) - + (combine-repeated-tests caller form env) (if (= len 1) (simple-cond->if caller form suggest) (when has-else ; len > 1 here (let ((last-clause (list-ref form (- len 1)))) ; not the else branch! -- just before it. - + (when (and (= suggest made-suggestion) ; look for all results the same (len>1? (cadr form))) (cond-one-result caller form last-clause len env)) - + (when (= len 3) (simplify-cond caller form env)) - + (when (> len 3) (cond-repeated-else caller form len env)) - + (cond-partial-test-repeat caller form) (cond-combine-into-else caller form last-clause len)))) - + (combine-conds caller form has-else len env)) - - (define (cond-walker caller form env) + + (define (cond-walker caller form env) (let ((len (- (length form) 1)) (suggest made-suggestion)) (if (or (< len 1) @@ -18045,8 +18062,8 @@ (hash-walker 'cond cond-walker)) - - ;; ---------------- case ---------------- + + ;; ---------------- case ---------------- (let () ;; -------- case->header+case+trailer -------- @@ -18075,7 +18092,7 @@ (and (eq? c else-clause) else-error)))) (cdddr form))) - + ((lambda (header-len trailer-len result-mid-len) (when (and (>= header-len 0) (>= trailer-len 0) @@ -18108,9 +18125,9 @@ ;; len > 2 so use case in the revision (let ((midctr 0) (valctr 0)) - (let ((middle + (let ((middle (map (lambda (c) - (if (and else-error + (if (and else-error (eq? c else-clause)) else-clause (let ((test (car c)) @@ -18128,7 +18145,7 @@ (lint-format "perhaps ~A" caller (lists->string form `(,@header (case ,(cadr form) ,@middle) ,@trailer)))))))))) (partition-form (cddr form) (if else-error (- len 1) len)))))))) - + ;; -------- simplify-case -------- (define (simplify-case caller form selector env) ;; case->simpler expr (eq? memq etc) @@ -18144,23 +18161,23 @@ (lists->string form (let ((test (cond ((pair? (cdr keys)) `(memv ,(cadr form) ',keys)) - + ((and (symbol? (car keys)) (not (keyword? (car keys)))) `(eq? ,(cadr form) ',(car keys))) - + ((or (keyword? (car keys)) (null? (car keys))) (list 'eq? (cadr form) (car keys))) - + ((not (boolean? (car keys))) (list 'eqv? (cadr form) (car keys))) - + ((car keys) (cadr form)) - + (else (list 'not (cadr form))))) - + (op (if (len>1? (cdr clause)) 'when 'if))) (cons op (cons test (cdr clause))))))))) @@ -18179,8 +18196,8 @@ ;; can't use '= or 'char=? here because the selector may return anything ;; (case x ((#\a) 3) (else 4)) -> (if (eqv? x #\a) 3 4) ;; (case x ((a) #t) (else #f)) -> (eq? x 'a) - (lint-format "perhaps ~A" caller - (lists->string form + (lint-format "perhaps ~A" caller + (lists->string form (cond ((and (boolean? (cadar clauses)) (boolean? (cadadr clauses))) (if (cadadr clauses) @@ -18188,16 +18205,16 @@ (list op selector (if quoted (list 'quote keylist) keylist)))) ((not (cadadr clauses)) ; (else #f) happens a few times - (simplify-boolean + (simplify-boolean (if quoted `(and (,op ,selector ',keylist) ,(cadar clauses)) `(and (,op ,selector ,keylist) ,(cadar clauses))) () () env)) - + (quoted `(if (,op ,selector ',keylist) ,(cadar clauses) ,(cadadr clauses))) - - (else + + (else (let ((select-expr (if (and (eq? op 'eqv?) (boolean? keylist) (or (and (symbol? selector) @@ -18236,24 +18253,24 @@ (if (and (len>1? exprs) ; this gets no hits -- it paralells a similar bug in cond: (test expr => expr) (memq '=> (cdr exprs))) (lint-format "'=> has no effect here: ~A~%" caller (truncated-list->string clause))) - + (if (member exprs all-exprs) (set! exprs-repeated exprs) (set! all-exprs (cons exprs all-exprs))) - + (when (len=1? exprs) (if (or (equal? (car exprs) (cadr form)) ; (case x ((0 1) x) (else #f)) (and (pair? keys) (null? (cdr keys)) (code-constant? (car exprs)) (eqv? (car keys) (car exprs)))) - (lint-format "in ~A, the result can be ~Aomitted" caller + (lint-format "in ~A, the result can be ~Aomitted" caller clause (if (and (pair? (car exprs)) ; all this paranoia for one hit (equal? (car exprs) (cadr form)) (side-effect? (car exprs) env)) "probably " ""))) - + (when (and (len=2? (car exprs)) (equal? selector (cadar exprs))) (if (and (pair? keys) ; (case x ((0) (f x)) ((1) (not x))) @@ -18261,14 +18278,14 @@ (not (memq #f keys))) (lint-format "in ~A, perhaps replace ~A with #f" caller clause (car exprs)) (if (eq? keys 'else) - (lint-format "perhaps use => here: ~A" caller + (lint-format "perhaps use => here: ~A" caller (lists->string clause (list 'else '=> (caar exprs)))))))) - + (if (pair? keys) (if (not (proper-list? keys)) ;; (case x ((0) 1) ((1) 2) ((3 . 0) 4)) - (lint-format (if (null? keys) - "null case key list: ~A" + (lint-format (if (null? keys) + "null case key list: ~A" "stray dot in case case key list: ~A") caller (truncated-list->string clause)) (for-each @@ -18277,7 +18294,7 @@ (if (and (number? key) (nan? key)) (lint-format "case key ~S in ~S is unlikely to work" caller key clause) - (if (or (and (sequence? key) + (if (or (and (sequence? key) (not (null? key))) (memq (type-of key) '(procedure? macro? iterator? c-object? c-pointer? syntax? input-port? output-port? random-state?))) ;; (case x ((#(0)) 2)) or (apply case ...) @@ -18295,7 +18312,7 @@ ;; (case (string->symbol x) ((a) 1) ((2 3) 3)) (lint-format "case key ~S in ~S is pointless" caller key clause))) keys)) - + (if (not (eq? keys 'else)) ;; (case ((1) 1) (t 2)) (lint-format "bad case key ~S in ~S" caller keys clause) @@ -18305,7 +18322,7 @@ (if (not (= ctr len)) ;; (case x (else 2) ((0) 1)) (lint-format "case else clause is not the last: ~A" - caller + caller (truncated-list->string (cddr form))) (when (and (len=1? exprs) (len>1? (car exprs))) @@ -18320,7 +18337,7 @@ (cond-eqv? (cadr expr) selector #t) (not (side-effect? selector env))) ;; else-foldable as (((keys-from-test) true-branch) (else false-branch)) - (set! else-foldable + (set! else-foldable (if (pair? (cdddr expr)) (list (case-branch (cadr expr) selector (list (caddr expr))) (list 'else (cadddr expr))) @@ -18328,8 +18345,8 @@ (check-results caller (car form) clause exprs env))) ; walk the result exprs (cddr form))) - - (let ((key-phrase + + (let ((key-phrase (let ((keylen (length all-keys))) (cond ((< keylen 20)) ((lint-every? char? all-keys) @@ -18343,19 +18360,19 @@ key-phrase (+ lint-left-margin 4) #\space (truncated-list->string form)))) - + (if (and has-else (pair? result) (not else-foldable)) (begin ;; (case x (else (case x (else 1)))) -> 1 - (lint-format "perhaps ~A" caller (lists->string form + (lint-format "perhaps ~A" caller (lists->string form (if (null? (cdr result)) (car result) (cons 'begin result)))) (set! exprs-repeated #f))) ;; repeated result (but not all completely equal) and with else never happens - + (when (or exprs-repeated else-foldable) (let ((new-keys-and-exprs ()) (mergers ()) @@ -18365,8 +18382,8 @@ (for-each (lambda (c) (if (eq? (car c) 'else) (return c))) else-foldable) ())) (or has-else ())))) - - (let ((merge-case-keys + + (let ((merge-case-keys (let ((else-exprs (and (pair? else-clause) (cdr else-clause))) (a-few (lambda (lst) (if (> (length lst) 3) @@ -18392,24 +18409,24 @@ (set! new-keys-and-exprs (cons (cons (copy (car clause)) (cdr clause)) new-keys-and-exprs))))))))))) - + (for-each merge-case-keys (cddr form)) (if (pair? else-foldable) (for-each merge-case-keys else-foldable))) - + (if (null? new-keys-and-exprs) - (lint-format "perhaps ~A" caller + (lint-format "perhaps ~A" caller ;; (case x (else (case x (else 1)))) -> 1 - (lists->string form + (lists->string form (if (or (null? else-clause) ; this can happen... (null? (cdr else-clause))) () - (if (null? (cddr else-clause)) + (if (null? (cddr else-clause)) (cadr else-clause) (cons 'begin (cdr else-clause)))))) (begin ;; (null? (cdr new-keys-and-exprs)) is rare and kinda dumb -- cases look like test suite entries - (for-each + (for-each (lambda (clause) (if (len>1? (car clause)) (if (just-integers? (car clause)) @@ -18423,11 +18440,11 @@ ;; (case x ((0) 32) ((1) 32)) -> (case x ((0 1) 32)) (lint-format "perhaps ~A" caller (if (pair? mergers) - (format #f "merge keys ~{~{~A with ~A~}~^, ~}: ~A" - (reverse mergers) + (format #f "merge keys ~{~{~A with ~A~}~^, ~}: ~A" + (reverse mergers) (lists->string form new-form)) (lists->string form new-form)))))))))) - + ;; -------- case->symbol->value -------- (define (case->symbol->value caller form) ; (case x ((abs) abs) ((expt) expt)...) -> (symbol->value x) (do ((selector (cadr form)) @@ -18443,7 +18460,7 @@ `(case ,selector ,@(if (memv (car (caaddr form)) (cdar svs)) () '(...)) ,@(map (lambda (sv) - (list (reverse (cdr sv)) '=> (case (car sv) + (list (reverse (cdr sv)) '=> (case (car sv) ((list-values) 'list) (else)))) svs) @@ -18452,47 +18469,47 @@ (cond ((not (and (len=2? c) (pair? (car c)))) (set! others #t)) - + ((and (null? (cdar c)) ; ((a) a) (symbol? (caar c)) (eq? (caar c) (cadr c))) ; the quoted case happens only in test suites - (cond ((assq 'symbol->value svs) + (cond ((assq 'symbol->value svs) => (lambda (sv-data) (set-cdr! sv-data (cons (caar c) (cdr sv-data))))) (else (set! svs (cons (list 'symbol->value (caar c)) svs))))) - + ((and (just-symbols? (car c)) ; ((a b c) (eval selector)) (len=2? (cadr c)) (memq (caadr c) '(eval symbol->value)) (equal? (cadadr c) selector)) - (cond ((assq 'symbol->value svs) + (cond ((assq 'symbol->value svs) => (lambda (sv-data) (set-cdr! sv-data (append (reverse (car c)) (cdr sv-data))))) (else (set! svs (cons (cons 'symbol->value (reverse (car c))) svs))))) - + ((and (null? (cdar c)) ; ((a) (f a)) (len=2? (cadr c)) (eqv? (caar c) (cadadr c)) (not (memq (caadr c) '(quote values)))) - (cond ((assq (caadr c) svs) + (cond ((assq (caadr c) svs) => (lambda (func-data) (set-cdr! func-data (cons (caar c) (cdr func-data))))) (else (set! svs (cons (list (caadr c) (caar c)) svs))))) - - ((not (and (len=2? (cadr c)) + + ((not (and (len=2? (cadr c)) (equal? (cadadr c) selector))) (set! others #t)) - - ((assq (caadr c) svs) + + ((assq (caadr c) svs) => (lambda (func-data) ; ((1 b #f) (func selector)) (set-cdr! func-data (append (reverse (car c)) (cdr func-data))))) - (else + (else (set! svs (cons (cons (caadr c) (reverse (car c))) svs))))))) ;; -------- case-walker -------- - (define case-walker + (define case-walker (let ((selector-types '(#t symbol? char? boolean? integer? rational? real? complex? number? null? eof-object?))) (define (case->case+args caller form len) @@ -18524,7 +18541,7 @@ (list (car c) (caadr c))) (cddr form))) ,@(cdadr first-clause)))))))) - + (lambda (caller form env) ;; here the keys are not evaluated, so we might have a list like (letrec define ...) ;; also unlike cond, only 'else marks a default branch (not #t) @@ -18534,7 +18551,7 @@ (lint-format "case is messed up: ~A" caller (truncated-list->string form)) ;; perhaps also (lint-every? (lambda (c) (or (pair? c) (eq? c 'else))) (car clause)) above (let ((suggest made-suggestion)) - + ;; if regular case + else, focus case on diff (let ((len (- (length form) 2))) ; number of clauses (when (and (> len 1) ; (case x (else ...)) is handled elsewhere @@ -18543,29 +18560,29 @@ (case->case+args caller form len) (case->header+case+trailer caller form len env))) (case->symbol->value caller form) - + (let ((selector (cadr form))) (when (= suggest made-suggestion) (simplify-case caller form selector env)) - + (if (and (not (pair? selector)) (constant? selector)) ; (case 3 ((0) #t)) (lint-format "case selector is a constant: ~A" caller (truncated-list->string form)) (if (symbol? selector) (set-ref selector caller form env) (lint-walk caller selector env))) - + (let ((sel-type (and (pair? selector) (symbol? (car selector)) (return-type (car selector) env)))) (if (and (symbol? sel-type) ; (case (list 1) ((0) #t)) - (not (memq sel-type selector-types))) + (not (memq sel-type selector-types))) (lint-format "case selector may not work with eqv: ~A" caller (truncated-list->string selector))) (check-keys caller form selector sel-type env))))) ; calls lint-walk-open-body on each result env))) (hash-walker 'case case-walker)) - - + + ;; ---------------- do ---------------- (let () (define (car-subst sym new-sym tree) @@ -18606,7 +18623,7 @@ (if (and (null? (cddr end+result)) (code-constant? (cadr end+result))) ; (begin (z 1) (do ((i 0 (+ i 1))) ((= i n) 32))): 32 (lint-format "this do-loop could be replaced by ~A: ~A" caller (cadr end+result) (truncated-list->string form)))) - (if (and (null? end+result) ; (do () ()) -- need more of these + (if (and (null? end+result) ; (do () ()) -- need more of these (null? (cadr form))) (lint-format "infinite loop: ~A" caller form))))) @@ -18637,13 +18654,13 @@ (let ((new-var (let ((v (make-lint-var (caar bindings) (cadar bindings) 'do))) (let ((stepper (and (pair? (cddar bindings)) (caddar bindings)))) (varlet (cdr v) :step stepper) - (if stepper + (if stepper (begin (set! (var-history v) (cons (list 'set! (caar bindings) stepper) (var-history v))) (set! (var-refenv v) env)))) v))) (set! vars (cons new-var vars)))))) - + ;; -------- walk-do-steps -------- (define (walk-do-steps caller form vars inner-env env) ;; walk the step exprs @@ -18675,9 +18692,9 @@ (set! baddies (cons step-name baddies)))) vars)))) step-vars) - + (check-unordered-exprs caller form (map var-initial-value vars) env) - + (when (pair? baddies) ;; (do ((i 0 j) (j ...))...) is unreadable -- which (binding of) j is i set to? ;; but this is tricky if there is more than one such variable -- if cross links, we'll need named let @@ -18731,8 +18748,8 @@ (list (car s) (cadr s))) step-vars) (if ,test ,result ,new-body))))))))))) - - ;; -------- walk-do-end+result -------- + + ;; -------- walk-do-end+result -------- (define (walk-do-end+result caller form vars inner-env env) ;; walk the body and end stuff (it's too tricky to find infinite do loops) (when (and (pair? (caddr form)) @@ -18759,18 +18776,18 @@ (lint-format "return value is redundant: ~A" caller end+result) (if (and (len=2? result) (equal? end (cadr result))) - (lint-format "perhaps use => here: ~A" caller - (lists->string end+result + (lint-format "perhaps use => here: ~A" caller + (lists->string end+result (list end '=> (car result)))))))))) (if (and (symbol? end) (memq end '(= > < >= <= null? not))) ;; (do ((i 0 (+ i 1))) (= i 10) (display i)) (lint-format "perhaps missing parens: ~A" caller end+result)) - + (cond ((never-false end) ;; (do ((i 0 (+ i 1))) ((+ i 10) i)) (lint-format "end test is never false: ~A" caller end)) - + (end ; it's not #f (if (never-true end) (lint-format "end test is never true: ~A" caller end) @@ -18801,12 +18818,12 @@ (val (and (not (tree-set-memq '(read-char read-line read-string read) new-end)) ;; if new-end has (for example) read-char, eval here will hang waiting on *stdin* ;; TODO: here and below, protect against any attempt at IO - (catch #t - (lambda () + (catch #t + (lambda () ;(format *stderr* "new-end: ~S, form: ~S~%" new-end form) ((lambda args ; lambda here and below to catch multiple values, if any (car args)) ; no need to check (pair? args) since in this context (values)->#<unspecified> - (eval new-end (inlet)))) + (eval new-end (inlet)))) (lambda args :eval-error))))) (if (and val (not (eq? val :eval-error))) @@ -18814,7 +18831,7 @@ (let* ((step-end `(let (,@(map (lambda (stepper) ; -> (let ((i (+ 0 1))) (= i 0)) as above (if (tree-memq (car stepper) end) (if (pair? (cddr stepper)) - (list (car stepper) + (list (car stepper) (tree-subst (cadr stepper) (car stepper) (caddr stepper))) ; new old tree stepper) ; was (cadr stepper) which can't be right (values))) @@ -18824,7 +18841,7 @@ (catch #t (lambda () ;(format *stderr* "step-end: ~S, form: ~S~%" step-end form) - ((lambda args + ((lambda args (car args)) (eval step-end (inlet)))) (lambda args @@ -18846,25 +18863,25 @@ (and (real? (caddr step)) (caddr step)))))) (when (and (real? inc) (case (car step) - ((+) (and (positive? inc) + ((+) (and (positive? inc) (memq (car end) '(< <=)))) - ((-) (and (positive? inc) + ((-) (and (positive? inc) (memq (car end) '(> >=)))) (else #f))) ;; (do ((i 0 (+ i 1))) ((< i len)) (display i) ;; (do ((i 0 (- i 1))) ((> i len)) (display i)) - (lint-format "do step looks like it doesn't match end test: ~A" caller + (lint-format "do step looks like it doesn't match end test: ~A" caller (lists->string step end))))))))))) ((pair? (cdr end+result)) ;; (do ((i 0 (+ i 1))) (#f i)) (lint-format "result is unreachable: ~A" caller end+result))) - + (if (and (symbol? end) (not (var-member end env)) (procedure? (symbol->value end *e*))) ;; (do ((i 0 (+ i 1))) (abs i) (display i)) (lint-format "strange do end-test: ~A in ~A is a procedure" caller end end+result))))))) - + ;; -------- walk-do-body -------- (define (walk-do-body caller form vars inner-env env) (lint-walk-body caller 'do (cdddr form) (cons (make-lint-var :do form 'do) @@ -18918,18 +18935,18 @@ (lint-format "perhaps move ~A to ~A's step expression: ~A" caller (truncated-list->string last-expr) (var-name v) - (list (var-name v) - (var-initial-value v) + (list (var-name v) + (var-initial-value v) (if (not (var-step v)) val (let ((expr (tree-subst val (var-name v) (var-step v)))) - (cond ((not (pair? expr)) + (cond ((not (pair? expr)) expr) ((hash-table-ref numeric-ops (car expr)) (simplify-numerics expr env)) - ((memq (car expr) '(and or not)) + ((memq (car expr) '(and or not)) (simplify-boolean expr () () env)) (else expr)))))))))))))) @@ -18942,7 +18959,7 @@ (pair? (car body))) ;; do+let ;; no hits for define here - ;; this is tricky: make-index.scm (do () ((>= i len)) (let ((c (string-ref scheme-name i))) ...)) can't move the let upwards + ;; this is tricky: make-index.scm (do () ((>= i len)) (let ((c (string-ref scheme-name i))) ...)) can't move the let upwards (if (and (eq? (caar body) 'let) (len>1? (cdar body)) ; body not ((let))! (not (symbol? (cadar body))) ; not named let @@ -18955,7 +18972,7 @@ (if (symbol? x) x (values))) ; overkill obviously (caaddr form)) ()))) - (lint-every? (lambda (c) + (lint-every? (lambda (c) (and (len>1? c) (not (memq (car c) varset)) ; no shadowing (or (code-constant? (cadr c)) @@ -19015,7 +19032,7 @@ (case (caaddr var) ((cdr) (when (and (case (car end) - ((null?) + ((null?) (eq? (cadr end) vname)) ((not) (and (pair? (cadr end)) @@ -19090,7 +19107,7 @@ (setv #f)) (when (and (pair? end-test) (len=1? body) - (pair? (car body)) + (pair? (car body)) (memq (car end-test) '(>= = < negative?))) (set! body (car body)) (when (memq (car body) '(vector-set! float-vector-set! int-vector-set! list-set! string-set!)) @@ -19144,8 +19161,8 @@ (memq (car val) '(vector-ref float-vector-ref int-vector-ref list-ref string-ref)) (eq? (caddr val) vname))) ;; (do ((i 2 (+ i 1))) ((= i len)) (string-set! s i #\a)) -> (fill! s #\a 2 len) - (lint-format "perhaps ~A" caller - (lists->string form + (lint-format "perhaps ~A" caller + (lists->string form (if (code-constant? setv) (list 'fill! (cadr body) (cadddr body) start end) ;; (do ((i 0 (+ i 1))) ((= i (length str)) s) (string-set! s i (string-ref str i))) -> (copy str s) @@ -19169,7 +19186,7 @@ (pair? (caddr var2)) (eq? (caaddr var2) 'cons)) (do->make-list caller form form var1 var2)))))))) - + ;; -------- do-walker -------- (define (do-walker caller form env) (if (not (and (>= (length form) 3) @@ -19192,15 +19209,15 @@ env) (hash-walker 'do do-walker)) - - + + ;; ---------------- let, let*, letrec ---------------- - (let () + (let () (define (unsafe-definer? form) - (tree-set-memq + (tree-set-memq '(define define* define-constant curlet require load eval eval-string - define-macro define-macro* define-bacro define-bacro* define-expansion + define-macro define-macro* define-bacro define-bacro* define-expansion definstrument define-animal define-envelope defgenerator define-values define-module define-method define-syntax define-public define-inlinable define-integrable define^ @@ -19214,7 +19231,7 @@ (e (lint-walk-body caller (car form) body cur-env))) (when (pair? vars) - (case (car form) + (case (car form) ((let) (for-each (lambda (v) (if (null? (var-env v)) @@ -19233,7 +19250,7 @@ (set! vars (append nvars vars))))) (report-usage caller (car form) vars e) (cons vars env))) - + ;; --------declare-named-let -------- (define (declare-named-let form env) ; used in let-walker and let*-walker (let ((named-let (and (symbol? (cadr form)) (cadr form)))) @@ -19246,7 +19263,7 @@ (let ((vars (map car (caddr form)))) (list (make-fvar named-let (car form) vars form env)))))) - + ;; -------- remove-null-let -------- (define (remove-null-let caller form env) (if (and (null? (cadr form)) ; this can be fooled by macros that define things @@ -19261,7 +19278,7 @@ (hash-table-ref syntaces (car p)) (not (side-effect? p env)))) (cddr form)) - (lint-format "let could be begin: ~A" caller + (lint-format "let could be begin: ~A" caller (truncated-lists->string form (cons 'begin (cddr form)))))) (let ((body (cddr form))) (when (and (null? (cdr body)) @@ -19277,7 +19294,7 @@ (null? (cadr form))) ;; (let () (lambda (a b) (if (positive? a) (+ a b) b))) -> (lambda (a b) (if (positive? a) (+ a b) b)) (lint-format "pointless let: ~A" caller (lists->string form (car body))))))))) - + ;; -------- walk-let-vars -------- (define (walk-let-vars caller form varlist vars env) (let ((named-let (and (symbol? (cadr form)) (cadr form)))) @@ -19290,7 +19307,7 @@ (tree-car-member (caar bindings) val) (not (var-member (caar bindings) env))) ; (let ((x (lambda (a) (x 1)))) x) (lint-format "let variable ~A is called in its binding? Perhaps let should be letrec: ~A" - caller (caar bindings) + caller (caar bindings) (truncated-list->string bindings)) (unless named-let (for-each (lambda (v) @@ -19318,8 +19335,8 @@ (set! vars (cons (car e) vars))) (set! vars (cons (make-lint-var (caar bindings) val (if named-let 'named-let 'let)) vars))))))) - - (check-unordered-exprs caller form + + (check-unordered-exprs caller form (map (if (not named-let) var-initial-value (lambda (v) @@ -19329,7 +19346,7 @@ vars) env) vars)) - + ;; -------- move-let-into-if -------- (define (move-let-into-if caller form env) ;; move let in: @@ -19434,7 +19451,7 @@ (lint-format "perhaps move the let inside the ~A: ~A" caller (car first-expr) (truncated-lists->string form `(,(car first-expr) ,test (let ,(cadr form) ,@(cddr first-expr)))))))))))) - + ;; -------- let-body->value -------- (define (let-body->value caller form vars env) (let ((named-let (and (symbol? (cadr form)) (cadr form)))) @@ -19469,13 +19486,13 @@ (cons (replace (car tree)) (replace (cdr tree)))))))) (lint-format "perhaps ~A" caller ; (let ((a 1)) (set! a 2)) -> 2 - (lists->string form + (lists->string form (if (null? (cdr body)) ; this only happens in test suites... (if (null? (cdr varlist)) setval (list 'let (map (lambda (v) (if (eq? (car v) settee) (values) v)) varlist) setval)) - (cons 'let + (cons 'let (cons (map (lambda (v) (if (eq? (car v) settee) ; (let ((x 0)) (set! x 1)...) -> (let ((x 1)) ...) (list (car v) setval) ; replace initial with set! value @@ -19502,7 +19519,7 @@ (eq? (car v) settee)) varlist) setval))))))))) - + ((define) (unless named-let (let ((f (cdar body))) @@ -19519,10 +19536,10 @@ `(let (,@varlist ,f) ...))))))) - + ;; display et al here happen a lot, but only a few are rewritable or collapsible ;; *-set! happen a couple dozen times, but not in ways we can rewrite - + ((fill! string-fill! vector-fill!) ; (let ((x (make-vector 3))) (fill! x 1) ...) -> (let ((x (make-vector 3 1))) ...) (cond ((assq (cadar body) vars) => (lambda (v) @@ -19537,7 +19554,7 @@ i1) (lambda args :none))) (if (and (pair? init) - (memq (car init) '(make-string make-list make-vector + (memq (car init) '(make-string make-list make-vector make-int-vector make-float-vector make-byte-vector)) (let ((ninit (caddar body)) (local-vars (map car vars))) @@ -19556,7 +19573,7 @@ v)) varlist) (caddar body)) - (cons 'let + (cons 'let (cons (map (lambda (v) (if (eq? (car v) (cadar body)) (list (car v) new-init) @@ -19565,7 +19582,7 @@ (if (null? (cddr body)) (cdr body) (list (cadr body) '...))))))))))))))))) - + ;; -------- normal-let->do -------- (define (normal-let->do caller form env) (let ((varlist (cadr form)) @@ -19587,7 +19604,7 @@ ;; (let ((a 1)) (do ((i a (+ i 1))) ((= i 3)) (display i))) -> (do ((i 1 (+ i 1))) ...) (lint-format "perhaps ~A" caller (lists->string form (list 'do new-cadr '...))))))) - + ;; let->do -- sometimes a bad idea, set *report-combinable-lets* to #f to disable this. ;; (the main objection is that the s7/clm optimizer can't handle it, and ;; instruments using it look kinda dumb -- the power of habit or something) @@ -19628,14 +19645,14 @@ ,@(if (side-effect? (cdadr do-form) env) (cdadr do-form) ()) ,@(cdr body)) ; include rest of let as do return value ...)))))))))))) - + ;; -------- split-let -------- (define (split-let caller form body vars env) ;; look for splittable lets and let-temporarily possibilities - (for-each + (for-each (lambda (local-var) (let ((vname (var-name local-var))) - + ;; ideally we'd collect vars that fit into one let etc (when (> (length body) (* 5 (var-set local-var)) 0) (do ((i 0 (+ i 1)) @@ -19660,12 +19677,12 @@ ...)))) ;; (let ((x 32)) (set! y (f 1)) (a y) (f y) (g y) (h y) (i y) (set! x (+ x... -> (let () ... (let ((x (+ 32 1))) ...)) (lint-format "perhaps move the ~A binding to replace ~A: ~A" caller - vname + vname (truncated-list->string (car p)) (let ((new-value (if (tree-memq vname (caddar p)) (tree-subst (var-initial-value local-var) vname (copy (caddar p))) (caddar p)))) - (lists->string form + (lists->string form `(let ,(let rewrite ((lst (cadr form))) (cond ((null? lst) ()) ((and (pair? (car lst)) @@ -19681,7 +19698,7 @@ #t)))) (if (tree-memq vname (car p)) (set! preref i)))) - + (when (and (zero? (var-set local-var)) (= (var-ref local-var) 2)) ; initial value and set!'s value (do ((saved-name (var-initial-value local-var)) @@ -19697,10 +19714,10 @@ ;; the pattern (set! x y) ... (set! y x) happens a few times (say 5 to 10) (lint-format "perhaps use let-temporarily here: ~A" caller (lists->string form - (let ((new-let (cons 'let-temporarily - (cons (list (list saved-name - (if (pair? first-pos) - (caddar first-pos) + (let ((new-let (cons 'let-temporarily + (cons (list (list saved-name + (if (pair? first-pos) + (caddar first-pos) saved-name))) (map (lambda (expr) (if (or (and (pair? first-pos) @@ -19729,16 +19746,16 @@ (if (eq? (caddr expr) vname) (set! last-pos p)))))))) vars)) - + ;; -------- let-var->body -------- (define (let-var->body caller form body varlist) (when (len=1? varlist) - (if (and (len=1? body) ; (let ((x y)) x) -> y, named let is possible here + (if (and (len=1? body) ; (let ((x y)) x) -> y, named let is possible here (eq? (car body) (caar varlist)) (pair? (cdar varlist))) ; (let ((a))...) (lint-format "perhaps ~A" caller (lists->string form (cadar varlist)))) ;; also (let ((x ...)) (let ((y x)...))) happens but it looks like automatically generated code or test suite junk - + ;; copied from letrec below -- happens about a dozen times (when (and (list? (cadr form)) ; not named let (len=1? (cddr form)) @@ -19756,20 +19773,20 @@ (if (not (tree-memq sym (cdr body))) ;; (let ((x (lambda (y) (+ y (x (- y 1)))))) (x 2)) -> (let ((y 2)) (+ y (x (- y 1)))) (lint-format "perhaps ~A" caller - (lists->string form - (cons 'let + (lists->string form + (cons 'let (cons (map list (cadr lform) (cdr body)) (cddr lform)))))) (if (= (tree-count sym body 2) 1) (let ((call (find-call sym body))) - (when (pair? call) - (let ((new-call (cons 'let + (when (pair? call) + (let ((new-call (cons 'let (cons (map list (cadr lform) (cdr call)) (cddr lform))))) ;; (let ((f60 (lambda (x) (* 2 x)))) (+ 1 (f60 y))) -> (+ 1 (let ((x y)) (* 2 x))) (lint-format "perhaps ~A" caller (lists->string form (tree-subst new-call call body))))))))))))) - + ;; -------- combine-lets -------- (define combine-lets (let () @@ -19778,21 +19795,21 @@ (and (pair? forms) (or (and (pair? (car forms)) (or (tree-set-memq vars (car forms)) - (lint-any? (lambda (a) + (lint-any? (lambda (a) (or (not (pair? a)) - (not (pair? (cdr a))) + (not (pair? (cdr a))) (side-effect? (cadr a) env))) (car forms)))) - (loop (append (map car (car forms)) vars) + (loop (append (map car (car forms)) vars) (cdr forms)))))) - + (lambda (caller form varlist env) (when (and (pair? (cadr form)) (len=1? (cddr form)) (pair? (caddr form))) (let ((inner (caddr form)) ; the inner let (outer-vars (cadr form))) - + (when (len>1? (cdr inner)) (let ((inner-vars (cadr inner))) (when (and (eq? (car inner) 'let) @@ -19810,21 +19827,21 @@ ;; (let ((x 1) (y (f g 2))) (let loop ((a (+ x 1)) (b y)) (loop a b))) -> (let loop ((a (+ 1 1)) (b (f g 2))) (loop a b)) (lint-format "perhaps ~A" caller (lists->string form - (cons 'let - (cons inner-vars + (cons 'let + (cons inner-vars (cons new-args named-body))))))))) - + ;; maybe more code than this is worth -- combine lets (when (and (memq (car inner) '(let let*)) (pair? inner-vars)) - + (cond ((and (null? (cdadr form)) ; let(1) + let* -> let* (eq? (car inner) 'let*) (not (symbol? inner-vars))) ; not named let* ;; (let ((a 1)) (let* ((b (+ a 1)) (c (* b 2))) (display (+ a b c)))) -> (let* ((a 1) (b (+ a 1)) (c (* b 2))) (display (+ a b c))) (lint-format "perhaps ~A" caller (lists->string form - (cons 'let* + (cons 'let* (cons (append outer-vars inner-vars) (one-call-and-dots (cddr inner))))))) ((and (len=1? (cddr inner)) @@ -19846,7 +19863,7 @@ ;; (let ((a 1)) (let ((b 2)) (let ((c 3)) (let ((d 4)) (+ a b c d))))) -> (let ((a 1) (b 2) (c 3) (d 4)) (+ a b c d)) (lint-format "perhaps ~A" caller (lists->string form - (cons 'let + (cons 'let (cons (append outer-vars inner-vars inner1-vars inner2-vars) (one-call-and-dots (cdr inner2)))))))) (if (not (letstar env outer-vars @@ -19855,7 +19872,7 @@ ;; (let ((b 2)) (let ((c 3)) (let ((d 4)) (+ a b c d)))) -> (let ((b 2) (c 3) (d 4)) (+ a b c d)) (lint-format "perhaps ~A" caller (lists->string form - (cons 'let + (cons 'let (cons (append outer-vars inner-vars inner1-vars) (one-call-and-dots (cdr inner1)))))))))) ((not (letstar env outer-vars @@ -19863,20 +19880,20 @@ ;; (let ((c 3)) (let ((d 4)) (+ a b c d))) -> (let ((c 3) (d 4)) (+ a b c d)) (lint-format "perhaps ~A" caller (lists->string form - (cons 'let + (cons 'let (cons (append outer-vars inner-vars) (one-call-and-dots (cddr inner))))))) - + ((and (null? (cdadr form)) ; 1 outer var - (pair? inner-vars) + (pair? inner-vars) (null? (cdadr inner))) ; 1 inner var, dependent on outer ;; (let ((x 0)) (let ((y (g 0))) (+ x y))) -> (let* ((x 0) (y (g 0))) (+ x y)) (lint-format "perhaps ~A" caller (lists->string form - (cons 'let* + (cons 'let* (cons (append outer-vars inner-vars) (one-call-and-dots (cddr inner)))))))))))))))) - + ;; -------- tighten-let -------- (define (tighten-let caller form vars env) (let ((body (cddr form)) @@ -19885,7 +19902,7 @@ (not (tree-set-memq open-definers body))) ;; define et al are like a continuation of the let bindings, so we can't restrict them by accident ;; (let ((x 1)) (define y x) ...) - (let ((last-refs (map (lambda (v) + (let ((last-refs (map (lambda (v) (vector (var-name v) #f 0 v)) vars)) (got-lambdas (tree-set-car-member '(lambda lambda*) body))) @@ -19902,8 +19919,8 @@ (< (tree-leaves (car body)) 100)) (let ((old-start (let ((old-pp (lint-pp-funclet '*pretty-print-left-margin*))) (set! (lint-pp-funclet '*pretty-print-left-margin*) (+ lint-left-margin 4)) - (let ((res (lint-pp (cons 'let - (cons (cadr form) + (let ((res (lint-pp (cons 'let + (cons (cadr form) (copy body (make-list (+ end 1)))))))) (set! (lint-pp-funclet '*pretty-print-left-margin*) old-pp) res)))) @@ -19915,7 +19932,7 @@ (+ lint-left-margin 4) #\space (lint-pp (list-ref body (+ end 1))))) (begin - ;; look for bindings that can be severely localized + ;; look for bindings that can be severely localized (let ((locals (map (lambda (v) (if (and (integer? (v 1)) (< (- (v 2) (v 1)) 2) @@ -19925,7 +19942,7 @@ last-refs))) ;; should this omit cases where most of the let is in the one or two lines? (when (pair? locals) - (set! locals (sort! locals (lambda (a b) + (set! locals (sort! locals (lambda (a b) (or (< (a 1) (b 1)) (< (a 2) (b 2)))))) (do ((lv locals (cdr lv))) @@ -19950,13 +19967,13 @@ (truncated-list->string (list-ref body cur-line)) (if (= cur-line max-line) "" - (format #f "~%~NC~A" + (format #f "~%~NC~A" (+ lint-left-margin 6) #\space (truncated-list->string (list-ref body max-line)))) (+ lint-left-margin 4) #\space (truncated-list->string form))) - (gather (cdr pv) - (cons (car pv) cur-vars) + (gather (cdr pv) + (cons (car pv) cur-vars) (max max-line ((car pv) 2))))))))) (let ((mnv ()) (cur-end i)) @@ -19971,13 +19988,13 @@ (set! mnv (cons v (if (= (v 2) cur-end) mnv ()))) (set! cur-end (v 2)))) last-refs) - + ;; look for vars used only at the start of the let (when (and (pair? mnv) (< cur-end (/ i lint-let-reduction-factor)) (> (- i cur-end) 3)) ;; mnv is in the right order because last-refs is reversed - (lint-format "the scope of ~{~A~^, ~} could be reduced: ~A" caller + (lint-format "the scope of ~{~A~^, ~} could be reduced: ~A" caller (map (lambda (v) (v 0)) mnv) (lists->string form `(let ,(map (lambda (v) @@ -19991,7 +20008,7 @@ ,@(copy body (make-list (+ cur-end 1)))) ,(list-ref body (+ cur-end 1)) ...))))))))) - + ;; body of do loop above (if (and (not got-lambdas) (pair? (car p)) @@ -20003,13 +20020,13 @@ (lint-format "~A in ~A could be omitted" caller (car p) (truncated-list->string form)) (lint-format "perhaps ~A" caller (lists->string (car p) (caddar p))))) ;; 1 use in cadr and none thereafter happens a few times, but looks like set-as-documentation mostly - + (for-each (lambda (v) (when (tree-memq (v 0) (car p)) (set! (v 2) i) (if (not (v 1)) (set! (v 1) i)))) last-refs)))))) - + ;; -------- let-ends-in-set -------- (define (let-ends-in-set caller form) (let ((body (cddr form)) @@ -20024,7 +20041,7 @@ (not (tree-set-memq '(call/cc call-with-current-continuation curlet lambda lambda*) form))) (lint-format "set! is pointless in ~A: use ~A" caller last (caddr last)))))) ; could add definers here, especially define - + ;; -------- embed-let -------- (define (embed-let caller form env) (let ((varlist (cadr form)) @@ -20046,7 +20063,7 @@ (< (tree-leaves (cadr v)) 8) (= (tree-count (car v) body 2) 1))) varlist)) - + (let ((new-body (copy (car body))) (bool-arg? #f)) (for-each (lambda (v) @@ -20061,35 +20078,21 @@ (tree-walk (cdr tree))))))) (set! new-body (tree-subst (cadr v) (car v) new-body))) varlist) - (lint-format (if bool-arg? + (lint-format (if bool-arg? "perhaps, ignoring short-circuit issues, ~A" "perhaps ~A") caller (lists->string form new-body)))))) -#| - (define (forgotten-let caller form env) - ;; (let ((x (length y))) (+ x (length y))) -> (let ((x (length y))) (+ x x)) - ;; embed-let above will suggest -> (+ (length y) (length y)) - (let ((varlist (cadr form)) - (body (cddr form)) - (ok-varlist ())) - - (let ((new-body (copy (car body)))) - (for-each (lambda (v) - (set! new-body (tree-subst (car v) (cadr v) new-body))) - ok-varlist) -|# - ;; -------- useless-let -------- (define (useless-let caller form env) (when (and (pair? (cadr form)) ; (let ((x x)) (+ x 1)) -> (+ x 1), (let ((x x))...) does not copy x if x is a sequence - (lint-every? (lambda (c) + (lint-every? (lambda (c) (and (len>1? c) ; the usual... (let binding might be messed up) (eq? (car c) (cadr c)))) (cadr form))) (let ((vs (map car (cadr form)))) - (unless (lint-any? (lambda (p) + (unless (lint-any? (lambda (p) (and (pair? p) (memq (cadr p) vs) (or (eq? (car p) 'set!) @@ -20100,18 +20103,18 @@ (if (null? (cdddr form)) (caddr form) (cons 'begin (cddr form))))))))) - + ;; -------- let->cond -------- (define let->cond ; not named-let here ;; (let ((x (A))) (if x (f x) B)) -> (cond ((A) => f) (else B) - (let ((wrap-new-form + (let ((wrap-new-form (lambda (header new-form trailer) (if (pair? trailer) `(let ,header ,new-form ,@(if (< (tree-leaves trailer) 20) trailer '(...))) (if (pair? header) `(let ,header ,new-form) new-form))))) - (lambda (caller form env) + (lambda (caller form env) (let ((body (cddr form))) (let ((p (car body)) (trailer (cdr body)) @@ -20136,7 +20139,7 @@ (pargs (cdr p)) (first-arg (cadr p)) (next-args (cddr p))) - + ;; (let ((x (assq a y))) (set! z (if x (cadr x) 0))) -> (set! z (cond ((assq a y) => cadr) (else 0))) (when (and (not (memq (car p) '(if cond))) ; handled separately below (= (tree-count vname p 3) 2)) @@ -20153,14 +20156,14 @@ (if (pair? bp) (let ((else-clause (if (pair? (cdddar bp)) (list (cons 'else (cdddar bp))) ()))) (lint-format "perhaps ~A" caller - (lists->string form - (wrap-new-form + (lists->string form + (wrap-new-form header `(,@(copy p (make-list (+ i 1))) (cond (,vvalue => ,(caaddr (car bp))) ,@else-clause) ,@(cdr bp)) trailer)))))))) - + (when (and (eq? (car p) 'cond) ; (let ((x (f y))) (cond (x (g x)) ...)) -> (cond ((f y) => g) ...) (len=2? first-arg) (eq? (car first-arg) vname) @@ -20169,8 +20172,8 @@ (eq? vname (cadr first-arg))) (or (null? next-args) (not (tree-memq vname next-args)))) - (lint-format "perhaps ~A" caller - (lists->string form + (lint-format "perhaps ~A" caller + (lists->string form (wrap-new-form header (if (eq? vname (cadr first-arg)) @@ -20182,38 +20185,38 @@ (cadar next-args) (cons 'begin (cdar next-args))) (cons 'cond next-args))) - (cons 'cond + (cons 'cond (cons (list vvalue '=> (caadr first-arg)) next-args))) trailer)))) - + (when (and (null? next-args) ; (let ((x (+ y 1))) (abs x)) -> (abs (+ y 1)) (eq? vname first-arg)) ; not tree-subst or trailing (pair) args: the let might be forcing evaluation order (if (or (hash-table-ref built-in-functions (car p)) (let ((v (var-member (car p) env))) (and v (memq (var-ftype v) '(define define* lambda lambda*))))) ; was definer?? - (lint-format "perhaps ~A" caller (lists->string form + (lint-format "perhaps ~A" caller (lists->string form (wrap-new-form header (list (car p) vvalue) trailer))) (if (not (or (any-macro? vname env) (tree-unquoted-member vname (car p)))) (lint-format "perhaps, assuming ~A is not a macro, ~A" caller (car p) - (lists->string form + (lists->string form (wrap-new-form header (list (car p) vvalue) trailer)))))) (when (pair? next-args) (when (and (eq? (car p) 'if) (pair? (cdr next-args))) (let ((if-true (car next-args)) (if-false (cadr next-args))) - + (when (and (eq? first-arg vname) ; (let ((x (g y))) (if x #t #f)) -> (g y) (boolean? if-true) (boolean? if-false) (not (eq? if-true if-false))) (lint-format "perhaps ~A" caller - (lists->string form + (lists->string form (wrap-new-form header (if if-true vvalue (list 'not vvalue)) trailer)))) - + (when (and (len>1? first-arg) ; (let ((x (f y))) (if (not x) B (g x))) -> (cond ((f y) => g) (else B)) (eq? (car first-arg) 'not) (eq? (cadr first-arg) vname) @@ -20226,8 +20229,8 @@ :oops! ; if the let var appears in the else portion, we can't do anything with => (list (list 'else if-true)))))) (unless (eq? else-clause :oops!) - (lint-format "perhaps ~A" caller - (lists->string form + (lint-format "perhaps ~A" caller + (lists->string form (wrap-new-form header (cons 'cond (cons (list vvalue '=> (car if-false)) else-clause)) @@ -20246,7 +20249,7 @@ (lint-format "in ~A, ~A can't be null so pair? might be better" caller p vname) #t) (and (eq? (car first-arg) 'null?) ; (let ((x (assoc y z))) (if (null? x) (g x))) - (lint-format "in ~A, ~A can't be null because ~A in ~A only returns #f or a pair" + (lint-format "in ~A, ~A can't be null because ~A in ~A only returns #f or a pair" caller p vname (car vvalue) (truncated-list->string (list vname vvalue))) #f)) (eq? (cadr first-arg) vname)) @@ -20258,20 +20261,20 @@ (and (not (eq? (car vvalue) 'string->number)) (eq? (car first-arg) 'integer?))) (eq? (cadr first-arg) vname))))) - + (or (and (len=2? (car next-args)) ; one func arg (or (eq? vname (cadar next-args)) (and (hash-table-ref combinable-cxrs (caar next-args)) ((lambda* (cr arg) ; lambda* not lambda because combine-cxrs might return just #f (and cr - (< (length cr) 5) + (< (length cr) 5) (eq? vname arg) (set! crf (symbol "c" cr "r")))) (combine-cxrs (car next-args)))))) (and (eq? (car p) 'if) (eq? (car next-args) vname) (not (tree-unquoted-member vname (cdr next-args))) ; (let ((x (g y))) (if x x (g z))) -> (or (g y) (g z)) - (lint-format "perhaps ~A" caller + (lint-format "perhaps ~A" caller (lists->string form (wrap-new-form header @@ -20295,12 +20298,12 @@ ((or) '((else #t))) (else ()))))) (unless (eq? else-clause :oops!) ; (let ((x (assoc y z))) (if x (cdr x))) -> (cond ((assoc y z) => cdr)) - (lint-format "perhaps ~A" caller - (lists->string form + (lint-format "perhaps ~A" caller + (lists->string form (wrap-new-form header - (cons 'cond - (cons (list vvalue '=> (or crf (caar next-args))) + (cons 'cond + (cons (list vvalue '=> (or crf (caar next-args))) else-clause)) trailer)))))))) (when (and (= suggest made-suggestion) @@ -20319,7 +20322,7 @@ (if (and (eq? first-arg vname) (= (tree-count vname body 2) 1)) ; 2 if we can use cond => (remember cdr) (lint-format "perhaps ~A" caller - (lists->string form + (lists->string form (wrap-new-form header (tree-subst vvalue vname p) trailer))))) ((if) (when (len=3? p) @@ -20343,7 +20346,7 @@ (lint-format "perhaps ~A" caller (lists->string form (wrap-new-form header (tree-subst vvalue vname p) trailer)))))))))))))))) - + ;; -------- let->for-each -------- (define (let->for-each caller form varlist body) (when (and (len>2? body) @@ -20360,7 +20363,7 @@ (arg2 ()) (p body (cdr p)) (i 0 (+ i 1))) - ((or (null? p) + ((or (null? p) (not (and (pair? (car p)) (eq? name (caar p))))) (if (and (>= i 3) @@ -20384,7 +20387,7 @@ (set! arg1 (cons (cadar p) arg1)) (if (pair? (cddar p)) (set! arg2 (cons (caddar p) arg2)))))))) - + ;; -------- combine set+one-use -------- (define (combine-set+one-use caller body varlist env) (do ((hits ()) @@ -20418,18 +20421,18 @@ (and (pair? (caddr call)) (tree-memq (cadr prev) (caddr call))) ; in the end+result section (and (pair? (cadr call)) - (member (cadr prev) (cadr call) (lambda (a b) (eq? a (cadr b))))))) ; initial value + (member (cadr prev) (cadr call) (lambda (a b) (eq? a (cadr b))))))) ; initial value (set! hits (cons (list prev p) hits))) (set! prev ()))))))) - + ;; --------- rewrite-funcs -------- (define (rewrite-funcs f) (let ((def (cdr f))) (if (symbol? (cadr def)) (cdr def) (list (caadr def) - (cons (if (eq? (car def) 'define*) - 'lambda* + (cons (if (eq? (car def) 'define*) + 'lambda* 'lambda) (cons (cdadr def) (if (< (tree-leaves (cddr def)) local-function-context) @@ -20455,7 +20458,7 @@ (old-vars (if (< (tree-leaves (cadr form)) local-function-context) (cadr form) (list (if (< (tree-leaves (caadr form)) local-function-context) - (caadr form) + (caadr form) (list (caaadr form) '...)) '...)))) @@ -20468,12 +20471,12 @@ ;; be letrec* in r7rs -- the example below may be incorrect in r7rs. ;; I think I'll put the functions on the outside. ;; (letrec ((f1 () (lambda () (f2 1))) (f2 (lambda () (f1 2))))...) is happy in s7. - + (lint-format "the inner function~A ~{~A~^, ~} could be moved ~A: ~A" caller (if (null? (cdr ok-funcs)) "" "s") func-names - (if named-let - (format #f "out to ~A's closure" (cadr form)) + (if named-let + (format #f "out to ~A's closure" (cadr form)) (if letrec? "to an outer letrec" "into the let")) @@ -20481,7 +20484,7 @@ (if named-let `(,(if letrec? 'letrec 'let) ,(map rewrite-funcs ok-funcs) (let ,old-vars ...)) - (if letrec? + (if letrec? `(letrec ,(map rewrite-funcs ok-funcs) (let ,old-vars ...)) `(let (,@old-vars @@ -20495,7 +20498,7 @@ (true #f) (false #f)) ;; scan of multiple vars for useful one got no hits - (when (case (car expr) + (when (case (car expr) ((if) (and (= (length expr) 4) (pair? (cadr expr)))) ((cond) (and (= (length expr) 3) @@ -20538,10 +20541,10 @@ (if (or (eq? false var) (and (len=2? false) (eq? var (cadr false)))) - `(case ,selector + `(case ,selector ((,key) ,true) (else ,@(if (eq? false var) () (list '=> (car false))))) - `(case ,selector + `(case ,selector ((,key) ,@(if (eq? true var) () (list '=> (car true)))) (else ,false)))))) (lists->string form @@ -20558,18 +20561,18 @@ (define (let-walker caller form env) (if (or (< (length form) 3) ; (let ((a 1) (set! a 2))) (not (or (symbol? (cadr form)) - (list? (cadr form))))) + (list? (cadr form))))) (lint-format "let is messed up: ~A" caller (truncated-list->string form)) - + (let ((named-let (and (symbol? (cadr form)) (cadr form)))) (if (keyword? named-let) ; (let :x ((i y)) (x i)) (lint-format "bad let name: ~A" caller named-let)) - + (if named-let (if *report-shadowed-variables* (report-shadower caller 'let 'named-let-function-name named-let named-let env)) (remove-null-let caller form env)) - + (let ((vars (declare-named-let form env)) (varlist ((if named-let caddr cadr) form)) (body ((if named-let cdddr cddr) form))) @@ -20582,7 +20585,7 @@ (len=1? body) (not (side-effect? (car body) env))) ; (let xx () z) (lint-format "perhaps ~A" caller (lists->string form (car body)))) - + (set! vars (walk-let-vars caller form varlist vars env)) (when (and (pair? body) @@ -20591,7 +20594,7 @@ (let-local-funcs->closure caller form body (map var-name vars))) ;; here we could check '+signature+ and others, but it is tricky to tell that ;; var-initial-value is messed up - + (let ((suggest made-suggestion)) (unless named-let (when (and (pair? varlist) @@ -20612,7 +20615,7 @@ (let ((es (walk-letx-body caller form body vars env))) (set! vars (car es)) (set! env (cdr es))) - + (when (pair? vars) (unless (or named-let (not *report-combinable-lets*)) @@ -20620,9 +20623,9 @@ (when (and (pair? (cadr form)) (pair? (caadr form))) (split-let caller form body vars env))) - + (let-var->body caller form body varlist) - + (when (pair? body) (when (len>2? (car body)) (let-body->value caller form vars env)) @@ -20636,12 +20639,12 @@ (tighten-let caller form vars env) (if (= suggest made-suggestion) (combine-set+one-use caller body varlist env))))) - + (combine-lets caller form varlist env)))))) env) (hash-walker 'let let-walker) - - + + ;; -------- let*->let+do -------- (define (let*->let+do caller form env) (let ((body (cddr form)) @@ -20703,7 +20706,7 @@ ;; one variable, or where subsequent values are known to be independent. ;; if each function could tell us what globals it depends on or affects, ;; we could make this work in all cases. - + (when (binding-ok? caller 'let* (car bindings) env #f) (let ((expr (cadar bindings)) (side (side-effect? (cadar bindings) env))) @@ -20723,10 +20726,10 @@ (set! vars (cons (car e) vars))) (set! vars (cons (make-lint-var (caar bindings) expr (if named-let 'named-let* 'let*)) vars)))) - + ;; look for duplicate values ;; someday protect against any shadows if included in any expr - (unless (or side + (unless (or side (not (pair? expr)) (code-constant? expr) (maker? expr)) @@ -20743,7 +20746,7 @@ name expr (caar vs)) (dup-check (cdr vs)))))))))) vars)) - + ;; -------- let*->let+let -------- (define (let*->let+let caller form vars env) ;; if var is not used except in other var bindings, it can be moved out of this let* @@ -20779,7 +20782,7 @@ (walker (cdr vs))))))))) (set! vs-pos (cdr vs-pos)))) (cdr vars)) ; vars is reversed from code order, new-vars is in code order - + (when (pair? new-vars) (define (gather-dependencies var val env) (let ((deps ())) @@ -20787,7 +20790,7 @@ (if (and (eq? (car nv) var) (or no-repeats (tree-memq (cadr nv) val))) - (set! deps (cons (list (cadr nv) + (set! deps (cons (list (cadr nv) (gather-dependencies (cadr nv) (caddr nv) env)) deps)))) new-vars) @@ -20796,11 +20799,11 @@ (if (pair? deps) (list (if (null? (cdr deps)) 'let 'let*) deps val) val))) - + (let ((new-let-binds (map (lambda (v) (if (member (var-name v) new-vars (lambda (name lst) (eq? name (cadr lst)))) (values) - (list (var-name v) + (list (var-name v) (gather-dependencies (var-name v) (var-initial-value v) env)))) (reverse vars)))) ;; (let* ((a 1) (b 2) (c (+ a 1))) (* c 2)) -> (let* ((b 2) (c (let ((a 1)) (+ a 1)))) ...) @@ -20840,7 +20843,7 @@ (memq (car value) cur-vars))) (constant-expression? value env) (do ((oldv varlist (cdr oldv))) - ((or (null? oldv) + ((or (null? oldv) (tree-memq vname (car oldv))) (and (pair? oldv) (pair? (car oldv)) @@ -20854,7 +20857,7 @@ (let ((lv ()) (ov ()) (iv ()) - (truncate-value + (truncate-value (lambda (v) (list v (let ((val (var-initial-value (var-member v vars)))) (if (and (pair? val) @@ -20874,7 +20877,7 @@ (set! iv (map truncate-value inner-vars)) (if (pair? inner-vars) (set! ov (cons (truncate-value (car inner-vars)) ov)))) - + (set! ov (if (null? ov) (list 'let (reverse iv) '...) (list (if (pair? (cdr ov)) 'let* 'let) @@ -20889,7 +20892,7 @@ (lint-format "perhaps split this let*: ~A" caller (lists->string form lv)))))))) - + ;; -------- let*+let*->let* (define (let*+let*->let* caller form) (let ((varlist (cadr form)) @@ -20907,10 +20910,10 @@ ;; (let* ((a 1) (b (+ a 2)) (c (+ b 3)) (d (+ c 4))) (display a) ...) (lint-format "perhaps ~A" caller (lists->string form - (cons 'let* + (cons 'let* (cons (append varlist (cadar body)) (one-call-and-dots (cddar body))))))))) - + ;; -------- remove-unneeded-let*-vars -------- (define (remove-unneeded-let*-vars caller form env) (do ((body (cddr form)) @@ -20919,7 +20922,7 @@ ((null? vs) (if (pair? changes) (let ((new-form (copy form))) - (for-each + (for-each (lambda (v) (list-set! new-form 1 (remove-if (lambda (p) (equal? p v)) (cadr new-form))) (set! new-form (tree-subst (cadr v) (car v) new-form))) @@ -20927,11 +20930,11 @@ ;; (let* ((x y) (a (* 2 x))) (+ (f a (+ a 1)) (* 3 x))) -> (let ((a (* 2 y))) (+ (f a (+ a 1)) (* 3 y))) (lint-format "assuming we see all set!s, the binding~A ~{~A~^, ~} ~A pointless: perhaps ~A" caller (if (pair? (cdr changes)) "s" "") - changes + changes (if (pair? (cdr changes)) "are" "is") (lists->string form (let ((header (if (len>1? (cadr new-form)) 'let* 'let))) - (cons header + (cons header (if (< (tree-leaves new-form) 200) (cdr new-form) (cons (cadr new-form) @@ -20956,7 +20959,7 @@ (tree-set-memq (var-setters data) body))))) (cdr vs)))) (set! changes (cons v changes)))))))) - + ;; -------- combine-let*-vars -------- (define (combine-let*-vars caller form vars env) ;; successive vars, first used in second but nowhere else -- combine if (very!) simple-looking @@ -20966,7 +20969,7 @@ (v varlist (cdr v))) ((or (null? v) (null? (cdr v))) - + (when (pair? gone-vars) (let ((waiter #f) (new-vars ()) @@ -20987,7 +20990,7 @@ new-v)))) varlist)) ;; (let* ((y 3) (x (log y))) x) -> (let ((x (log 3))) ...) - (lint-format "perhaps substitute ~{~{~A into ~A~}~^, ~}: ~A" caller + (lint-format "perhaps substitute ~{~{~A into ~A~}~^, ~}: ~A" caller (reverse save-vars) (lists->string form (list (if (null? (cdr new-vars)) 'let 'let*) @@ -21041,7 +21044,7 @@ (any-pairs? (cdr p))))) (cdar body)))) ;; (let* ((a 1) (b 2) (c (+ a 1))) (* c 2)) -> (let* ((a 1) (b 2)) (* (+ a 1) 2)) - (lint-format "perhaps ~A" caller + (lint-format "perhaps ~A" caller (lists->string form (cons (if (<= varlist-len 2) 'let 'let*) (cons (copy varlist (make-list (- varlist-len 1))) (tree-subst (cadr last-var) (car last-var) body)))))) @@ -21059,7 +21062,7 @@ (null? (cdddr p))) (not (eq? (caaddr p) (car last-var))) ; ! (let* (...(x A)) (if x (x x))) (eq? (car last-var) (cadr (caddr p)))) - + (let ((else-clause (if (pair? (cdddr p)) ; only if 'if (see above) (if (eq? (cadddr p) (car last-var)) `((else #f)) ; this stands in for the local var @@ -21075,17 +21078,17 @@ ;; (let* ((x (f y))) (and x (g x))) -> (cond ((f y) => g) (else #f) (lint-format "perhaps ~A" caller (case varlist-len - ((1) (lists->string form - (cons 'cond - (cons (list (cadr last-var) '=> (caaddr p)) + ((1) (lists->string form + (cons 'cond + (cons (list (cadr last-var) '=> (caaddr p)) else-clause)))) - ((2) (lists->string form + ((2) (lists->string form `(let (,(car varlist)) (cond (,(cadr last-var) => ,(caaddr p)) ,@else-clause)))) - (else (lists->string form + (else (lists->string form `(let* ,(copy varlist (make-list (- varlist-len 1))) (cond (,(cadr last-var) => ,(caaddr p)) ,@else-clause))))))))))) - + (unless (pair? (car body)) (if (and (eq? (car body) (caar varlist)) (null? (cdr varlist)) @@ -21096,11 +21099,11 @@ (len=2? last-var) (eq? (car body) (car last-var))) ;; (let* ((y 3) (x (log y))) x) -> (let ((y 3)) (log y)) - (lint-format "perhaps ~A" caller + (lint-format "perhaps ~A" caller (lists->string form (list (if (= varlist-len 2) 'let 'let*) (copy varlist (make-list (- varlist-len 1))) (cadr last-var))))))))))) - + ;; -------- reduce-let*-scope (define (reduce-let*-scope caller form vars) (let ((lastref (vector (var-name (car vars)) #f 0 (car vars))) @@ -21114,7 +21117,7 @@ (vname (lastref 0))) (if (and (< max-line (/ i lint-let-reduction-factor)) (> (- i max-line) 3)) - (lint-format "the scope of ~A could be reduced: ~A" caller + (lint-format "the scope of ~A could be reduced: ~A" caller vname (lists->string form `(,(if (> (length vars) 2) 'let* 'let) @@ -21136,7 +21139,7 @@ (truncated-list->string (list-ref body cur-line)) (if (= cur-line max-line) "" - (format #f "~%~NC~A" + (format #f "~%~NC~A" (+ lint-left-margin 6) #\space (truncated-list->string (list-ref body max-line)))) (+ lint-left-margin 4) #\space @@ -21183,17 +21186,17 @@ (when (and (pair? body) (pair? varlist) (func-definer? (car body))) - (let*-local-funcs->closure caller form body + (let*-local-funcs->closure caller form body (if named-let (cons (cadr form) (map car varlist)) (map car varlist)))) - - (let ((es (walk-letx-body caller form body + + (let ((es (walk-letx-body caller form body (walk-let*-vars caller form vars env) env))) (set! vars (car es)) (set! env (cdr es))) - + (when (and (not named-let) (pair? body) (proper-pair? varlist)) @@ -21202,11 +21205,11 @@ (let*+let*->let* caller form) (let*->let+do caller form env) ;; (define...) as first in body rarely happens in rewritable contexts - + (unless (unsafe-definer? body) (remove-unneeded-let*-vars caller form env)) (combine-let*-vars caller form vars env) - + (let ((last-var (last-ref varlist))) (combine-let*-last-var caller form last-var env) (if (and (null? (cdr body)) @@ -21214,16 +21217,16 @@ (len=2? last-var)) (let->case-else caller form (car last-var) (cadr last-var) body))) ;; last var -> if/cond in car(body) as in let only happens a few times (leaving aside stuff caught above) - + (when (and (> (length body) 3) (> (length vars) 1) - (not (tree-set-car-member '(define define* define-macro define-macro* + (not (tree-set-car-member '(define define* define-macro define-macro* define-bacro define-bacro* define-constant define-expansion) body))) (reduce-let*-scope caller form vars)))))))) - + env) - (hash-walker 'let* let*-walker) + (hash-walker 'let* let*-walker) ;; -------- letrec->let -------- @@ -21259,7 +21262,7 @@ (cadr form))) ;; this happens only in psyntax-pp.scm (Guile) (lint-format "letrec* could be letrec: ~A" caller (truncated-list->string form))) - + (when (and (null? (cdr vars)) (pair? (cadr form)) (len>1? (caadr form)) @@ -21277,8 +21280,8 @@ ;; the limit on tree-leaves is for cases where the args are long lists of data -- ;; more like for-each than let, and easier to read if the code is first, I think. (lint-format "perhaps ~A" caller - (lists->string - form `(let ,sym + (lists->string + form `(let ,sym ,(map list (cadr lform) (cdr body)) ,@(cddr lform))))) (if (and (not (eq? caller 'define)) @@ -21290,12 +21293,12 @@ ,@(cddr lform)))) (lint-format "perhaps ~A" caller (lists->string form (tree-subst new-call call body))))))))))))) - + ;; maybe (let () ...) here because (letrec ((x (lambda (y) (+ y 1)))) (x (define z 32))) needs to block z? ;; currently we get (let x ((y (define z 32))) (+ y 1)) ;; and even that should be (let () (define z 32) (+ z 1)) or something similar ;; lambda here is handled under define?? - + ;; -------- walk-letrec-vars -------- (define (walk-letrec-vars caller form env) (let ((head (car form)) @@ -21308,7 +21311,7 @@ ((not (pair? bindings)) (if (not (null? bindings)) ; (letrec* letrec)! (lint-format "~A variable list is not a proper list? ~S" caller head (cadr form)))) - + (when (and (not warned) ; letrec -> letrec* (len>1? (car bindings)) ;; type of current var is not important -- if used in non-function elsewhere, @@ -21329,7 +21332,7 @@ (caar bindings) (car baddy) (cadr baddy))) - + (when (binding-ok? caller head (car bindings) env #f) (let ((init (if (and (eq? (caar bindings) (cadar bindings)) (or (eq? head 'letrec) @@ -21365,7 +21368,7 @@ (cdr tree) (or (search (car tree)) (search (cdr tree)))))))) - + (call-with-exit (lambda (quit) (let ((vs (car (out-vars lr-name pars (cddr lr-lambda))))) @@ -21378,7 +21381,7 @@ (lists->string form (tree-subst `(let ,lr-name ,(map list pars lr-args) ,@(one-call-and-dots (cddr lr-lambda))) - (cons lr-name lr-args) + (cons lr-name lr-args) (caddr form))))))))))))) ;; -------- letrec-walker -------- @@ -21390,26 +21393,26 @@ (lint-format "~A is messed up: ~A" caller (car form) (truncated-list->string form)) env) (let ((head (car form))) - + (cond ((null? (cadr form)) ; (letrec () 1) (lint-format "~A could be let: ~A" caller head (truncated-list->string form))) ((and (null? (cdadr form)) (eq? head 'letrec*)) ; (letrec* ((a (lambda b (a 1)))) a) (lint-format "letrec* could be letrec: ~A" caller (truncated-list->string form)))) - + (let ((vars (walk-letrec-vars caller form env))) ;; no hits for func-definer as car of body - + (when (eq? head 'letrec) (check-unordered-exprs caller form (map var-initial-value vars) env) (letrec+lambda->lambda+let caller form)) - + ;; define backwards propagation check got no hits: (letrec ((f1 (lambda () f2))) (define f2 1) (f1)) (when (pair? vars) (letrec->let caller form vars env)) - + (when (pair? (cadr form)) (let ((new-env (append vars env))) (for-each (lambda (binding) @@ -21421,12 +21424,12 @@ (hash-walker 'letrec letrec-walker) (hash-walker 'letrec* letrec-walker)) - - + + ;; ---------------- begin ---------------- (let () (define (begin-walker caller form env) - + (if (not (proper-list? form)) (begin ; (begin . 1) (lint-format "stray dot in begin? ~A" caller (truncated-list->string form)) @@ -21435,11 +21438,11 @@ (when (pair? (cdr form)) (if (null? (cddr form)) ; (begin (f y)) (lint-format "begin could be omitted: ~A" caller (truncated-list->string form)) - + ;; these two are questionable -- simpler, but scope enlarged - (when (and (pair? (cadr form)) + (when (and (pair? (cadr form)) (len=1? (cddr form))) - + ;; begin+do+return -> do+return (if (and (eq? (caadr form) 'do) (< (tree-leaves (caddr form)) 24) ; or maybe (< ... (min 24 (tree-leaves do-form)))? @@ -21473,19 +21476,19 @@ ,(caddr form)))))))))) (lint-walk-open-body caller 'begin (cdr form) env)))) (hash-walker 'begin begin-walker)) - - + + ;; ---------------- with-baffle ---------------- (let () (define (with-baffle-walker caller form env) ;; with-baffle introduces a new frame, so we need to handle it here - (lint-walk-body caller 'with-baffle (cdr form) + (lint-walk-body caller 'with-baffle (cdr form) (cons (make-lint-var :with-baffle form 'with-baffle) env)) env) (hash-walker 'with-baffle with-baffle-walker)) - - + + ;; ---------------- let-temporarily ---------------- (let () (define (let-temporarily-walker caller form env) @@ -21497,14 +21500,14 @@ (lint-walk caller (cadr form) new-env)) (let ((e (lint-walk-body caller 'let-temporarily (cddr form) new-env))) (report-usage caller 'let-temporarily - (if (eq? e new-env) - () - (env-difference caller e new-env ())) + (if (eq? e new-env) + () + (env-difference caller e new-env ())) new-env)))) env) (hash-walker 'let-temporarily let-temporarily-walker)) - - + + ;; -------- with-let -------- (let () (define (with-let-walker caller form env) @@ -21512,13 +21515,14 @@ (lint-format "with-let is messed up: ~A" caller (truncated-list->string form)) (let ((e (cadr form))) (if (or (and (code-constant? e) - (not (let? e))) + (not (let? e)) + (not (eq? e '*s7*))) ; (with-let *s7* ... ) (and (pair? e) (let ((op (return-type (car e) env))) (and op - (not (return-type-ok? 'let? op)))))) ; (with-let 123 123) + (not (return-type-ok? 'let? op)))))) ; (with-let 123 123) (lint-format "~A: first argument should be an environment: ~A" 'with-let caller (truncated-list->string form))) - + (if (symbol? e) (set-ref e caller form env) (if (pair? e) @@ -21539,22 +21543,22 @@ (set! lib (if (defined? e) (symbol->value e) (let ((file (*autoload* e))) - (and (string? file) + (and (string? file) (load file)))))) (let-temporarily ((*e* (if (let? lib) lib *e*)) (lint-in-with-let #t)) (let ((e (lint-walk-open-body caller 'with-let (cddr form) new-env))) (if (not (or ignore-usage (tree-memq 'curlet (cddr form)))) - (report-usage caller 'with-let - (if (eq? e new-env) - () - (env-difference caller e new-env ())) + (report-usage caller 'with-let + (if (eq? e new-env) + () + (env-difference caller e new-env ())) new-env))))))) env) (hash-walker 'with-let with-let-walker)) - - + + ;; ---------------- load ---------------- (let () (define (load-walker caller form env) @@ -21572,19 +21576,19 @@ env)) env)) (hash-walker 'load load-walker)) - - + + ;; ---------------- require ---------------- (let () (define (require-walker caller form env) (if (not (pair? (cdr form))) ; (require) - (lint-format "~A is pointless" caller form) + (lint-format "~A is pointless" caller form) (if (lint-any? string? (cdr form)) ; (require "repl.scm") (lint-format "require's arguments should be symbols: ~A" caller (truncated-list->string form)))) (if (not *report-loaded-files*) env (let ((vars env)) - (for-each + (for-each (lambda (f) (let ((file (*autoload* f))) (if (string? file) @@ -21596,15 +21600,15 @@ (cdr form)) vars))) (hash-walker 'require require-walker)) - - + + ;; ---------------- call-with-input-file etc ---------------- (let () (define (call-with-io-walker caller form env) (check-call caller (car form) form env) (let ((len (if (eq? (car form) 'call-with-output-string) 2 3))) ; call-with-output-string func is the first arg, not second (when (= (length form) len) - + ;; call-with-output-string -> object->string (when (and (eq? (car form) 'call-with-output-string) (= (length form) 2) @@ -21618,8 +21622,8 @@ (eq? (caddar body) (car (cadadr form)))) (if (null? (cdr body)) (lint-format "perhaps ~A" caller - (lists->string form (cons 'object->string - (cons (cadar body) + (lists->string form (cons 'object->string + (cons (cadar body) (if (eq? (caar body) 'display) '(#f) ()))))) (if (and (len=1? (cdr body)) (len=1? (cadr body)) @@ -21627,7 +21631,7 @@ (lint-format "perhaps ~A" caller (lists->string form (list 'format #f (if (eq? (caar body) 'display) "~A~%" "~S~%") (cadar body))))))))) - + (let ((func (list-ref form (- len 1)))) (if (= len 3) (lint-walk caller (cadr form) env)) @@ -21656,19 +21660,19 @@ (len=2? (car body)) (eq? (cadar body) port)) ;; (call-with-input-file "file" (lambda (p) (read-char p))) -> (call-with-input-file "file" read-char) - (lint-format "perhaps ~A" caller - (lists->string form + (lint-format "perhaps ~A" caller + (lists->string form (list head (if (= len 2) (caar body) (values (cadr form) (caar body))))))) (let ((cc (make-lint-var port - (list (case head + (list (case head ((call-with-input-string) 'open-input-string) ((call-with-output-string) 'open-output-string) ((call-with-input-file) 'open-input-file) ((call-with-output-file) 'open-output-file))) head))) - (lint-walk-body caller head body (cons cc + (lint-walk-body caller head body (cons cc (cons (make-lint-var :let form head) env))) (report-usage caller head (list cc) env)))))))))) @@ -21676,8 +21680,8 @@ (for-each (lambda (op) (hash-walker op call-with-io-walker)) '(call-with-input-string call-with-input-file call-with-output-file call-with-output-string))) - - + + ;; ---------------- catch ---------------- (let () (define (catch-walker caller form env) @@ -21707,8 +21711,8 @@ (lint-walk caller error-handler env)))) env) (hash-walker 'catch catch-walker)) - - + + ;; ---------------- call-with-exit etc ---------------- (let () (define (call-with-exit-walker caller form env) @@ -21718,7 +21722,7 @@ (eq? (caadr form) 'lambda) (pair? (cadadr form)) (car (cadadr form))))) - + (if (not (symbol? continuation)) (lint-walk caller (cdr form) env) (let ((body (cddadr form)) @@ -21728,9 +21732,9 @@ (report-shadower caller head (if (eq? head 'call-with-exit) 'exit-function 'continuation) continuation form env)) - + (if (not (or (eq? head 'call-with-exit) ; (call/cc (lambda (p) (+ x (p 1)))) - (eq? continuation (car body)) ; and (null? (cdr) I think (call/cc (lambda (k) k)) is intended + (eq? continuation (car body)) ; and (null? (cdr) I think (call/cc (lambda (k) k)) is intended (tree-sym-set-member continuation '(lambda lambda* define define* curlet apply error) body))) ;; this checks for continuation as arg (of anything), and any of set as car ;; for define and define* it would be tighter to check that they aren't returned or used as an arg @@ -21738,9 +21742,9 @@ head (+ lint-left-margin 4) #\space (truncated-list->string form))) - + (if (not (tree-unquoted-member continuation body)) ; (call-with-exit (lambda (p) (+ x 1))) - (lint-format "~A ~A ~A appears to be unused: ~A" caller head + (lint-format "~A ~A ~A appears to be unused: ~A" caller head (if (eq? head 'call-with-exit) "exit function" "continuation") continuation (truncated-list->string form)) @@ -21750,7 +21754,7 @@ (eq? (car last) continuation)) ;; (call-with-exit (lambda (return) (display x) (return (+ x y)))) (lint-format "~A is redundant here: ~A" caller continuation (truncated-list->string last))))) - + (let ((cc (make-lint-var continuation (if (eq? head 'call-with-exit) :call/exit :call/cc) head))) (lint-walk-body caller head body (cons cc env)) (report-usage caller head (list cc) env))))) @@ -21759,19 +21763,19 @@ (hash-walker op call-with-exit-walker)) '(call/cc call-with-current-continuation call-with-exit))) - + ;; ---------------- import etc ---------------- (let () (define (get-repeats caller lst) (do ((repeats ()) (p lst (cdr p))) ((null? p) - (if (pair? repeats) + (if (pair? repeats) (lint-format "repeated entr~@P: ~{~A~^, ~}" caller (length repeats) (reverse repeats)))) (if (and (memq (car p) (cdr p)) (not (memq (car p) repeats))) (set! repeats (cons (car p) repeats))))) - + (define (walk-import caller form env) ; report repeated entries in import and export lists -- this does not apply to s7 (if (and (> (length form) 12) (just-symbols? (cdr form))) @@ -21787,7 +21791,7 @@ (get-repeats caller (cadr lst)) (loop (cdr lst))))) env))) - + (hash-walker 'provide (lambda (caller form env) (if (not (= (length form) 2)) ; (provide a b c) @@ -21797,13 +21801,13 @@ (if (not (memq op '(symbol? #f #t values))) ; (provide "test") (lint-format "provide's argument should be a symbol: ~S" caller form))))) env)) - + (hash-walker 'module ; module apparently has different syntax and expectations in various schemes (lambda (caller form env) (if (len>1? (cdr form)) (lint-walk 'module (cddr form) env)) env)) - + (hash-walker 'define-syntax (lambda (caller form env) ;; we need to put the macro name in env with ftype=define-syntax @@ -21812,7 +21816,7 @@ (not (keyword? (cadr form)))) ; !! this thing is a disaster from the very start (cons (make-fvar (cadr form) 'define-syntax #f #f #f) env) env))) - + (hash-walker 'define-method ; guile and mit-scheme have different syntaxes here (lambda (caller form env) (let ((cdr-form (cdr form))) @@ -21829,16 +21833,16 @@ env (cons (make-fvar (caar cdr-form) 'define-method #f #f #f) env)))) (lint-walk-body caller (caar cdr-form) (cdr cdr-form) new-env))))))) - + (hash-walker 'let-syntax (lambda (caller form env) (lint-walk-body caller 'define-method (cddr form) env) env)) - + (hash-walker 'letrec-syntax (lambda (caller form env) (lint-walk-body caller 'define-method (cddr form) env) env)) - + ;; ---------------- case-lambda ---------------- (let () (define (case-lambda-walker caller form env) @@ -21846,8 +21850,8 @@ (let ((lens ()) (body ((if (string? (cadr form)) cddr cdr) form)) ; might have a doc string before the clauses (doc-string (and (string? (cadr form)) (cadr form)))) - - (for-each + + (for-each (lambda (choice) (if (pair? choice) (let ((len (length (car choice)))) @@ -21857,17 +21861,17 @@ (set! lens (cons len lens)) (lint-walk 'case-lambda (cons 'lambda choice) env)))) body) - + (case (length lens) - ((1) + ((1) ;; (case-lambda (() (if #f #f))) -> (lambda () (if #f #f)) - (lint-format "perhaps ~A" caller - (lists->string form + (lint-format "perhaps ~A" caller + (lists->string form (if doc-string (list 'let (list (list '+documentation+ doc-string)) (cons 'lambda (car body))) (cons 'lambda (car body)))))) - ((2) + ((2) (when (let arglists-equal? ((args1 (caar body)) (args2 (caadr body))) (if (null? args1) @@ -21883,7 +21887,7 @@ (clause2 (cadr body)) (body2 (cdr clause2)) (arglist (let ((arg1 (car clause1)) - (arg2 (car clause2))) + (arg2 (car clause2))) (if (> (car lens) (cadr lens)) arg2 arg1))) ; lens is reversed (arg-name (last-ref arglist)) (diffs (let arg->defaults ((arg arg-name) @@ -21947,7 +21951,7 @@ (search (cdr vs))) ((eq? (var-history v) :built-in) - (lint-format "~A is the same as the built-in ~A ~A" caller + (lint-format "~A is the same as the built-in ~A ~A" caller func-name (if (eq? (car (var-initial-value v)) 'define-macro) 'macro 'function) vname)) @@ -21963,17 +21967,17 @@ vname)))) ((eq? vname func-name) - (lint-format "~A definition repeated: ~A" caller + (lint-format "~A definition repeated: ~A" caller func-name (truncated-list->string (var-initial-value func)))) - (else - (lint-format "~A could be (define ~A ~A)" caller + (else + (lint-format "~A could be (define ~A ~A)" caller func-name func-name vname)))))) (vector-set! old 2 (cons func (vector-ref old 2)))))))))) - - - - (denote reduce-tree + + + + (denote reduce-tree (let ((quit #f) (outer-vars ()) (local-ctr 0) @@ -21989,7 +21993,7 @@ (set-car! (car ovars) tree) (cadar ovars)) (set-outer (cdr ovars) tree)))) - + (denote (reduce-v v) ;; this might be the first appearance of (car v) (when (null? (cadr v)) @@ -22003,7 +22007,7 @@ (case (car tree) ((quote) tree) - + ((let let*) ;; in let we need to sort locals by order of appearance in the body (if (<= (length tree) 2) @@ -22022,7 +22026,7 @@ (set! locals (cadr tree)) (set! body (cddr tree)))) (if (not (list? locals)) (quit)) - + (let ((func (if (eq? (car tree) 'let) (lambda (local) (if (not (len>1? local)) (quit)) @@ -22036,7 +22040,7 @@ lvars)) (set! local-ctr (+ local-ctr 1)))))) (for-each func locals)) - + ;; now walk the body, setting the reduced local name by order of encounter (in let, not let*) (let ((new-body (reduce-walker body (append lvars vars)))) (unless (pair? new-body) (set! new-body (list new-body))) @@ -22050,15 +22054,15 @@ (set! local-ctr (+ local-ctr 1)))) lvars)) (set! lvars (sort! lvars (lambda (a b) (< (caddr a) (caddr b))))) - + (if named-let `(,(car tree) ,(cadr (assq (cadr tree) lvars)) ,(map (lambda (v) (list (cadr v) (cadddr v))) (cdr lvars)) ,@new-body) - `(,(car tree) + `(,(car tree) ,(map (lambda (v) (list (cadr v) (cadddr v))) lvars) ,@new-body))))) - + ((if) (if (not (and (len>1? (cdr tree)) (list? (cdddr tree)))) @@ -22071,14 +22075,14 @@ (cons 'unless (cons (cadr expr) (unbegin true))) (cons 'when (cons expr (unbegin true)))) (list 'if expr true (reduce-walker (cadddr tree) vars))))) - + ((when unless) (if (not (len>1? (cdr tree))) (quit)) - (cons (car tree) - (cons (reduce-walker (cadr tree) vars) + (cons (car tree) + (cons (reduce-walker (cadr tree) vars) (map (lambda (p) (reduce-walker p vars)) (cddr tree))))) - + ((set!) (if (not (len>1? (cdr tree))) (quit)) (if (symbol? (cadr tree)) @@ -22093,7 +22097,7 @@ (set! local-ctr (+ local-ctr 1))) (list 'set! (cadr v) (reduce-walker (caddr tree) vars))) (list 'set! (reduce-walker (cadr tree) vars) (reduce-walker (caddr tree) vars)))) - + ((do) (if (not (and (len>1? (cdr tree)) (list? (cadr tree)) @@ -22109,9 +22113,9 @@ (for-each (lambda (local) (if (not (len>1? local)) (quit)) - (set! lvars (cons (list (car local) - () 0 - (reduce-walker (cadr local) vars) + (set! lvars (cons (list (car local) + () 0 + (reduce-walker (cadr local) vars) (if (pair? (cddr local)) (caddr local) :unset)) @@ -22120,8 +22124,8 @@ (let ((new-env (append lvars vars))) (let ((new-end (reduce-walker end+result new-env)) (new-body (reduce-walker body new-env))) - (unless (pair? new-body) - (set! new-body (list new-body))) + (unless (pair? new-body) + (set! new-body (list new-body))) (when (pair? lvars) (for-each (lambda (lv) (if (not (eq? (lv 4) :unset)) @@ -22134,13 +22138,13 @@ (set! local-ctr (+ local-ctr 1)))) lvars) (set! lvars (sort! lvars (lambda (a b) (< (caddr a) (caddr b)))))) - - `(do ,(map (lambda (v) + + `(do ,(map (lambda (v) (map v (if (eq? (v 4) :unset) '(1 3) '(1 3 4)))) lvars) ,new-end ,@new-body))))) - + ((lambda) (if (not (proper-pair? (cdr tree))) (quit)) @@ -22160,12 +22164,12 @@ (append (copy lst (make-list (- (length lst) 1))) (last-ref lst))))))) (cons 'lambda (cons new-args new-body)))) - + ((case) (if (not (and (len>1? (cdr tree)) (pair? (caddr tree)))) (quit)) - (list 'case + (list 'case (reduce-walker (cadr tree) vars) (map (lambda (c) (if (not (len>1? c)) @@ -22173,7 +22177,7 @@ (cons (car c) (map (lambda (p) (reduce-walker p vars)) (cdr c)))) (cddr tree)))) - + ((letrec letrec*) (if (not (pair? (cdr tree))) (quit)) (let ((locals (cadr tree)) @@ -22192,13 +22196,13 @@ (for-each (lambda (local lv) (list-set! lv 3 (reduce-walker (cadr local) lvars))) locals lvars) - (cons (car tree) + (cons (car tree) (cons (map (lambda (v) (list (cadr v) (cadddr v))) lvars) (reduce-walker body (append lvars vars)))))) - + ((lambda*) (if (not (and (proper-pair? (cdr tree)) - (or (symbol? (cadr tree)) + (or (symbol? (cadr tree)) (proper-list? (cadr tree))))) (quit)) (let ((old-args (args->proper-list (cadr tree)))) @@ -22225,7 +22229,7 @@ (else (quit)))) (cadr tree))))) (cons 'lambda* (cons new-args new-body))))) - + (else ; still (pair? tree) but (car tree) not hit above (cons (cond ((pair? (car tree)) (reduce-walker (car tree) vars)) @@ -22236,31 +22240,31 @@ (reduce-walker p vars)) (cdr tree)) (cdr tree)))))) - + ;; (pair? tree) far far above - + ((or (not (symbol? tree)) (keyword? tree)) tree) - + ((assq tree vars) => reduce-v) ; replace in-tree symbol with its reduction (this includes any outer-var once set below) - + (fuvar (quit)) (else (set-outer outer-vars tree)))) - + (lambda (new-form leaves env fvar orig-form) (unless (tree-set-memq '(define define* ;; these propagate backwards and we're not returning the new env in this loop, - ;; lvars can be null, so splicing a new local into vars is a mess, + ;; lvars can be null, so splicing a new local into vars is a mess, ;; but if the defined name is not reduced, it can occur later as itself (not via car), ;; so without lots of effort (a dummy var if null lvars, etc), we can only handle ;; functions within a function (fvar not #f). ;; but adding that possibility got no hits list-values apply-values append quasiquote unquote - define-constant define-macro define-macro* define-expansion - define-syntax let-syntax letrec-syntax match syntax-rules + define-constant define-macro define-macro* define-expansion + define-syntax let-syntax letrec-syntax match syntax-rules require import module cond-expand reader-cond while case-lambda call-with-values let-values define-values let*-values multiple-value-bind) new-form) @@ -22285,13 +22289,13 @@ (search (car tree)) (search (cdr tree)))))) (if (not line) (set! line 0))) - + (set! leaves (tree-leaves reduced-form)) ; if->when, for example, so tree length might change (if (and (<= *fragment-min-size* leaves) (< leaves *fragment-max-size*)) (hash-fragment reduced-form leaves env fvar orig-form line outer-vars)) (when fvar (quit)) - + (unless (and (pair? lint-function-body) (equal? new-form (car lint-function-body))) (let ((fvars (let ((fcase (and (< leaves *fragment-max-size*) @@ -22315,7 +22319,7 @@ (truncated-list->string new-form) (var-name (car fvars)) (map (lambda (a) (case (car a) ((()) (values)) (else))) outer-vars))))))))))))) - + (define (lint-fragment form env) (let ((leaves (tree-leaves form))) (when (< *fragment-min-size* leaves *fragment-max-size*) @@ -22333,8 +22337,8 @@ (reduce-tree form leaves env (and (not (keyword? (var-name fvar))) fvar) form)))))) ;; ---------------------------------------- - - (denote lint-walk-pair + + (denote lint-walk-pair (let () (denote (walk-rest caller form env) (let ((vars env)) @@ -22343,17 +22347,17 @@ (set! vars (lint-walk caller f vars))) form)) env) - + ;; -------- walk head=symbol -------- - (denote walk-symbol - (letrec ((unsafe-makers '(sublet inlet copy cons list append subvector vector hash-table + (denote walk-symbol + (letrec ((unsafe-makers '(sublet inlet copy cons list append subvector vector hash-table make-hash-table make-hook list-values append gentemp or and not)) - - (equal-ignoring-constants? + + (equal-ignoring-constants? (lambda (a b) (or (equivalent? a b) (and (symbol? a) - (constant? a) + (constant? a) (equivalent? (symbol->value a) b)) (and (symbol? b) (constant? b) @@ -22365,7 +22369,7 @@ (constable? (lambda (cp) (and (len>1? cp) (memq (car cp) '(list vector int-vector float-vector byte-vector)) - (lint-every? (lambda (inp) + (lint-every? (lambda (inp) (and (or (not (symbol? inp)) ; leave (list pi *stderr*) unrewritten (keyword? inp)) (or (code-constant? inp) @@ -22377,11 +22381,11 @@ (set! (var-history v) (cons form (var-history v))) (set! (var-refenv v) env)) (check-call caller head form env) - + ;; look for one huge argument leaving lonely trailing arguments somewhere off the screen ;; (it needs to be one arg, not a call on values) (let ((branches (length form))) - + (when (and (= branches 2) (any-procedure? head v) (not (eq? head 'unquote))) @@ -22462,7 +22466,7 @@ (format #f ", assuming ~A is not a macro," head)))) ;; begin=(caar p) here is almost entirely as macro arg ;; (apply env-channel (make-env ...) args) -> (let ((<1> (make-env ...))) (apply env-channel <1> args)) - (lint-format "perhaps~A~%~NC~A ->~%~NC~A" caller + (lint-format "perhaps~A~%~NC~A ->~%~NC~A" caller disclaimer (+ lint-left-margin 4) #\space (lint-pp (append header (cons (one-call-and-dots (car p)) trailer))) @@ -22480,7 +22484,7 @@ (lint-pp `(let ((<1> ,(one-call-and-dots (car p)))) (,@header <1> ,@trailer))))) #t))))))))) - + (when (pair? form) ;; save any references to vars in their var-history (type checked later) ;; this can be fooled by macros, as everywhere else @@ -22491,10 +22495,10 @@ (set! (var-history v) (cons form (var-history v))) (set! (var-refenv v) env))))) form) - + (if (lint-set!? form env) (set-set (cadr form) caller form env))) - + (if (var? v) (if (memq (var-ftype v) '(define lambda define* lambda*)) (update-scope v caller env)) @@ -22502,9 +22506,9 @@ (cond ((hash-table-ref special-case-functions head) => (lambda (f) (f caller head form env)))) - + ;; change (list ...) to '(...) if it's safe as a constant list - ;; and (vector ...) -> #(...) + ;; and (vector ...) -> #(...) (if (and (pair? (cdr form)) (hash-table-ref no-side-effect-functions head) (not (memq head unsafe-makers))) @@ -22512,9 +22516,9 @@ (when (constable? p) (let ((pval (eval/error caller p))) (if (not (eq? pval :error)) - (lint-format "perhaps ~A -> ~A~A" caller + (lint-format "perhaps ~A -> ~A~A" caller (truncated-list->string p) - (if (eq? (car p) 'list) "'" "") + (if (eq? (car p) 'list) "'" "") (object->string pval)))))) (cdr form))) @@ -22527,18 +22531,18 @@ (set! last-simplify-numeric-line-number line-number) ;; (+ 1 2) -> 3, and many others (lint-format "perhaps ~A" caller (lists->string form val))))) - + ;; if a var is used before it is defined, the var history and ref/set ;; info needs to be saved until the definition, so other-identifiers collects it (unless (defined? head (rootlet)) - (hash-table-set! other-identifiers head + (hash-table-set! other-identifiers head (cons form (or (hash-table-ref other-identifiers head) ())))))) - + ;; (f ... (if A B C) (if A D E) ...) -> (f ... (if A (values B D) (values C E)) ...) - ;; these happen up to almost any number of clauses + ;; these happen up to almost any number of clauses ;; need true+false in every case, and need to be contiguous ;; case/cond happen here, but very rarely in a way we can combine via values - + (unless (any-macro? head env) ; actually most macros are safe here... (do ((p (cdr form) (cdr p))) ((or (not (pair? p)) @@ -22563,8 +22567,8 @@ (trues ()) (falses ())) ((eq? r q) - (list 'if test - (cons 'values (reverse trues)) + (list 'if test + (cons 'values (reverse trues)) (cons 'values (reverse falses)))) (set! trues (cons (caddar r) trues)) (set! falses (cons (car (cdddar r)) falses))))) @@ -22575,7 +22579,7 @@ "") (lists->string form (append header (cons middle q))))))))))))) (walk-rest caller form env)))) - + ;; -------- walk head=pair -------- (denote (walk-pair caller head form env) (cond ((eq? (car head) 'list) @@ -22583,30 +22587,30 @@ ((not (and (pair? (cdr head)) (memq (car head) '(lambda lambda*))))) - + ((and (identity? head) (pair? (cdr form))) ; identity needs an argument ;; ((lambda (x) x) 32) -> 32 (lint-format "perhaps ~A" caller (truncated-lists->string form (cadr form)))) - + ((and (symbol? (cadr head)) ; ((lambda x x) 1 2 3) -> (list 1 2 3) (len=1? (cddr head)) (eq? (cadr head) (caddr head))) (lint-format "perhaps ~A" caller (lists->string form (cons 'list (cdr form))))) - + ((and (null? (cadr head)) (pair? (cddr head))) ;; ((lambda () 32) 0) -> 32 - (lint-format "perhaps ~A" caller - (truncated-lists->string - form + (lint-format "perhaps ~A" caller + (truncated-lists->string + form (if (and (null? (cdddr head)) (not (and (pair? (caddr head)) (memq (caaddr head) '(define define* define-constant define-macro define-macro*))))) (caddr head) (cons 'let (cons () (cddr head))))))) - + ((and (proper-pair? (cddr head)) ; ((lambda (...) ...) ...) -> (let ...) -- lambda here is ugly and slow (not (lint-any? (lambda (a) (mv-range a env)) (cdr form)))) (call-with-exit @@ -22627,7 +22631,7 @@ (eq? (car head) 'lambda))) ; too many args (quit)) - (else + (else (for-each (lambda (p) (if (pair? p) (begin @@ -22657,9 +22661,9 @@ (cons (map list (reverse vars) (reverse vals)) (cddr head)))))))))) (walk-rest caller form env)) - + ;; -------- walk head=quasiquote (aimed at ,@x primarily) -------- - (denote walk-qq + (denote walk-qq (let ((qq-form #f)) (define (safe-av? p) @@ -22670,7 +22674,7 @@ (lambda (caller head form env) (for-each (lambda (p) (let ((sym (and (symbol? p) p))) - (cond ((not sym) + (cond ((not sym) #f) ((var-member sym env) (set-ref sym caller form env)) @@ -22678,7 +22682,7 @@ (hash-table-set! other-identifiers sym (cons form (or (hash-table-ref other-identifiers sym) ()))))))) (cdr form)) - + (let ((old-current-form lint-current-form)) ;; maybe put these on a switch -- some days I think they're good, and others... (unless (and qq-form @@ -22696,9 +22700,9 @@ (let ((lst-len (length lst))) (case lst-len ((2) (lint-format "perhaps ~A" caller (lists->string form `(cons ,(cadr lst) ,rest)))) - ((3) (lint-format "perhaps ~A" caller - (lists->string form - `(cons ,(cadr lst) + ((3) (lint-format "perhaps ~A" caller + (lists->string form + `(cons ,(cadr lst) (cons ,(caddr lst) ,rest))))))))) (when (eq? head 'list-values) @@ -22716,16 +22720,16 @@ (unlist-values (if (pair? (cadr arg1)) (cadr arg1) (list 'copy (cadr arg1))))))))) - ((or (symbol? arg1) + ((or (symbol? arg1) (quoted-symbol? arg1)) - (lint-format "perhaps ~A" caller ; `(,x) -> (list x) + (lint-format "perhaps ~A" caller ; `(,x) -> (list x) (lists->string form (list 'list arg1)))) ((and (pair? arg1) ; `((a ,b)) -> (list (list 'a b)) (not (tree-set-memq '(apply-values unquote) arg1))) (lint-format "perhaps ~A" caller ((if (< (tree-leaves form) 50) lists->string truncated-lists->string) - form + form (unlist-values form))))))) ((3) @@ -22737,9 +22741,9 @@ (eq? (cadr arg1) 'begin) (not (and (pair? arg2) (eq? (car arg2) 'apply-values)))) ; no other way to splice here, I hope - (lint-format "pointless begin: ~A" caller + (lint-format "pointless begin: ~A" caller (lists->string form (caddr form)))) - + (cond ((and (len=1? arg2) (eq? (car arg2) 'apply-values)) (lint-format "apply-values takes one argument: ~A" caller form)) @@ -22757,7 +22761,7 @@ (list 'cons (unlist-values arg1) (cadr arg2))) ((list-values) (list 'list (unlist-values arg1) (cons 'list (cdr arg2)))) - (else + (else (list 'list (unlist-values arg1) arg2))) (list 'list (unlist-values arg1) arg2))))) ((and (len=2? arg1) @@ -22767,15 +22771,15 @@ (not (qq-tree? (cadr arg2))) (eq? (car arg2) 'apply-values)) ; `(,@x ,@y) -> (append x y) (lint-format "perhaps ~A" caller - (lists->string form - (list 'append - (unlist-values (cadr arg1)) + (lists->string form + (list 'append + (unlist-values (cadr arg1)) (unlist-values (cadr arg2))))) (if (not (and (pair? arg2) (tree-set-memq '(apply-values append unquote) arg2))) (lint-format "perhaps ~A" caller ; `(,@x ,y) -> (append x (list y)) (lists->string form - (list 'append + (list 'append (unlist-values (cadr arg1)) (list 'list (unlist-values arg2)))))))) @@ -22797,21 +22801,21 @@ (pa2 (case len2 ((2) (list 'cons (cadr ca2) (caddr arg2))) ((3) (list 'cons (cadr ca2) (list 'cons (caddr ca2) (caddr arg2))))))) - (if (and (pair? pa1) + (if (and (pair? pa1) (pair? pa2)) - (lint-format "perhaps ~A" caller + (lint-format "perhaps ~A" caller (lists->string form (list 'list pa1 pa2)))))))) ((not (tree-set-memq '(apply-values unquote) (cdr form))) (lint-format "perhaps ~A" caller ((if (< (tree-leaves form) 100) lists->string truncated-lists->string) - form + form (unlist-values form))))))) - - (else ; checked already that form is a proper-list, so the length here is > 3 + + (else ; checked already that form is a proper-list, so the length here is > 3 (let ((args (cdr form))) ; car is list-values (cond ((lint-every? (lambda (p) ; `((f . ,a) (g . ,b)...) -> (list (cons f a) (cons g b) ...) - (and (pair? p) ; from (append (list x) y) -> (cons x y) + (and (pair? p) ; from (append (list x) y) -> (cons x y) (eq? (car p) 'append) (len=2? (cdr p)) (len=2? (cadr p)) @@ -22822,7 +22826,7 @@ `(list (cons ,(cadadr (car args)) ,(caddar args)) (cons ,(cadadr (cadr args)) ,(caddr (cadr args))) ...)))) - + ((lint-any? (lambda (p) (and (len=1? p) (eq? (car p) 'apply-values))) @@ -22837,9 +22841,9 @@ (memq (caaddr args) '(apply-values append unquote))))) (lint-format "perhaps ~A" caller (lists->string form - (list 'append (cadar args) (cadadr args) + (list 'append (cadar args) (cadadr args) (list 'list (unlist-values (caddr args)))))))) - + ;; `(+ ,y ,@(map f x)) -> (cons '+ (cons y (map f x))) ;; `(+ ,y ,@x ,@z etc) -> (cons '+ (cons y (append x z ...))) ;; `(f ,@x ,@y etc) -> (cons 'f (append x y ...)) @@ -22853,7 +22857,7 @@ (lint-format "perhaps ~A" caller (lists->string form `(cons ,(unlist-values (car args)) (append ,@(map cadr (cdr args))))))))) - + ((not (or (tree-set-memq '(apply-values append unquote) (car args)) (tree-set-memq '(apply-values append unquote) (cadr args)))) (lint-format "perhaps ~A" caller @@ -22868,26 +22872,26 @@ (not (tree-set-memq '(apply-values append unquote) (cadr args)))) (lint-format "perhaps ~A" caller (lists->string form - (list 'append (cadar args) + (list 'append (cadar args) (list 'cons (unlist-values (cadr args)) (cadr (caddr args)))))))))))))) (let ((e (walk-rest caller form env))) (set! lint-current-form old-current-form) e))))) - + ;; -------- lint-walk-pair -------- (lambda (caller form env) (let ((head (car form))) (set! line-number (or (pair-line-number form) (max line-number 0))) - + (if *report-repeated-code-fragments* (lint-fragment form env)) ;; (error...) as arg happens very rarely (a half-dozen hits, one: (values (error...))! - - (cond + + (cond ((hash-table-ref walker-functions head) - => (lambda (walker) + => (lambda (walker) (walker caller form env))) ((not (proper-list? form)) @@ -22899,7 +22903,7 @@ (memq head '(or and)))) (lint-format "unexpected dot: ~A" caller (truncated-list->string form))) env) - + ((and *report-quasiquote-rewrites* (memq head '(list-values apply-values))) (walk-qq caller head form env)) @@ -22911,7 +22915,7 @@ (walk-pair caller head form env)) (else (walk-rest caller form env))))))) - + ;; -------- lint-walk -------- (denote (lint-walk caller form env) (cond ((symbol? form) @@ -22931,7 +22935,7 @@ ;; and functions from elsewhere that lint can't see (cond ((assq form recent-names) => (lambda (data) - (lint-format "~S might be undefined, but it was defined recently (via a ~S broadly speaking) to be ~S" + (lint-format "~S might be undefined, but it was defined recently (via a ~S broadly speaking) to be ~S" caller form (cadr data) (caddr data)))))) |# (hash-table-set! other-identifiers form (cons #f (or old ())))))) @@ -22958,7 +22962,7 @@ ((or (= i len) (not (integer? (vector-ref form i)))) (if (= i len) - (lint-format "~A could be ~A" caller + (lint-format "~A could be ~A" caller (let-temporarily (((*s7* 'print-length) 8)) (values (object->string form) (object->string (copy form (make-int-vector len))))))))) @@ -22967,7 +22971,7 @@ ((or (= i len) (not (float? (vector-ref form i)))) (if (= i len) - (lint-format "~A could be ~A" caller + (lint-format "~A could be ~A" caller (let-temporarily (((*s7* 'print-length) 8)) (values (object->string form) (object->string (copy form (make-float-vector len))))))))))) @@ -22981,20 +22985,20 @@ form) ;; (begin (define x 1) `#(,x)) (if (not happy) - (lint-format "quasiquoted vectors are not supported: ~A~%~NCperhaps use `(vector ...) rather than `#(...)" caller + (lint-format "quasiquoted vectors are not supported: ~A~%~NCperhaps use `(vector ...) rather than `#(...)" caller (truncated-list->string form) (+ lint-left-margin 4) #\space)))))) - ;; `(x #(,x)) for example will not work in s7, but `(,x ,(vector x)) will + ;; `(x #(,x)) for example will not work in s7, but `(,x ,(vector x)) will env) - + (else env))) - + ;; -------- lint-file -------- (define *report-input* #t) ;; lint-file is called via load etc above and it's a pain to thread this variable all the way down the call chain - + (define (lint-file-1 file env) (set! linted-files (cons file linted-files)) (let ((fp (if (input-port? file) @@ -23005,7 +23009,7 @@ (lambda () (let ((p (open-input-file file))) (when *report-input* - (format outport + (format outport (if (and (output-port? outport) (not (member outport (list *stderr* *stdout*)))) (values "~%~NC~%;~A~%" (+ lint-left-margin 16) #\-) @@ -23015,7 +23019,7 @@ (lambda (type info) (format outport "~NCcan't open ~S: ~A~%" lint-left-margin #\space file (apply format #f info)) #f)))))) - + (if (not (input-port? fp)) env (do ((vars env) @@ -23023,11 +23027,11 @@ (last-form #f) (last-line-number -1) (form (read fp) (read fp))) - ((eof-object? form) - + ((eof-object? form) + (if (not (input-port? file)) (close-input-port fp)) - + (when (and *report-repeated-code-fragments* (or (not *report-loaded-files*) (= lint-left-margin 1))) @@ -23077,15 +23081,15 @@ (set! reported #t) (format outport "~%~NCrepeated code fragments:~%" lint-left-margin #\space)) (set! reports (+ reports 1)) - (format outport + (format outport (if (equal? (val 3) (car keyval)) - (values "~NCsize: ~A, uses: ~A, lines: '~A:~%~NCexpression: ~A~%" + (values "~NCsize: ~A, uses: ~A, lines: '~A:~%~NCexpression: ~A~%" lint-left-margin #\space size (val 0) (val 1) (+ lint-left-margin 2) #\space (let-temporarily ((target-line-length 120)) (truncated-list->string (car keyval)))) - (values "~NCsize: ~A, uses: ~A, lines: '~A:~%~NCpattern: ~A~%~NCexample: ~A~A~%" + (values "~NCsize: ~A, uses: ~A, lines: '~A:~%~NCpattern: ~A~%~NCexample: ~A~A~%" lint-left-margin #\space size (val 0) (val 1) (+ lint-left-margin 2) #\space @@ -23099,7 +23103,7 @@ "" (let ((vars (map (lambda (v) (case (car v) ((()) (values)) (else))) (val 5)))) (if (pair? vars) - (format #f "~%~NCwith var~P: ~{~A ~}" + (format #f "~%~NCwith var~P: ~{~A ~}" (+ lint-left-margin 4) #\space (length vars) vars) "")))))))))) (sort! reportables ; the sort needs to be stable across calls so diff works on the output @@ -23113,21 +23117,21 @@ (or (string<? (or (a 4) (set! (a 4) (object->string (a 3)))) (or (b 4) (set! (b 4) (object->string (b 3))))) (and (string=? (a 4) (b 4)) ; finally by reduced form as a string - (string<? (object->string (car kv1)) + (string<? (object->string (car kv1)) (object->string (car kv2)))))))))))))))) vars) ; lint-file-1 should return the environment (if (pair? form) (set! line (max line (or (pair-line-number form) 0)))) - + (if (not (or (= last-line-number -1) (side-effect? last-form vars))) - (format outport "~NCtop-level (line ~D): this has no effect: ~A~%" + (format outport "~NCtop-level (line ~D): this has no effect: ~A~%" lint-left-margin #\space last-line-number (truncated-list->string last-form))) (set! last-form form) (set! last-line-number line) - + (if (and (len>1? form) (hash-table-ref definers-table (car form)) ; set! case is handled elsewhere (not (memq (car form) '(eval eval-string load require))) ; (eval-string|load (string-append...)) (eval (string->symbol...)) @@ -23136,19 +23140,19 @@ (let ((f ((if (pair? (cadr form)) caadr cadr) form))) (if (and (symbol? f) (hash-table-ref built-in-functions f)) - (format outport "~NCtop-level ~Aredefinition of built-in function ~A: ~A~%" - lint-left-margin #\space + (format outport "~NCtop-level ~Aredefinition of built-in function ~A: ~A~%" + lint-left-margin #\space (if (and (pair-line-number form) (> (pair-line-number form) 0)) (format #f "(line ~D) " (pair-line-number form)) "") f (truncated-list->string form))))) - - (set! vars (lint-walk (if (symbol? form) - form - (and (pair? form) + + (set! vars (lint-walk (if (symbol? form) + form + (and (pair? form) (car form))) - form + form vars)))))) @@ -23161,7 +23165,7 @@ (old-pp-left-margin pp-left-margin) (old-lint-left-margin lint-left-margin) (old-load-path *load-path*)) - + (dynamic-wind (lambda () (set! pp-left-margin (+ pp-left-margin 4)) @@ -23174,10 +23178,10 @@ (if (> last-pos 0) (set! *load-path* (cons (substring file 0 last-pos) *load-path*)))) (set! last-pos pos))))) - + (lambda () (lint-file-1 file env)) - + (lambda () (set! pp-left-margin old-pp-left-margin) (set! lint-left-margin old-lint-left-margin) @@ -23185,14 +23189,14 @@ (set! *load-path* old-load-path) (if (positive? (length *current-file*)) (newline outport))))))) - - + + ;;; --------------------------------------------------------------------------------' ;;; lint itself ;;; (let ((+documentation+ "(lint file port) looks for infelicities in file's scheme code") (+signature+ '(#t (string? input-port?) (output-port? null?) boolean?)) ; not list! we want a list of symbols - (readers + (readers (list (cons #\e (lambda (str) (unless (string=? str "e") (let ((num (string->number (substring str 1)))) @@ -23207,8 +23211,8 @@ (cons #\i (lambda (str) (unless (string=? str "i") (let ((num (string->number (substring str 1)))) - (when num - (format outport + (when num + (format outport (if (not (rational? num)) (values "~NCthis #i is dumb, #~A -> ~A~%" lint-left-margin #\space str (substring str 1)) (values "~NCperhaps #~A -> ~A~%" lint-left-margin #\space str (* 1.0 num))))))) @@ -23218,20 +23222,20 @@ (string->number (substring str 1))) (format outport "~NC#d is pointless, #~A -> ~A~%" lint-left-margin #\space str (substring str 1))) #f)) - + (cons #\' (lambda (str) ; for Guile (and syntax-rules, I think) (list 'syntax (if (string=? str "'") (read) (string->symbol (substring str 1)))))) - + (cons #\` (lambda (str) ; for Guile (sigh) (list 'quasisyntax (if (string=? str "`") (read) (string->symbol (substring str 1)))))) - + (cons #\, (lambda (str) ; the same, the last is #,@ -> unsyntax-splicing -- right. (list 'unsyntax (if (string=? str ",") (read) (string->symbol (substring str 1)))))) - + (cons #\& (lambda (str) ; ancient Guile code (and (> (length str) 1) (string->keyword (substring str 1))))) - + (cons #\\ (lambda (str) (cond ((assoc str '(("\\x0" . #\null) ("\\x7" . #\alarm) @@ -23245,7 +23249,7 @@ => (lambda (c) (format outport "~NC#\\~A is ~W~%" lint-left-margin #\space (substring str 1) (cdr c))))) #f)) - + (cons #\! (lambda (str) (if (member str '("!optional" "!default" "!rest" "!key" "!aux" "!false" "!true" "!r6rs") string-ci=?) ; for MIT-scheme (string->keyword (substring str 1)) @@ -23279,23 +23283,23 @@ (lambda () (case (data 0) ((#\;) (read) (values)) - + ((#\T) (and (string=? data "T") (format outport "#T should be #t~%") #t)) - - ((#\F) - (and (string=? data "F") + + ((#\F) + (and (string=? data "F") (format outport "#F should be #f~%") ''#f)) - - ((#\X #\B #\O #\D) + + ((#\X #\B #\O #\D) (let ((num (string->number (substring data 1) (case (data 0) ((#\X) 16) ((#\O) 8) ((#\B) 2) ((#\D) 10))))) (if (number? num) (begin - (format outport "~NCuse #~A~A not #~A~%" - lint-left-margin #\space + (format outport "~NCuse #~A~A not #~A~%" + lint-left-margin #\space (char-downcase (data 0)) (substring data 1) data) num) (string->symbol data)))) @@ -23303,11 +23307,11 @@ ((#\i) (format outport "#i is used for int-vectors, not numbers.~%") (cond ((string->number (substring data 1)) => exact->inexact) (else #f))) - + ((#\r) (format outport "#r is used for float-vectors, not numbers.~%") #f) - + ((#\l #\z) (let ((num (string->number (substring data 1)))) ; Bigloo (also has #ex #lx #z and on and on) (if (number? num) @@ -23315,14 +23319,14 @@ (format outport "~NCjust omit this silly #~C!~%" lint-left-margin #\space (data 0)) num) (string->symbol data)))) - + ((#\u) ; for Bigloo (if (string=? data "unspecified") (format outport "~NCuse #<unspecified>, not #unspecified~%" lint-left-margin #\space)) ;; #<unspecified> seems to hit the no-values check? (string->symbol data)) ;; Bigloo also seems to use #" for here-doc concatenation?? - + ((#\v) ; r6rs byte-vectors? (if (string=? data "vu8") (format outport "~NCuse #u, not #vu8~%" lint-left-margin #\space)) @@ -23331,8 +23335,8 @@ ((#\>) ; for Chicken, apparently #>...<# encloses in-place C code (do ((last #\#) (c (read-char) (read-char))) - ((and (char=? last #\<) - (char=? c #\#)) + ((and (char=? last #\<) + (char=? c #\#)) (values)) (if (char=? c #\newline) (set! (port-line-number) (+ (port-line-number) 1))) @@ -23340,7 +23344,7 @@ ((#\<) ; Chicken also, #<<EOF -> EOF (if (string=? data "<undef>") ; #<undef> chibi et al - #<undefined> + #<undefined> (if (and (char=? (data 1) #\<) (> (length data) 2)) (do ((end (substring data 2)) @@ -23348,8 +23352,8 @@ ((string-position end c) (values))) (string->symbol data)))) - - ((#\\) + + ((#\\) (cond ((assoc data '(("\\newline" . #\newline) ("\\return" . #\return) ("\\space" . #\space) @@ -23368,7 +23372,7 @@ ("\\bel" . #\alarm) ; #\x07 ("\\sub" . #\x1a) ("\\soh" . #\x01) - + ;; these are for Guile ("\\vt" . #\xb) ("\\bs" . #\backspace) @@ -23383,9 +23387,9 @@ => (lambda (c) (format outport "~NCperhaps use ~W instead~%" (+ lint-left-margin 4) #\space (cdr c)) (cdr c))) - (else + (else (string->symbol (substring data 1))))) - (else + (else (string->symbol data)))) (lambda args #f)))))))))) @@ -23401,7 +23405,7 @@ (set! fragmax (min fragmax (- *fragment-max-size* 1))) (fill! fragments #f) - + (set! last-simplify-boolean-line-number -1) (set! last-simplify-numeric-line-number -1) (set! last-simplify-cxr-line-number -1) @@ -23431,10 +23435,10 @@ ;; preset list-tail and list-ref (vector-set! fragments 10 (make-hash-table)) (hash-table-set! (vector-ref fragments 10) '((if (zero? <2>) <1> (<F> (cdr <1>) (- <2> 1)))) - (vector 0 () - (list (cons 'list-tail + (vector 0 () + (list (cons 'list-tail (inlet 'initial-value '(define (list-tail x k) (if (zero? k) x (list-tail (cdr x) (- k 1)))) - 'arglist '(x k) + 'arglist '(x k) 'history :built-in))) '(define (list-tail x k) (if (zero? k) x (list-tail (cdr x) (- k 1)))) #f)) @@ -23446,11 +23450,11 @@ 'history :built-in))) '(define (list-ref items n) (if (= n 0) (car items) (list-ref (cdr items) (- n 1)))) #f)) - - + + ;; -------- call lint -------- - (let ((vars (let-temporarily (((*s7* 'expansions?) #f)) + (let ((vars (let-temporarily (((*s7* 'expansions?) #f)) (lint-file file ())))) (set! lint-left-margin (max lint-left-margin 1)) @@ -23463,15 +23467,15 @@ (hash-table-set! *top-level-objects* (car var) *current-file*) (if (and (string? *current-file*) (not (string=? var-file *current-file*))) - (format outport "~NC~S is defined at the top level in ~S and ~S~%" - lint-left-margin #\space + (format outport "~NC~S is defined at the top level in ~S and ~S~%" + lint-left-margin #\space (car var) var-file *current-file*))))) vars)) - + (if (string? file) (report-usage top-level: "" vars vars)))) - (for-each + (for-each (lambda (p) (if (> (cdr p) 3) (format outport "'~A occurs ~D times~%" @@ -23481,11 +23485,11 @@ ;(format *stderr* "~W~%" other-identifiers) (if (and *report-undefined-identifiers* (positive? (hash-table-entries other-identifiers))) - (let ((lst (sort! (map car other-identifiers) + (let ((lst (sort! (map car other-identifiers) (lambda (a b) (string<? (symbol->string a) (symbol->string b)))))) (format outport "~NCth~A identifier~A not defined~A: ~{~S~^ ~}~%" - lint-left-margin #\space + lint-left-margin #\space (if (= (hash-table-entries other-identifiers) 1) (values "is" " was") (values "e following" "s were")) @@ -23499,8 +23503,8 @@ ;;; this reads an HTML file, finds likely-looking scheme code, and runs lint over it. ;;; called on all snd files in hg.scm -(define html-lint - (letrec ((remove-markups +(define html-lint + (letrec ((remove-markups (lambda (str) (let ((tpos (string-position "<b>" str))) (if tpos @@ -23518,7 +23522,7 @@ (string-append (substring str 0 pos) (substring str bpos epos) (remove-markups (substring str (+ epos (if (and apos (= apos pos)) 4 5)))))))))))) - (fixup-html + (fixup-html (lambda (str) (let ((pos (char-position #\& str))) (if (not pos) @@ -23526,9 +23530,9 @@ (string-append (substring str 0 pos) (let* ((epos (char-position #\; str pos)) (substr (substring str (+ pos 1) epos))) - (string-append (cond ((assoc substr '(("gt" . ">") - ("lt" . "<") - ("mdash" . "-") + (string-append (cond ((assoc substr '(("gt" . ">") + ("lt" . "<") + ("mdash" . "-") ("amp" . "&")) string=?) => cdr) (else (format #t "unknown: ~A~%" substr))) @@ -23539,11 +23543,11 @@ (do ((line-num 0 (+ line-num 1)) (line (read-line f #t) (read-line f #t))) ((eof-object? line)) - + ;; look for <pre , gather everything until </pre> ;; decide if it is scheme code (first char is #\() ;; if so, clean out html markup stuff, call lint on that - + (when (string-position "<pre" line) (let ((code (substring line (+ (char-position #\> line) 1)))) (do ((cline (read-line f #t) (read-line f #t)) @@ -23551,7 +23555,7 @@ ((string-position "</pre>" cline) (set! line-num (+ line-num rline))) (set! code (string-append code cline))) - + ;; is first non-whitespace char #\(? ignoring comments (do ((len (length code)) (i 0 (+ i 1))) @@ -23567,8 +23571,8 @@ (lambda () (let ((outstr (call-with-output-string (lambda (op) - (call-with-input-string - (object->string (with-input-from-string + (call-with-input-string + (object->string (with-input-from-string (fixup-html (remove-markups code)) read) #t) ; write, not display @@ -23583,7 +23587,7 @@ ;;; -------------------------------------------------------------------------------- -;;; and this reads C code looking for s7_eval_c_string. No attempt here to +;;; and this reads C code looking for s7_eval_c_string. No attempt here to ;;; handle weird cases. (define (C-lint file) @@ -23604,10 +23608,10 @@ (set! code (string-append code cline)) (set! line-num (+ line-num rline))) (set! code (string-append code cline)))) - + (let ((len (string-position "\");" code))) (set! code (substring code 0 len)) - + ;; clean out backslashes (do ((i 0 (+ i 1))) ((>= i (- len 3))) @@ -23616,10 +23620,10 @@ ((char=? (code (+ i 1)) #\n) (set! (code i) #\space) (set! (code (+ i 1)) #\space)) - + ((memv (code (+ i 1)) '(#\newline #\")) (set! (code i) #\space)) - + ((and (char=? (code (+ i 1)) #\\) (char=? (code (- i 1)) #\#)) (set! (code (- i 1)) #\space) @@ -23641,7 +23645,7 @@ ;;; -------------------------------------------------------------------------------- #| ;;; external use of lint contents (see also snd-lint.scm): -(for-each (lambda (f) +(for-each (lambda (f) (if (not (hash-table-ref (*lint* 'no-side-effect-functions) (car f))) (format *stderr* "~A " (car f)))) (*lint* 'built-in-functions)) @@ -23662,4 +23666,3 @@ |# ;;; 54 896368, 53 874874, 52 871075 - diff --git a/notcurses_s7.c b/notcurses_s7.c index ada100e..e1cb51f 100644 --- a/notcurses_s7.c +++ b/notcurses_s7.c @@ -8,14 +8,19 @@ #include <notcurses/notcurses.h> #include <notcurses/direct.h> -/* notcurses version.h (included only after version 2) has only string version numbers, so if using version 1, pass -DNOTCURSES_1=1 */ -#if (!NOTCURSES_1) - #define NOTCURSES_2 1 - /* version 2.0.5 has an incompatible change to ncplane_options, plus some other functions; - * to get these, define NOTCURSES_2_0_5 before compiling this file. - */ -#else + +/* notcurses version.h was included only by version 2 so if using version 1, pass -DNOTCURSES_1=1 */ +#if NOTCURSES_1 #define NOTCURSES_2 0 + #define NOTCURSES_2_0_5 0 +#else + #define NOTCURSES_2 1 + #include <notcurses/version.h> + #ifndef NOTCURSES_2_0_5 + #if (defined(NOTCURSES_VERNUM_MAJOR)) && (NOTCURSES_VERNUM_MAJOR >= 2) && (NOTCURSES_VERNUM_PATCH >= 5) + #define NOTCURSES_2_0_5 1 + #endif + #endif #endif #include "s7.h" @@ -1601,6 +1606,32 @@ static s7_pointer g_ncplane_putnstr_aligned(s7_scheme *sc, s7_pointer args) (size_t)s7_integer_checked(sc, s7_cadddr(args)), (const char *)s7_string_checked(sc, s7_cadr(s7_cdddr(args)))))); } + +#if (NOTCURSES_VERNUM_MAJOR >= 2) && ((NOCURSES_VERNUM_MINOR > 0) || (NOTCURSES_VERNUM_PATCH >= 11)) +static s7_pointer g_ncpile_render(s7_scheme *sc, s7_pointer args) +{ + return(s7_make_integer(sc, ncpile_render((struct ncplane *)s7_c_pointer_with_type(sc, s7_car(args), ncplane_symbol, __func__, 1)))); +} + +static s7_pointer g_ncpile_rasterize(s7_scheme *sc, s7_pointer args) +{ + return(s7_make_integer(sc, ncpile_rasterize((struct ncplane *)s7_c_pointer_with_type(sc, s7_car(args), ncplane_symbol, __func__, 1)))); +} + +static s7_pointer g_ncpile_create(s7_scheme *sc, s7_pointer args) +{ + return(s7_make_c_pointer_with_type(sc, ncpile_create((struct notcurses *)s7_c_pointer_with_type(sc, s7_car(args), notcurses_symbol, __func__, 1), + (const ncplane_options *)s7_c_pointer(s7_cadr(args))), + ncplane_symbol, s7_f(sc))); +} + +static s7_pointer g_ncplane_reparent_family(s7_scheme *sc, s7_pointer args) +{ + return(s7_make_c_pointer_with_type(sc, ncplane_reparent_family((struct ncplane *)s7_c_pointer_with_type(sc, s7_car(args), ncplane_symbol, __func__, 1), + (struct ncplane *)s7_c_pointer_with_type(sc, s7_cadr(args), ncplane_symbol, __func__, 1)), + ncplane_symbol, s7_f(sc))); +} +#endif #endif static s7_pointer g_ncplane_putnstr_yx(s7_scheme *sc, s7_pointer args) @@ -3487,7 +3518,7 @@ static s7_pointer g_ncvisual_destroy(s7_scheme *sc, s7_pointer args) ncvisual_destroy((struct ncvisual *)s7_c_pointer_with_type(sc, s7_car(args), ncvisual_symbol, __func__, 1)); return(s7_f(sc)); } - + static s7_pointer g_ncvisual_decode(s7_scheme *sc, s7_pointer args) { return(s7_make_integer(sc, ncvisual_decode((struct ncvisual *)s7_c_pointer_with_type(sc, s7_car(args), ncvisual_symbol, __func__, 1)))); @@ -3595,6 +3626,13 @@ static s7_pointer g_ncvisual_geom(s7_scheme *sc, s7_pointer args) return(s7_list(sc, 5, res, s7_make_integer(sc, y), s7_make_integer(sc, x), s7_make_integer(sc, toy), s7_make_integer(sc, tox))); } +#if (NOTCURSES_VERNUM_MAJOR >= 2) && ((NOCURSES_VERNUM_MINOR > 0) || (NOTCURSES_VERNUM_PATCH >= 11)) +static s7_pointer g_ncvisual_decode_loop(s7_scheme *sc, s7_pointer args) +{ + return(s7_make_integer(sc, ncvisual_decode_loop((struct ncvisual *)s7_c_pointer_with_type(sc, s7_car(args), ncvisual_symbol, __func__, 1)))); +} +#endif + /* typedef int (*streamcb)(struct ncvisual*, struct ncvisual_options*, const struct timespec*, void*); * int ncvisual_stream(struct notcurses* nc, struct ncvisual* ncv, nc_err_e* ncerr, float timescale, streamcb streamer, const struct ncvisual_options* vopts, void* curry); */ @@ -3771,7 +3809,11 @@ void notcurses_s7_init(s7_scheme *sc) nc_int(NCOPTION_NO_ALTERNATE_SCREEN); nc_int(NCOPTION_NO_FONT_CHANGES); +#if (defined NOTCURSES_VERSION_COMPARABLE) && (NOTCURSES_VERSION_COMPARABLE(2,1,4) >= NOTCURSES_VERNUM_ORDERED) + /* notcurses-2.1.4 dropped CELL_WIDEASIAN_MASK */ +#else nc_int(CELL_WIDEASIAN_MASK); +#endif nc_int(CELL_BGDEFAULT_MASK); nc_int(CELL_FGDEFAULT_MASK); nc_int(CELL_BG_RGB_MASK); @@ -3800,6 +3842,10 @@ void notcurses_s7_init(s7_scheme *sc) nc_int(NCSTYLE_INVIS); nc_int(NCSTYLE_PROTECT); nc_int(NCSTYLE_ITALIC); +#if (defined(NOTCURSES_VERNUM_MAJOR)) && (NOTCURSES_VERNUM_MAJOR >= 2) && ((NOCURSES_VERNUM_MINOR > 0) || (NOTCURSES_VERNUM_PATCH >= 11)) + nc_int(NCSTYLE_STRUCK); + nc_int(NCSTYLE_NONE); +#endif nc_int(WCHAR_MAX_UTF8BYTES); @@ -4145,6 +4191,13 @@ void notcurses_s7_init(s7_scheme *sc) nc_func(ncplane_above, 1, 0, false); nc_func(ncplane_parent, 1, 0, false); +#if (defined(NOTCURSES_VERNUM_MAJOR)) && (NOTCURSES_VERNUM_MAJOR >= 2) && ((NOCURSES_VERNUM_MINOR > 0) || (NOTCURSES_VERNUM_PATCH >= 11)) + nc_func(ncpile_render, 1, 0, false); + nc_func(ncpile_rasterize, 1, 0, false); + nc_func(ncpile_create, 2, 0, false); + nc_func(ncplane_reparent_family, 2, 0, false); +#endif + nc_func(cell_make, 0, 0, false); nc_func(cell_load, 3, 0, false); nc_func(cell_duplicate, 3, 0, false); @@ -4340,6 +4393,9 @@ void notcurses_s7_init(s7_scheme *sc) nc_func(ncvisual_render, 3, 0, false); nc_func(ncvisual_simple_streamer, 4, 0, false); nc_func(ncvisual_geom, 7, 0, false); +#if (defined(NOTCURSES_VERNUM_MAJOR)) && (NOTCURSES_VERNUM_MAJOR >= 2) && ((NOCURSES_VERNUM_MINOR > 0) || (NOTCURSES_VERNUM_PATCH >= 11)) + nc_func(ncvisual_decode_loop, 1, 0, false); +#endif nc_func(ncplane_rgba, 6, 0, false); nc_func(ncblit_rgba, 3, 0, false); @@ -4379,6 +4435,12 @@ void notcurses_s7_init(s7_scheme *sc) nc_int(NCDIRECT_OPTION_INHIBIT_SETLOCALE); nc_int(NCDIRECT_OPTION_INHIBIT_CBREAK); + #if (defined(NOTCURSES_VERNUM_MAJOR)) + nc_int(NOTCURSES_VERNUM_MAJOR); + nc_int(NOTCURSES_VERNUM_MINOR); + nc_int(NOTCURSES_VERNUM_PATCH); /* tweak version "number" can be empty! */ + nc_int(NOTCURSES_VERNUM_ORDERED); + #endif #endif ncp_move_hook = s7_eval_c_string(sc, "(make-hook 'plane 'y 'x)"); @@ -4398,7 +4460,17 @@ void notcurses_s7_init(s7_scheme *sc) */ /* TODO: ncmenu_item(s) various callbacks palette256-chans? - * list of lists of menu items -> (permanent) c array, arg type checks + * list of lists of menu items -> (permanent) c array, arg type checks + * API void ncplane_set_resizecb(struct ncplane* n, int(*resizecb)(struct ncplane*)); -- these need wrappers + * API int (*ncplane_resizecb(const struct ncplane* n))(struct ncplane*); + * 2.1.0 + * cell -> nccell, cell_load/duplicate/release/extended_gcluster + * ncpile_top|bottom, ncplane_resize_maximize, ncplane_descendent_p? + * NCPLOT_OPTION_PRINTSAMPLE + * 2.1.1 + * ncprogbar + * 2.1.2 + * notcurses_linesigs_enable|disable */ #endif @@ -2,7 +2,7 @@ # Translator: Michael Scholz <mi-scholz@users.sourceforge.net> # Created: 05/04/09 23:55:07 -# Changed: 17/11/30 22:57:04 +# Changed: 20/11/08 00:06:07 # class Complex # to_f @@ -86,7 +86,8 @@ class Poly < Vec while self[i].zero? and i > 0 i -= 1 end - self[0, i + 1] + # FIXME: ruby3 requires to_poly + self[0, i + 1].to_poly else self end @@ -41,7 +41,7 @@ (if (null? args) (#_make-hash-table) (if (procedure? (car args)) - (#_make-hash-table (if (null? (cdr args)) (*s7 'default-hash-table-length) (cadr args)) (car args)) + (#_make-hash-table (if (null? (cdr args)) (*s7* 'default-hash-table-length) (cadr args)) (car args)) (apply #_make-hash-table args)))) (define bytevector byte-vector) @@ -402,7 +402,7 @@ (define (os-type) (car ((*libc* 'uname)))) (define (cpu-architecture) (cadr ((*libc* 'uname)))) (define (machine-name) (caddr ((*libc* 'uname)))) -(define (os-version) (string-append (list-ref ((*libc* 'uname)) 3) " " (list-ref ((*libc* 'uname)) 4))) +(define (os-version) (string-append (list-ref ((*libc* 'uname)) 3) " " (list-ref ((*libc* 'uname)) 4))) ; or perhaps use /etc/os-release (define (implementation-name) (copy "s7")) (define (implementation-version) (substring (*s7* 'version) 3 7)) @@ -51,7 +51,7 @@ * the optimizers * multiple-values, quasiquote * eval - * *s7* let + * *s7* * initialization and free * repl * @@ -206,7 +206,7 @@ #endif #ifndef WITH_C_LOADER - #if WITH_GCC && (!__MINGW32__) + #if WITH_GCC && (!__MINGW32__) && (!__CYGWIN__) #define WITH_C_LOADER 1 /* (load file.so [e]) looks for (e 'init_func) and if found, calls it * as the shared object init function. If WITH_SYSTEM_EXTRAS is 0, the caller @@ -311,6 +311,10 @@ #endif #endif +#ifndef WITH_VECTORIZE + #define WITH_VECTORIZE 1 +#endif + #if (WITH_VECTORIZE) && (defined(__GNUC__) && __GNUC__ >= 5) #define Vectorized __attribute__((optimize("tree-vectorize"))) #else @@ -428,10 +432,8 @@ typedef long double long_double; /* types */ enum {T_FREE = 0, - T_PAIR, T_NIL, T_UNUSED, T_UNDEFINED, T_UNSPECIFIED, T_EOF, - T_BOOLEAN, T_CHARACTER, T_SYNTAX, T_SYMBOL, - T_INTEGER, T_RATIO, T_REAL, T_COMPLEX, - T_BIG_INTEGER, T_BIG_RATIO, T_BIG_REAL, T_BIG_COMPLEX, + T_PAIR, T_NIL, T_UNUSED, T_UNDEFINED, T_UNSPECIFIED, T_EOF, T_BOOLEAN, T_CHARACTER, T_SYNTAX, T_SYMBOL, + T_INTEGER, T_RATIO, T_REAL, T_COMPLEX, T_BIG_INTEGER, T_BIG_RATIO, T_BIG_REAL, T_BIG_COMPLEX, T_STRING, T_C_OBJECT, T_VECTOR, T_INT_VECTOR, T_FLOAT_VECTOR, T_BYTE_VECTOR, T_CATCH, T_DYNAMIC_WIND, T_HASH_TABLE, T_LET, T_ITERATOR, T_STACK, T_COUNTER, T_SLOT, T_C_POINTER, T_OUTPUT_PORT, T_INPUT_PORT, T_RANDOM_STATE, @@ -552,8 +554,7 @@ typedef enum {o_d_v, o_d_vd, o_d_vdd, o_d_vid, o_d_id, o_d_7pi, o_d_7pii, o_d_7p o_d_ip, o_d_pd, o_d_7pid, o_d, o_d_d, o_d_dd, o_d_7dd, o_d_ddd, o_d_dddd, o_i_i, o_i_7i, o_i_ii, o_i_7ii, o_i_iii, o_i_7pi, o_i_7pii, o_i_7piii, o_d_p, o_b_p, o_b_7p, o_b_pp, o_b_7pp, o_b_pp_unchecked, o_b_pi, o_b_ii, o_b_7ii, o_b_dd, - o_p, o_p_p, o_p_ii, o_p_d, o_p_dd, o_i_7d, o_i_7p, o_d_7d, - o_p_pp, o_p_pp_unchecked, o_p_ppp, o_p_ppp_unchecked, o_p_pi, o_p_pi_unchecked, + o_p, o_p_p, o_p_ii, o_p_d, o_p_dd, o_i_7d, o_i_7p, o_d_7d, o_p_pp, o_p_ppp, o_p_pi, o_p_pi_unchecked, o_p_ppi, o_p_i, o_p_pii, o_p_pip, o_p_pip_unchecked, o_p_piip, o_b_i, o_b_d} opt_func_t; typedef struct opt_funcs_t { @@ -736,6 +737,7 @@ typedef struct bigcmp {mpc_t z; struct bigcmp *nxt;} bigcmp; typedef struct s7_cell { union { uint64_t flag; /* type info */ + int64_t signed_flag; uint8_t type_field; uint16_t sflag; struct { @@ -1095,7 +1097,7 @@ struct s7_scheme { uint32_t gc_stats, gensym_counter, f_class, add_class, multiply_class, subtract_class, num_eq_class; int32_t format_column; uint64_t capture_let_counter; - bool short_print, is_autoloading, in_with_let, object_out_locked, has_openlets, is_expanding, accept_all_keyword_arguments, got_tc, got_rec; + bool short_print, is_autoloading, in_with_let, object_out_locked, has_openlets, is_expanding, accept_all_keyword_arguments, got_tc, got_rec, not_tc; s7_int rec_tc_args; int64_t let_number; s7_double default_rationalize_error, equivalent_float_epsilon, hash_table_float_epsilon; @@ -1312,7 +1314,7 @@ struct s7_scheme { vector_ref_2, vector_ref_3, vector_set_3, vector_set_4, read_char_1, dynamic_wind_unchecked, fv_ref_2, fv_ref_3, fv_set_3, fv_set_unchecked, iv_ref_2, iv_ref_3, iv_set_3, bv_ref_2, bv_ref_3, bv_set_3, list_0, list_1, list_2, list_3, list_set_i, hash_table_ref_2, hash_table_2, list_ref_0, list_ref_1, list_ref_2, - format_f, format_allg_no_column, format_just_control_string, format_as_objstr, + format_f, format_no_column, format_just_control_string, format_as_objstr, values_uncopied, memq_2, memq_3, memq_4, memq_any, tree_set_memq_syms, simple_inlet, profile_out, lint_let_ref, lint_let_set, geq_2, add_i_random, is_defined_in_rootlet; @@ -1522,11 +1524,8 @@ static void fill_block_list(s7_scheme *sc) b = (block_t *)Malloc(BLOCK_MALLOC_SIZE * sizeof(block_t)); /* batch alloc means blocks in this batch can't be freed, only returned to the list */ add_saved_pointer(sc, b); sc->block_lists[BLOCK_LIST] = b; - for (i = 0; i < BLOCK_MALLOC_SIZE - 1; i++) - { - block_next(b) = (block_t *)(b + 1); - b++; - } + for (i = 0; i < BLOCK_MALLOC_SIZE - 1; b++, i++) + block_next(b) = (block_t *)(b + 1); block_next(b) = NULL; } @@ -1999,6 +1998,7 @@ void s7_show_history(s7_scheme *sc); #define type(p) ((p)->tf.type_field) #define set_type(p, f) typeflag(p) = f #endif +#define signed_type(p) (p)->tf.signed_flag #define is_number(P) t_number_p[type(P)] #define is_small_real(P) t_small_real_p[type(P)] @@ -2029,7 +2029,7 @@ void s7_show_history(s7_scheme *sc); #define is_mutable_sequence(P) (((t_sequence_p[type(P)]) || (has_methods(P))) && (!is_immutable(P))) #define is_mappable(P) (t_mappable_p[type(P)]) #define is_applicable(P) (t_applicable_p[type(P)]) -/* this misses #() which actually is not applicable to anything, probably "" also, and inapplicable c-objects like random-state */ +/* this misses #() which is not applicable to anything, and "", and inapplicable c-objects like random-state */ #define is_procedure(p) ((t_procedure_p[type(p)]) || ((is_c_object(p)) && (is_safe_procedure(p)))) #define is_t_procedure(p) (t_procedure_p[type(p)]) @@ -2480,6 +2480,10 @@ void s7_show_history(s7_scheme *sc); #define T_DEFINER (1 << 2) #define is_definer(p) has_type1_bit(T_Sym(p), T_DEFINER) #define set_is_definer(p) set_type1_bit(T_Sym(p), T_DEFINER) +#define is_func_definer(p) has_type1_bit(T_Fnc(p), T_DEFINER) +#define set_func_is_definer(p) do {set_type1_bit(T_Fnc(slot_value(initial_slot(p))), T_DEFINER); set_type1_bit(T_Sym(p), T_DEFINER);} while (0) +#define is_syntax_definer(p) has_type1_bit(T_Syn(p), T_DEFINER) +#define set_syntax_is_definer(p) do {set_type1_bit(T_Syn(slot_value(initial_slot(p))), T_DEFINER); set_type1_bit(T_Sym(p), T_DEFINER);} while (0) /* this marks "definers" like define and define-macro */ #define T_MACLET T_DEFINER @@ -2488,6 +2492,7 @@ void s7_show_history(s7_scheme *sc); /* this marks a maclet */ #define T_HAS_FX T_DEFINER +/* #define set_has_fx(p) do {fprintf(stderr, "%s[%d]: %s\n", __func__, __LINE__, display(p)); set_type1_bit(T_Pair(p), T_HAS_FX);} while (0) */ #define set_has_fx(p) set_type1_bit(T_Pair(p), T_HAS_FX) #define has_fx(p) has_type1_bit(T_Pair(p), T_HAS_FX) #define clear_has_fx(p) clear_type1_bit(T_Pair(p), T_HAS_FX) @@ -2571,6 +2576,10 @@ void s7_show_history(s7_scheme *sc); #define is_case_key(p) has_type1_bit(T_Pos(p), T_CASE_KEY) #define set_case_key(p) set_type1_bit(T_Sym(p), T_CASE_KEY) +#define T_NO_GX T_CASE_KEY +#define set_no_gx(p) set_type1_bit(T_Pair(p), T_NO_GX) +#define no_gx(p) has_type1_bit(T_Pair(p), T_NO_GX) + #define T_FULL_HAS_GX (1LL << (TYPE_BITS + BIT_ROOM + 34)) #define T_HAS_GX (1 << 10) #define set_has_gx(p) set_type1_bit(T_Pair(p), T_HAS_GX) @@ -2721,9 +2730,9 @@ void s7_show_history(s7_scheme *sc); #define G_DIRECT (1 << 6) /* direct call info */ #define G_ANY (1 << 29) #define G_LET (1 << 17) /* let or #f */ -/* #define G_CTR (1 << 30) */ +#define G_CON (1 << 30) #define G_BYTE 0x80000000 /* not (1LL < 31) ! */ -#define G_MASK (G_ARGLEN | G_SYM | G_AND | G_ANY | G_LET | G_BYTE | S_LOCATION | S_LEN | G_DIRECT) +#define G_MASK (G_ARGLEN | G_SYM | G_AND | G_ANY | G_LET | G_BYTE | S_LOCATION | S_LEN | G_DIRECT | G_CON) #define opt3_is_set(p) (((p)->debugger_bits & G_SET) != 0) #define set_opt3_is_set(p) (p)->debugger_bits |= G_SET @@ -2789,6 +2798,8 @@ void s7_show_history(s7_scheme *sc); #define set_opt3_arglen(P, X) set_opt3(cdr(P), T_Int(X), G_ARGLEN) #define opt3_sym(P) T_Sym(opt3(P, G_SYM)) #define set_opt3_sym(P, X) set_opt3(P, T_Sym(X), G_SYM) +#define opt3_con(P) T_Pos(opt3(P, G_CON)) +#define set_opt3_con(P, X) set_opt3(P, T_Pos(X), G_CON) #define opt3_pair(P) T_Pair(opt3(P, G_AND)) #define set_opt3_pair(P, X) set_opt3(P, T_Pair(X), G_AND) #define opt3_any(P) opt3(P, G_ANY) @@ -2913,7 +2924,7 @@ void s7_show_history(s7_scheme *sc); #define is_symbol(p) (type(p) == T_SYMBOL) #define is_normal_symbol(p) ((is_symbol(p)) && (!is_keyword(p))) -#define is_safe_symbol(p) ((is_symbol(p)) && (is_slot(symbol_to_slot(sc, p)))) +#define is_safe_symbol(p) ((is_symbol(p)) && (is_slot(lookup_slot_from(p, sc->curlet)))) #define symbol_name_cell(p) T_Str((T_Sym(p))->object.sym.name) #define symbol_set_name_cell(p, S) (T_Sym(p))->object.sym.name = T_Str(S) #define symbol_name(p) string_value(symbol_name_cell(p)) @@ -2958,7 +2969,7 @@ static void symbol_set_id(s7_pointer p, s7_int id) #define symbol_tag(p) (T_Sym(p))->object.sym.tag #define symbol_set_tag(p, Val) (T_Sym(p))->object.sym.tag = Val #define symbol_ctr(p) (T_Sym(p))->object.sym.ctr /* needs to be in the symbol object (not symbol_info) for speed */ -#define symbol_set_ctr(p, Val) (T_Sym(p))->object.sym.ctr = Val +#define symbol_clear_ctr(p) (T_Sym(p))->object.sym.ctr = 0 #define symbol_increment_ctr(p) (T_Sym(p))->object.sym.ctr++ #define symbol_tag2(p) symbol_info(p)->ln.tag #define symbol_set_tag2(p, Val) symbol_info(p)->ln.tag = Val @@ -2969,8 +2980,14 @@ static void symbol_set_id(s7_pointer p, s7_int id) #define symbol_set_position(p, Pos) symbol_info(p)->dx.pos = Pos #define PD_POSITION_UNSET -1 -#define symbol_set_local_slot_unchecked(Symbol, Id, Slot) do {(Symbol)->object.sym.local_slot = T_Sln(Slot); symbol_set_id_unchecked(Symbol, Id); symbol_increment_ctr(Symbol);} while (0) -#define symbol_set_local_slot(Symbol, Id, Slot) do {set_local_slot(Symbol, Slot); symbol_set_id(Symbol, Id); symbol_increment_ctr(Symbol);} while (0) +#define symbol_set_local_slot_unchecked(Symbol, Id, Slot) \ + do {(Symbol)->object.sym.local_slot = T_Sln(Slot); symbol_set_id_unchecked(Symbol, Id); symbol_increment_ctr(Symbol);} while (0) +#define symbol_set_local_slot_unchecked_and_unincremented(Symbol, Id, Slot) \ + do {(Symbol)->object.sym.local_slot = T_Sln(Slot); symbol_set_id_unchecked(Symbol, Id);} while (0) +#define symbol_set_local_slot(Symbol, Id, Slot) \ + do {set_local_slot(Symbol, Slot); symbol_set_id(Symbol, Id); symbol_increment_ctr(Symbol);} while (0) +#define symbol_set_local_slot_unincremented(Symbol, Id, Slot) \ + do {set_local_slot(Symbol, Slot); symbol_set_id(Symbol, Id);} while (0) /* set slot before id in case Slot is an expression that tries to find the current Symbol slot (using its old Id obviously) */ #define is_slot(p) (type(p) == T_SLOT) @@ -2986,8 +3003,10 @@ static void symbol_set_id(s7_pointer p, s7_int id) #define slot_set_pending_value(p, Val) do {(T_Slt(p))->object.slt.pending_value = T_Pos(Val); slot_set_has_pending_value(p);} while (0) #define slot_simply_set_pending_value(p, Val) (T_Slt(p))->object.slt.pending_value = T_Pos(Val) #if S7_DEBUGGING -static s7_pointer slot_pending_value(s7_pointer p) {if (slot_has_pending_value(p)) return(p->object.slt.pending_value); fprintf(stderr, "slot: no pending value\n"); abort();} -static s7_pointer slot_expression(s7_pointer p) {if (slot_has_expression(p)) return(p->object.slt.expr); fprintf(stderr, "slot: no expression\n"); abort();} +static s7_pointer slot_pending_value(s7_pointer p) \ + {if (slot_has_pending_value(p)) return(p->object.slt.pending_value); fprintf(stderr, "slot: no pending value\n"); abort();} +static s7_pointer slot_expression(s7_pointer p) \ + {if (slot_has_expression(p)) return(p->object.slt.expr); fprintf(stderr, "slot: no expression\n"); abort();} #else #define slot_pending_value(p) (T_Slt(p))->object.slt.pending_value #define slot_expression(p) (T_Slt(p))->object.slt.expr @@ -3530,10 +3549,10 @@ static s7_pointer make_permanent_integer_unchecked(s7_int i) /* g_char_to_integer assumes this is at least NUM_CHARS */ #endif #endif -static s7_pointer *small_ints = NULL; +static s7_pointer *small_ints = NULL; #define small_int(Val) small_ints[Val] -#define is_small(n) ((n & ~(NUM_SMALL_INTS - 1)) == 0) /* ((n >= 0) && (n < NUM_SMALL_INTS)) is slower */ +#define is_small_int(n) ((n & ~(NUM_SMALL_INTS - 1)) == 0) /* ((n >= 0) && (n < NUM_SMALL_INTS)) is slower */ static s7_pointer real_zero, real_NaN, complex_NaN, real_pi, real_one, arity_not_set, max_arity, real_infinity, real_minus_infinity; static s7_pointer int_zero, int_one, int_two, int_three, minus_one, minus_two, mostfix, leastfix; @@ -3676,7 +3695,7 @@ static void try_to_call_gc(s7_scheme *sc); #endif #if WITH_GCC -#define make_integer(Sc, N) ({ s7_int _N_; _N_ = (N); (is_small(_N_) ? small_int(_N_) : ({ s7_pointer _I_; new_cell(Sc, _I_, T_INTEGER); integer(_I_) = _N_; _I_;}) ); }) +#define make_integer(Sc, N) ({ s7_int _N_; _N_ = (N); (is_small_int(_N_) ? small_int(_N_) : ({ s7_pointer _I_; new_cell(Sc, _I_, T_INTEGER); integer(_I_) = _N_; _I_;}) ); }) #define make_real(Sc, X) ({ s7_pointer _R_; s7_double _N_ = (X); new_cell(Sc, _R_, T_REAL); set_real(_R_, _N_); _R_;}) @@ -3754,8 +3773,7 @@ static char *copy_string_with_length(const char *str, s7_int len) { char *newstr; #if S7_DEBUGGING - if ((len <= 0) || (!str)) - fprintf(stderr, "%s[%d]: len: %" print_s7_int ", str: %s\n", __func__, __LINE__, len, str); + if ((len <= 0) || (!str)) fprintf(stderr, "%s[%d]: len: %" print_s7_int ", str: %s\n", __func__, __LINE__, len, str); #endif if (len > (1LL << 48)) return(NULL); /* squelch an idiotic warning */ newstr = (char *)Malloc(len + 1); @@ -3818,7 +3836,7 @@ static Sentinel size_t catstrs(char *dst, size_t len, ...) /* NULL-terminated ar va_list ap; d = dst; dend = (const char *)(dst + len); - while ((*d) && (d < dend)) d++; + while ((*d) && (d < dend)) d++; /* stop at NULL or end-of-buffer */ va_start(ap, len); for (s = va_arg(ap, const char *); s != NULL; s = va_arg(ap, const char *)) while ((*s) && (d < dend)) {*d++ = *s++;} @@ -3902,7 +3920,6 @@ static s7_pointer object_to_truncated_string(s7_scheme *sc, s7_pointer p, s7_int #endif static s7_pointer cons_unchecked(s7_scheme *sc, s7_pointer a, s7_pointer b); -static s7_pointer cons_unchecked_with_type(s7_scheme *sc, s7_pointer p, s7_pointer a, s7_pointer b); static s7_pointer unbound_variable(s7_scheme *sc, s7_pointer sym); static s7_pointer find_method(s7_scheme *sc, s7_pointer let, s7_pointer symbol); static s7_pointer find_method_with_let(s7_scheme *sc, s7_pointer let, s7_pointer symbol); @@ -3950,19 +3967,14 @@ enum {OP_UNOPT, OP_GC_PROTECT, /* must be an even number of ops here, op_gc_prot OP_SAFE_C_C_opSCq, HOP_SAFE_C_C_opSCq, OP_SAFE_C_S_opSCq, HOP_SAFE_C_S_opSCq, OP_SAFE_C_S_opCSq, HOP_SAFE_C_S_opCSq, OP_SAFE_C_opSq_S, HOP_SAFE_C_opSq_S, OP_SAFE_C_opSq_C, HOP_SAFE_C_opSq_C, OP_SAFE_C_opSq_opSq, HOP_SAFE_C_opSq_opSq, OP_SAFE_C_S_opSSq, HOP_SAFE_C_S_opSSq, OP_SAFE_C_C_opSq, HOP_SAFE_C_C_opSq, - OP_SAFE_C_C_opCSq, HOP_SAFE_C_C_opCSq, OP_SAFE_C_opCSq_C, HOP_SAFE_C_opCSq_C, + OP_SAFE_C_opCSq_C, HOP_SAFE_C_opCSq_C, OP_SAFE_C_S_opDq, HOP_SAFE_C_S_opDq, OP_SAFE_C_opSSq_C, HOP_SAFE_C_opSSq_C, OP_SAFE_C_C_opSSq, HOP_SAFE_C_C_opSSq, - OP_SAFE_C_C_opDq, HOP_SAFE_C_C_opDq, OP_SAFE_C_opDq_S, HOP_SAFE_C_opDq_S, + OP_SAFE_C_C_opDq, HOP_SAFE_C_C_opDq, OP_SAFE_C_opSSq_opSSq, HOP_SAFE_C_opSSq_opSSq, OP_SAFE_C_opSSq_opSq, HOP_SAFE_C_opSSq_opSq, OP_SAFE_C_opSq_opSSq, HOP_SAFE_C_opSq_opSSq, OP_SAFE_C_opSSq_S, HOP_SAFE_C_opSSq_S, OP_SAFE_C_opCSq_S, HOP_SAFE_C_opCSq_S, OP_SAFE_C_opSCq_C, HOP_SAFE_C_opSCq_C, - OP_SAFE_C_S_op_opSq_Cq, HOP_SAFE_C_S_op_opSq_Cq, - OP_SAFE_C_S_op_S_opSSqq, HOP_SAFE_C_S_op_S_opSSqq, OP_SAFE_C_S_op_S_opSqq, HOP_SAFE_C_S_op_S_opSqq, - OP_SAFE_C_op_opSSqq_C, HOP_SAFE_C_op_opSSqq_C, OP_SAFE_C_op_opSqq_C, HOP_SAFE_C_op_opSqq_C, - OP_SAFE_C_op_opSSqq_S, HOP_SAFE_C_op_opSSqq_S, - OP_SAFE_C_S_op_opSSq_opSSqq, HOP_SAFE_C_S_op_opSSq_opSSqq, OP_SAFE_C_op_opSSq_Sq_S, HOP_SAFE_C_op_opSSq_Sq_S, - OP_SAFE_C_op_opSqq, HOP_SAFE_C_op_opSqq, OP_SAFE_C_op_opSq_Cq, HOP_SAFE_C_op_opSq_Cq, - OP_SAFE_C_op_S_opSqq, HOP_SAFE_C_op_S_opSqq, OP_SAFE_C_op_opSq_Sq, HOP_SAFE_C_op_opSq_Sq, - OP_SAFE_C_opSq_CS, HOP_SAFE_C_opSq_CS, + OP_SAFE_C_S_op_S_opSSqq, HOP_SAFE_C_S_op_S_opSSqq, + OP_SAFE_C_op_opSSqq_S, HOP_SAFE_C_op_opSSqq_S, OP_SAFE_C_op_opSqq, HOP_SAFE_C_op_opSqq, + OP_SAFE_C_op_S_opSqq, HOP_SAFE_C_op_S_opSqq, OP_SAFE_C_op_opSq_Sq, HOP_SAFE_C_op_opSq_Sq, OP_SAFE_C_opSq_CS, HOP_SAFE_C_opSq_CS, OP_SAFE_C_A, HOP_SAFE_C_A, OP_SAFE_C_AA, HOP_SAFE_C_AA, OP_SAFE_C_SA, HOP_SAFE_C_SA, OP_SAFE_C_AS, HOP_SAFE_C_AS, @@ -4070,7 +4082,7 @@ enum {OP_UNOPT, OP_GC_PROTECT, /* must be an even number of ops here, op_gc_prot OP_READ_LIST, OP_READ_NEXT, OP_READ_DOT, OP_READ_QUOTE, OP_READ_QUASIQUOTE, OP_READ_UNQUOTE, OP_READ_APPLY_VALUES, OP_READ_VECTOR, OP_READ_BYTE_VECTOR, OP_READ_INT_VECTOR, OP_READ_FLOAT_VECTOR, OP_READ_DONE, - OP_LOAD_RETURN_IF_EOF, OP_LOAD_CLOSE_AND_POP_IF_EOF, OP_EVAL_DONE, OP_EVAL_DONE_NO_MV, + OP_LOAD_RETURN_IF_EOF, OP_LOAD_CLOSE_AND_POP_IF_EOF, OP_EVAL_DONE, OP_SPLICE_VALUES, OP_CATCH, OP_DYNAMIC_WIND, OP_DYNAMIC_UNWIND, OP_DYNAMIC_UNWIND_PROFILE, OP_PROFILE_IN, OP_DEFINE_CONSTANT, OP_DEFINE_CONSTANT1, OP_DO, OP_DO_END, OP_DO_END1, OP_DO_STEP, OP_DO_STEP2, OP_DO_INIT, @@ -4121,7 +4133,6 @@ enum {OP_UNOPT, OP_GC_PROTECT, /* must be an even number of ops here, op_gc_prot OP_IF_A_C_C, OP_IF_A_A, OP_IF_A_A_A, OP_IF_S_A_A, OP_IF_AND2_S_A, OP_IF_NOT_A_A, OP_IF_NOT_A_A_A, OP_IF_A_A_P, OP_IF_A_P_A, OP_IF_S_P_A, OP_IF_IS_TYPE_S_P_A, - OP_IF_S_P, OP_IF_S_P_P, OP_IF_S_R, OP_IF_S_N, OP_IF_S_N_N, OP_IF_opSq_P, OP_IF_opSq_P_P, OP_IF_opSq_R, OP_IF_opSq_N, OP_IF_opSq_N_N, OP_IF_IS_TYPE_S_P, OP_IF_IS_TYPE_S_P_P, OP_IF_IS_TYPE_S_R, OP_IF_IS_TYPE_S_N, OP_IF_IS_TYPE_S_N_N, @@ -4138,7 +4149,7 @@ enum {OP_UNOPT, OP_GC_PROTECT, /* must be an even number of ops here, op_gc_prot OP_SIMPLE_DO, OP_SIMPLE_DO_STEP, OP_SAFE_DOTIMES, OP_SAFE_DOTIMES_STEP, OP_SAFE_DOTIMES_STEP_O, OP_SAFE_DO, OP_SAFE_DO_STEP, OP_DOX, OP_DOX_STEP, OP_DOX_STEP_O, OP_DOX_NO_BODY, OP_DOX_PENDING_NO_BODY, OP_DOX_INIT, OP_DOTIMES_P, OP_DOTIMES_STEP_O, - OP_DO_NO_VARS, OP_DO_NO_VARS_NO_OPT, OP_DO_NO_VARS_NO_OPT_1, + OP_DO_NO_VARS, OP_DO_NO_VARS_NO_OPT, OP_DO_NO_VARS_NO_OPT_1, OP_DO_NO_BODY_FX_VARS, OP_DO_NO_BODY_FX_VARS_STEP, OP_DO_NO_BODY_FX_VARS_STEP_1, OP_SAFE_C_P_1, OP_SAFE_C_PP_1, OP_SAFE_C_PP_3_MV, OP_SAFE_C_PP_5, OP_SAFE_C_PP_6_MV, @@ -4154,7 +4165,6 @@ enum {OP_UNOPT, OP_GC_PROTECT, /* must be an even number of ops here, op_gc_prot OP_SAFE_C_PA_1, OP_SAFE_C_PA_MV, OP_ANY_CLOSURE_FP_2, OP_ANY_CLOSURE_3P_1, OP_ANY_CLOSURE_3P_2, OP_ANY_CLOSURE_3P_3, OP_ANY_CLOSURE_4P_1, OP_ANY_CLOSURE_4P_2, OP_ANY_CLOSURE_4P_3, OP_ANY_CLOSURE_4P_4, - OP_SET_WITH_LET_1, OP_SET_WITH_LET_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_OR_A_A_AND_A_A_LA, @@ -4163,8 +4173,8 @@ enum {OP_UNOPT, OP_GC_PROTECT, /* must be an even number of ops here, op_gc_prot OP_TC_COND_A_Z_A_Z_LAA, OP_TC_COND_A_Z_A_LAA_Z, OP_TC_COND_A_Z_A_LAA_LAA, OP_TC_LET_COND, OP_TC_IF_A_Z_LA, OP_TC_IF_A_Z_LAA, OP_TC_IF_A_Z_L3A, OP_TC_IF_A_L3A_Z, OP_TC_IF_A_LA_Z, OP_TC_IF_A_LAA_Z, OP_TC_IF_A_Z_IF_A_Z_LA, OP_TC_IF_A_Z_IF_A_LA_Z, OP_TC_IF_A_Z_IF_A_Z_LAA, OP_TC_IF_A_Z_IF_A_LAA_Z, OP_TC_IF_A_Z_IF_A_L3A_L3A, - OP_TC_COND_A_Z_A_Z_LA, OP_TC_COND_A_Z_A_LA_Z, - OP_TC_LET_IF_A_Z_LAA, OP_TC_IF_A_Z_LET_IF_A_Z_LAA, + OP_TC_COND_A_Z_A_Z_LA, OP_TC_COND_A_Z_A_LA_Z, OP_TC_COND_A_Z_LA, OP_TC_COND_A_LA_Z, OP_TC_COND_A_Z_LAA, OP_TC_COND_A_LAA_Z, + OP_TC_LET_IF_A_Z_LA, OP_TC_LET_IF_A_Z_LAA, OP_TC_IF_A_Z_LET_IF_A_Z_LAA, OP_TC_CASE_LA, OP_TC_AND_A_IF_A_Z_LA, OP_TC_AND_A_IF_A_LA_Z, OP_RECUR_IF_A_A_opA_LAq, OP_RECUR_IF_A_opA_LAq_A, OP_RECUR_IF_A_A_opLA_Aq, OP_RECUR_IF_A_opLA_Aq_A, @@ -4174,10 +4184,10 @@ enum {OP_UNOPT, OP_GC_PROTECT, /* must be an even number of ops here, op_gc_prot OP_RECUR_IF_A_A_opA_LAAq, OP_RECUR_IF_A_opA_LAAq_A, OP_RECUR_IF_A_A_opA_L3Aq, OP_RECUR_IF_A_A_LopL3A_L3A_L3Aq, OP_RECUR_IF_A_A_AND_A_LAA_LAA, OP_RECUR_IF_A_A_IF_A_LAA_opA_LAAq, /* same as cond case below */ - OP_RECUR_COND_A_A_opA_LAq, OP_RECUR_COND_A_A_opA_LAAq, OP_RECUR_COND_A_A_A_A_opLA_LAq, OP_RECUR_COND_A_A_A_A_opLAA_LAAq, OP_RECUR_COND_A_A_A_A_opA_LAAq, OP_RECUR_COND_A_A_A_LAA_LopA_LAAq, OP_RECUR_COND_A_A_A_LAA_opA_LAAq, + OP_RECUR_AND_A_OR_A_LAA_LAA, NUM_OPS}; @@ -4199,19 +4209,14 @@ static const char* op_names[NUM_OPS] = "safe_c_c_opscq", "h_safe_c_c_opscq", "safe_c_s_opscq", "h_safe_c_s_opscq", "safe_c_s_opcsq", "h_safe_c_s_opcsq", "safe_c_opsq_s", "h_safe_c_opsq_s", "safe_c_opsq_c", "h_safe_c_opsq_c", "safe_c_opsq_opsq", "h_safe_c_opsq_opsq", "safe_c_s_opssq", "h_safe_c_s_opssq", "safe_c_c_opsq", "h_safe_c_c_opsq", - "safe_c_c_opcsq", "h_safe_c_c_opcsq", "safe_c_opcsq_c", "h_safe_c_opcsq_c", + "safe_c_opcsq_c", "h_safe_c_opcsq_c", "safe_c_s_opdq", "h_safe_c_s_opdq", "safe_c_opssq_c", "h_safe_c_opssq_c", "safe_c_c_opssq", "h_safe_c_c_opssq", - "safe_c_c_opdq", "h_safe_c_c_opdq", "safe_c_opdq_s", "h_safe_c_opdq_s", + "safe_c_c_opdq", "h_safe_c_c_opdq", "safe_c_opssq_opssq", "h_safe_c_opssq_opssq", "safe_c_opssq_opsq", "h_safe_c_opssq_opsq", "safe_c_opsq_opssq", "h_safe_c_opsq_opssq", "safe_c_opssq_s", "h_safe_c_opssq_s", "safe_c_opcsq_s", "h_safe_c_opcsq_s", "safe_c_opscq_c", "h_safe_c_opscq_c", - "safe_c_s_op_opsq_cq", "h_safe_c_s_op_opsq_cq", - "safe_c_s_op_s_opssqq", "h_safe_c_s_op_s_opssqq", "safe_c_s_op_s_opsqq", "h_safe_c_s_op_s_opsqq", - "safe_c_op_opssqq_c", "h_safe_c_op_opssqq_c", "safe_c_op_opsqq_c", "h_safe_c_op_opsqq_c", - "safe_c_op_opssqq_s", "h_safe_c_op_opssqq_s", - "safe_c_s_op_opssq_opssqq", "h_safe_c_s_op_opssq_opssqq", "safe_c_opssq_sq_s", "h_safe_c_opssq_sq_s", - "safe_c_op_opsqq", "h_safe_c_op_opsqq", "safe_c_op_opsq_cq", "h_safe_c_op_opsq_cq", - "safe_c_op_s_opsqq", "h_safe_c_op_s_opsqq", "safe_c_op_opsq_sq", "h_safe_c_op_opsq_sq", - "safe_c_opsq_cs", "h_safe_c_opsq_cs", + "safe_c_s_op_s_opssqq", "h_safe_c_s_op_s_opssqq", + "safe_c_op_opssqq_s", "h_safe_c_op_opssqq_s", "safe_c_op_opsqq", "h_safe_c_op_opsqq", + "safe_c_op_s_opsqq", "h_safe_c_op_s_opsqq", "safe_c_op_opsq_sq", "h_safe_c_op_opsq_sq", "safe_c_opsq_cs", "h_safe_c_opsq_cs", "safe_c_a", "h_safe_c_a", "safe_c_aa", "h_safe_c_aa", "safe_c_sa", "h_safe_c_sa", "safe_c_as", "h_safe_c_as", @@ -4285,7 +4290,7 @@ static const char* op_names[NUM_OPS] = "safe_c_ps", "h_safe_c_ps", "safe_c_pc", "h_safe_c_pc", "safe_c_ssp", "h_safe_c_ssp", "any_c_fp", "h_any_c_fp", - "apply_ss", "apply_sa", "apply_sl", "safe_ifa_ss_a", "safe_ifa_ss_aa", + "apply_ss", "apply_sa", "apply_sl", "pif_a_ssq_a", "pif_a_ssq_a_a", "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_s", "s_c", "s_a", "c_fa_1", "s_aa", @@ -4316,7 +4321,7 @@ static const char* op_names[NUM_OPS] = "case", "read_list", "read_next", "read_dot", "read_quote", "read_quasiquote", "read_unquote", "read_apply_values", "read_vector", "read_byte_vector", "read_int_vector", "read_float_vector", "read_done", - "load_return_if_eof", "load_close_and_pop_if_eof", "eval_done", "eval_done_no_mv", + "load_return_if_eof", "load_close_and_pop_if_eof", "eval_done", "splice_values", "catch", "dynamic_wind", "dynamic_unwind", "dynamic_unwind_profile", "profile_in", "define_constant", "define_constant1", "do", "do_end", "do_end1", "do_step", "do_step2", "do_init", @@ -4365,7 +4370,6 @@ static const char* op_names[NUM_OPS] = "if_a_c_c", "if_a_a", "if_a_a_a", "if_s_a_a", "if_and2_s_a", "if_not_a_a", "if_not_a_a_a", "if_a_a_p", "if_a_p_a", "if_s_p_a", "if_is_type_s_p_a", - "if_s_p", "if_s_p_p", "if_s_r", "if_s_n", "if_s_n_n", "if_opsq_p", "if_opsq_p_p", "if_opsq_r", "if_opsq_n", "if_opsq_n_n", "if_is_type_s_p", "if_is_type_s_p_p", "if_is_type_s_r", "if_is_type_s_n", "if_is_type_s_n_n", @@ -4382,7 +4386,7 @@ static const char* op_names[NUM_OPS] = "simple_do", "simple_do_step", "safe_dotimes", "safe_dotimes_step", "safe_dotimes_step_o", "safe_do", "safe_do_step", "dox", "dox_step", "dox_step_o", "dox_no_body", "dox_pending_no_body", "dox_init", "dotimes_p", "dotimes_step_o", - "do_no_vars", "do_no_vars_no_opt", "do_no_vars_no_opt_1", + "do_no_vars", "do_no_vars_no_opt", "do_no_vars_no_opt_1", "do_no_body_fx_vars", "do_no_body_fx_vars_step", "do_no_body_fx_vars_step_1", "safe_c_p_1", "safe_c_pp_1", "safe_c_pp_3_mv", "safe_c_pp_5", "safe_c_pp_6_mv", @@ -4406,8 +4410,8 @@ static const char* op_names[NUM_OPS] = "tc_cond_a_z_a_z_laa", "tc_cond_a_z_a_laa_z", "tc_cond_a_z_a_laa_laa", "tc_let_cond", "tc_if_a_z_la", "tc_if_a_z_laa", "tc_if_a_z_l3a", "tc_if_a_l3a_z", "tc_if_a_la_z", "tc_if_a_laa_z", "tc_if_a_z_if_a_z_la", "tc_if_a_z_if_a_la_z", "tc_if_a_z_if_a_z_laa", "tc_if_a_z_if_a_laa_z", "tc_if_a_z_if_a_l3a_l3a", - "tc_cond_a_z_a_z_la", "tc_cond_a_z_a_la_z", - "tc_let_if_a_z_laa", "if_a_z_let_if_a_z_laa", + "tc_cond_a_z_a_z_la", "tc_cond_a_z_a_la_z", "tc_cond_a_z_la", "tc_cond_a_la_z", "tc_cond_a_z_laa", "tc_cond_a_laa_z", + "tc_let_if_a_z_la", "tc_let_if_a_z_laa", "if_a_z_let_if_a_z_laa", "tc_case_la", "tc_and_a_if_a_z_la", "tc_and_a_if_a_la_z", "recur_if_a_a_opa_laq", "recur_if_a_opa_laq_a", "recur_if_a_a_opla_aq", "recur_if_a_opla_aq_a", @@ -4417,10 +4421,10 @@ static const char* op_names[NUM_OPS] = "recur_if_a_a_opa_laaq", "recur_if_a_opa_laaq_a", "recur_if_a_a_opa_l3aq", "recur_if_a_a_lopl3a_l3a_l3aq", "recur_if_a_a_and_a_laa_laa", "recur_if_a_a_if_a_laa_opa_laaq", - "recur_cond_a_a_op_a_laq", "recur_cond_a_a_op_a_laaq", "recur_cond_a_a_a_a_opla_laq", "recur_cond_a_a_a_a_oplaa_laaq", "recur_cond_a_a_a_a_opa_laaq", "recur_cond_a_a_a_laa_lopa_laaq", "recur_cond_a_a_a_laa_opa_laaq", + "recur_and_a_or_a_laa_laa", }; #define is_safe_c_op(op) ((op >= OP_SAFE_C_D) && (op < OP_THUNK)) @@ -4501,10 +4505,9 @@ void s7_show_let(s7_scheme *sc) /* debugging convenience */ if (is_funclet(olet)) fprintf(stderr, "(%s funclet): ", display(funclet_function(olet))); else - { - if (olet == sc->shadow_rootlet) - fprintf(stderr, "(shadow rootlet): "); - }} + if (olet == sc->shadow_rootlet) + fprintf(stderr, "(shadow rootlet): "); + } fprintf(stderr, "%s\n", display(olet)); } } @@ -4649,7 +4652,7 @@ static char *describe_type_bits(s7_scheme *sc, s7_pointer obj) /* used outside S ((is_slot(obj)) ? " safe-stepper" : ((is_c_function(obj)) ? " maybe-safe" : ((is_number(obj)) ? " print-name" : - ((is_pair(obj)) ? " direct_opt" : + ((is_pair(obj)) ? " direct-opt" : ((is_hash_table(obj)) ? " weak-hash" : ((is_any_macro(obj)) ? " pair-macro-set" : " ?19?"))))))) : "", @@ -4694,7 +4697,9 @@ static char *describe_type_bits(s7_scheme *sc, s7_pointer obj) /* used outside S ((is_iterator(obj)) ? " weak-hash-iterator" : ((is_hash_table(obj)) ? " has-key-type" : ((is_let(obj)) ? " maclet" : - " ?26?")))))) : "", + ((is_c_function(obj)) ? " func-definer" : + ((is_syntax(obj)) ? " syntax-definer" : + " ?26?")))))))) : "", /* bit 27+16 */ ((full_typ & T_FULL_BINDER) != 0) ? ((is_pair(obj)) ? " tree-collected" : ((is_hash_table(obj)) ? " simple-values" : @@ -4719,18 +4724,13 @@ static char *describe_type_bits(s7_scheme *sc, s7_pointer obj) /* used outside S " 32?"))))) : "", /* bit 33+16 */ ((full_typ & T_FULL_CASE_KEY) != 0) ? ((is_symbol(obj)) ? " case-key" : " ?33?") : "", - /* bit 34+16 */ ((full_typ & T_FULL_HAS_GX) != 0) ? ((is_pair(obj)) ? " has-gx" : " ?34?") : "", - /* bit 35+16 */ ((full_typ & T_FULL_UNKNOPT) != 0) ? ((is_pair(obj)) ? " unknopt" : " ?35?") : "", - /* bit 36+16 */ ((full_typ & T_FULL_SAFETY_CHECKED) != 0) ? ((is_pair(obj)) ? " safety-checked" : " ?36?") : "", - ((full_typ & UNUSED_BITS) != 0) ? " unused bits set?" : "", - /* bit 54 */ ((full_typ & T_UNHEAP) != 0) ? " unheap" : "", /* bit 55 */ @@ -4770,7 +4770,9 @@ static bool has_odd_bits(s7_pointer obj) if (((full_typ & T_FULL_HAS_GX) != 0) && (!is_pair(obj)) && (!is_any_closure(obj))) return(true); if (((full_typ & T_DONT_EVAL_ARGS) != 0) && (!is_any_macro(obj)) && (!is_syntax(obj))) return(true); if (((full_typ & T_FULL_DEFINER) != 0) && - (!is_normal_symbol(obj)) && (!is_pair(obj)) && (!is_slot(obj)) && (!is_iterator(obj)) && (!is_hash_table(obj)) && (!is_let(obj))) return(true); + (!is_normal_symbol(obj)) && (!is_c_function(obj)) && (!is_pair(obj)) && (!is_slot(obj)) && (!is_iterator(obj)) && + (!is_hash_table(obj)) && (!is_let(obj)) && (!is_syntax(obj))) + return(true); if (((full_typ & T_FULL_HAS_LET_FILE) != 0) && (!is_let(obj)) && (!is_any_vector(obj)) && (!is_hash_table(obj)) && (!is_c_function(obj)) && (!is_slot(obj)) && (!is_pair(obj)) && (!is_closure_star(obj))) return(true); @@ -4804,6 +4806,8 @@ static bool has_odd_bits(s7_pointer obj) if ((symbol_type(obj) & ~0xffff) != 0) return(true); } + + if ((signed_type(obj) == 0) && ((full_typ & T_GC_MARK) != 0)) return(true); return(false); } @@ -4861,13 +4865,12 @@ static s7_pointer check_ref(s7_pointer p, uint8_t expected_type, const char *fun if (cur_sc->stop_at_error) abort(); } else - { - if ((strcmp(func, func1) != 0) && - ((!func2) || (strcmp(func, func2) != 0))) - { - fprintf(stderr, "%s%s[%d]: free cell, not %s%s\n", BOLD_TEXT, func, line, check_name(cur_sc, expected_type), UNBOLD_TEXT); - if (cur_sc->stop_at_error) abort(); - }}}} + if ((strcmp(func, func1) != 0) && + ((!func2) || (strcmp(func, func2) != 0))) + { + fprintf(stderr, "%s%s[%d]: free cell, not %s%s\n", BOLD_TEXT, func, line, check_name(cur_sc, expected_type), UNBOLD_TEXT); + if (cur_sc->stop_at_error) abort(); + }}} return(p); } @@ -5146,6 +5149,7 @@ static const char *opt3_role_name(uint32_t role) { if (role == G_ARGLEN) return("opt3_arglen"); if (role == G_SYM) return("opt3_sym"); + if (role == G_CON) return("opt3_con"); if (role == G_AND) return("opt3_pair"); if (role == G_ANY) return("opt3_any"); if (role == G_LET) return("opt3_let"); @@ -5160,37 +5164,38 @@ static char* show_debugger_bits(int64_t bits) { char *bits_str; bits_str = (char *)Malloc(512); - snprintf(bits_str, 512, " %s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s", - ((bits & E_SET) != 0) ? " e-set" : "", - ((bits & E_FAST) != 0) ? " opt1_fast" : "", - ((bits & E_CFUNC) != 0) ? " opt1_cfunc" : "", - ((bits & E_CLAUSE) != 0) ? " opt1_clause" : "", - ((bits & E_LAMBDA) != 0) ? " opt_lambda" : "", - ((bits & E_SYM) != 0) ? " opt1_sym" : "", - ((bits & E_PAIR) != 0) ? " opt1_pair" : "", - ((bits & E_CON) != 0) ? " opt1_con" : "", - ((bits & E_GOTO) != 0) ? " opt1_goto" : "", - ((bits & E_ANY) != 0) ? " opt1_any" : "", - ((bits & F_SET) != 0) ? " f-set" : "", - ((bits & F_KEY) != 0) ? " opt2_any" : "", - ((bits & F_SLOW) != 0) ? " opt2_slow" : "", - ((bits & F_SYM) != 0) ? " opt2_sym" : "", - ((bits & F_PAIR) != 0) ? " opt2_pair" : "", - ((bits & F_CON) != 0) ? " opt2_con" : "", - ((bits & F_CALL) != 0) ? " c_call(ee)" : "", - ((bits & F_LAMBDA) != 0) ? " opt2_lambda" : "", - ((bits & G_SET) != 0) ? " g-set" : "", - ((bits & G_ARGLEN) != 0) ? " opt3_arglen" : "", - ((bits & G_SYM) != 0) ? " opt3_sym" : "", - ((bits & G_AND) != 0) ? " opt3_pair " : "", - ((bits & G_ANY) != 0) ? " opt3_any " : "", - ((bits & G_LET) != 0) ? " opt3_let " : "", - ((bits & G_BYTE) != 0) ? " opt3_byte " : "", - ((bits & G_DIRECT) != 0) ? " opt3_direct" : "", - ((bits & S_NAME) != 0) ? " raw-name" : "", - ((bits & S_HASH) != 0) ? " raw-hash" : "", - ((bits & S_LOCATION) != 0) ? " location" : "", - ((bits & S_LEN) != 0) ? " len" : ""); + snprintf(bits_str, 512, " %s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s", + ((bits & E_SET) != 0) ? " e_set" : "", + ((bits & E_FAST) != 0) ? " opt1_fast" : "", + ((bits & E_CFUNC) != 0) ? " opt1_cfunc" : "", + ((bits & E_CLAUSE) != 0) ? " opt1_clause" : "", + ((bits & E_LAMBDA) != 0) ? " opt_lambda" : "", + ((bits & E_SYM) != 0) ? " opt1_sym" : "", + ((bits & E_PAIR) != 0) ? " opt1_pair" : "", + ((bits & E_CON) != 0) ? " opt1_con" : "", + ((bits & E_GOTO) != 0) ? " opt1_goto" : "", + ((bits & E_ANY) != 0) ? " opt1_any" : "", + ((bits & F_SET) != 0) ? " f_set" : "", + ((bits & F_KEY) != 0) ? " opt2_any" : "", + ((bits & F_SLOW) != 0) ? " opt2_slow" : "", + ((bits & F_SYM) != 0) ? " opt2_sym" : "", + ((bits & F_PAIR) != 0) ? " opt2_pair" : "", + ((bits & F_CON) != 0) ? " opt2_con" : "", + ((bits & F_CALL) != 0) ? " c_call(ee)" : "", + ((bits & F_LAMBDA) != 0) ? " opt2_lambda" : "", + ((bits & G_SET) != 0) ? " g_set" : "", + ((bits & G_ARGLEN) != 0) ? " opt3_arglen" : "", + ((bits & G_SYM) != 0) ? " opt3_sym" : "", + ((bits & G_CON) != 0) ? " opt3_con" : "", + ((bits & G_AND) != 0) ? " opt3_pair " : "", + ((bits & G_ANY) != 0) ? " opt3_any " : "", + ((bits & G_LET) != 0) ? " opt3_let " : "", + ((bits & G_BYTE) != 0) ? " opt3_byte " : "", + ((bits & G_DIRECT) != 0) ? " opt3_direct" : "", + ((bits & S_NAME) != 0) ? " raw_name" : "", + ((bits & S_HASH) != 0) ? " raw_hash" : "", + ((bits & S_LOCATION) != 0) ? " location" : "", + ((bits & S_LEN) != 0) ? " len" : ""); return(bits_str); } @@ -5592,6 +5597,21 @@ static s7_pointer set_clist_1(s7_scheme *sc, s7_pointer x1) /* for c_object leng return(sc->clist_1); } +#if 0 +#define set_ulist_1(Sc, X1, X2) set_ulist_1_1(Sc, X1, X2, __func__, __LINE__) +static s7_pointer set_ulist_1_1(s7_scheme *sc, s7_pointer x1, s7_pointer x2, const char *func, int line) +#else +static s7_pointer set_ulist_1(s7_scheme *sc, s7_pointer x1, s7_pointer x2) +#endif +{ +#if 0 + fprintf(stderr, "%s[%d]: %s\n", func, line, display(x1)); +#endif + set_car(sc->u1_1, x1); + set_cdr(sc->u1_1, x2); + return(sc->u1_1); +} + static int32_t position_of(s7_pointer p, s7_pointer args) { int32_t i; @@ -5609,38 +5629,20 @@ s7_pointer s7_method(s7_scheme *sc, s7_pointer obj, s7_pointer method) } /* if a method is shadowing a built-in like abs, it should expect the same args as abs and behave the same -- no multiple values etc. */ -static inline s7_pointer copy_proper_list(s7_scheme *sc, s7_pointer lst); - #define check_method(Sc, Obj, Method, Args) \ { \ s7_pointer func; \ - if ((has_active_methods(sc, Obj)) && \ - ((func = find_method_with_let(Sc, Obj, Method)) != Sc->undefined)) \ - return(call_method(Sc, Obj, func, copy_proper_list(Sc, Args))); \ - } - -#define check_method_uncopied(Sc, Obj, Method, Args) \ - { \ - s7_pointer func; \ - if ((has_active_methods(sc, Obj)) && \ + if ((has_active_methods(Sc, Obj)) && \ ((func = find_method_with_let(Sc, Obj, Method)) != Sc->undefined)) \ return(call_method(Sc, Obj, func, Args)); \ } -#define check_method_unstacking(Sc, Obj, Method, Args) \ - { \ - s7_pointer func; \ - if ((has_active_methods(sc, Obj)) && \ - ((func = find_method_with_let(Sc, Obj, Method)) != Sc->undefined)) \ - {unstack(Sc); return(call_method(Sc, Obj, func, copy_proper_list(Sc, Args)));} \ - } - static s7_pointer apply_boolean_method(s7_scheme *sc, s7_pointer obj, s7_pointer method) { s7_pointer func; func = find_method_with_let(sc, obj, method); if (func == sc->undefined) return(sc->F); - return(call_method(sc, obj, func, list_1(sc, obj))); + return(call_method(sc, obj, func, set_plist_1(sc, obj))); } static s7_pointer missing_method_error(s7_scheme *sc, s7_pointer method, s7_pointer obj) @@ -5653,7 +5655,7 @@ static s7_pointer missing_method_error(s7_scheme *sc, s7_pointer method, s7_poin s7_pointer p; \ p = car(Args); \ if (Checker(p)) return(Sc->T); \ - if (!has_active_methods(sc, p)) return(Sc->F); \ + if (!has_active_methods(Sc, p)) return(Sc->F); \ return(apply_boolean_method(Sc, p, Method)); \ } @@ -5673,6 +5675,27 @@ static s7_pointer method_or_bust(s7_scheme *sc, s7_pointer obj, s7_pointer metho return(wrong_type_argument(sc, method, num, obj, typ)); } +static s7_pointer method_or_bust_p(s7_scheme *sc, s7_pointer obj, s7_pointer method, uint8_t typ) +{ + if (has_active_methods(sc, obj)) + return(find_and_apply_method(sc, obj, method, set_plist_1(sc, obj))); + return(wrong_type_argument(sc, method, 1, obj, typ)); +} + +static s7_pointer method_or_bust_pp(s7_scheme *sc, s7_pointer obj, s7_pointer method, s7_pointer x1, s7_pointer x2, uint8_t typ, int32_t num) +{ + if (has_active_methods(sc, obj)) + return(find_and_apply_method(sc, obj, method, set_plist_2(sc, x1, x2))); + return(wrong_type_argument(sc, method, num, obj, typ)); +} + +static s7_pointer method_or_bust_ppp(s7_scheme *sc, s7_pointer obj, s7_pointer method, s7_pointer x1, s7_pointer x2, s7_pointer x3, uint8_t typ, int32_t num) +{ + if (has_active_methods(sc, obj)) + return(find_and_apply_method(sc, obj, method, set_plist_3(sc, x1, x2, x3))); + return(wrong_type_argument(sc, method, num, obj, typ)); +} + static s7_pointer immutable_object_error(s7_scheme *sc, s7_pointer info) {return(s7_error(sc, sc->immutable_error_symbol, info));} static s7_pointer mutable_method_or_bust(s7_scheme *sc, s7_pointer obj, s7_pointer method, s7_pointer args, uint8_t typ, int32_t num) @@ -5686,6 +5709,11 @@ static s7_pointer mutable_method_or_bust(s7_scheme *sc, s7_pointer obj, s7_point return(wrong_type_argument(sc, method, num, obj, typ)); } +static s7_pointer mutable_method_or_bust_ppp(s7_scheme *sc, s7_pointer obj, s7_pointer method, s7_pointer x1, s7_pointer x2, s7_pointer x3, uint8_t typ, int32_t num) +{ + return(mutable_method_or_bust(sc, obj, method, set_plist_3(sc, x1, x2, x3), typ, num)); +} + static s7_pointer method_or_bust_one_arg(s7_scheme *sc, s7_pointer obj, s7_pointer method, s7_pointer args, uint8_t typ) { if (has_active_methods(sc, obj)) @@ -5693,6 +5721,13 @@ static s7_pointer method_or_bust_one_arg(s7_scheme *sc, s7_pointer obj, s7_point return(simple_wrong_type_argument(sc, method, obj, typ)); } +static s7_pointer method_or_bust_one_arg_p(s7_scheme *sc, s7_pointer obj, s7_pointer method, uint8_t typ) +{ + if (has_active_methods(sc, obj)) + return(find_and_apply_method(sc, obj, method, set_plist_1(sc, obj))); + return(simple_wrong_type_argument(sc, method, obj, typ)); +} + static s7_pointer method_or_bust_with_type(s7_scheme *sc, s7_pointer obj, s7_pointer method, s7_pointer args, s7_pointer typ, int32_t num) { if (has_active_methods(sc, obj)) @@ -5700,6 +5735,27 @@ static s7_pointer method_or_bust_with_type(s7_scheme *sc, s7_pointer obj, s7_poi return(wrong_type_argument_with_type(sc, method, num, obj, typ)); } +static s7_pointer method_or_bust_with_type_pp(s7_scheme *sc, s7_pointer obj, s7_pointer method, s7_pointer x1, s7_pointer x2, s7_pointer typ, int32_t num) +{ + if (has_active_methods(sc, obj)) + return(find_and_apply_method(sc, obj, method, set_plist_2(sc, x1, x2))); + return(wrong_type_argument_with_type(sc, method, num, obj, typ)); +} + +static s7_pointer method_or_bust_with_type_pi(s7_scheme *sc, s7_pointer obj, s7_pointer method, s7_pointer x1, s7_int x2, s7_pointer typ) +{ + if (has_active_methods(sc, obj)) + return(find_and_apply_method(sc, obj, method, set_plist_2(sc, x1, make_integer(sc, x2)))); + return(wrong_type_argument_with_type(sc, method, 1, obj, typ)); +} + +static s7_pointer method_or_bust_with_type_pf(s7_scheme *sc, s7_pointer obj, s7_pointer method, s7_pointer x1, s7_double x2, s7_pointer typ) +{ + if (has_active_methods(sc, obj)) + return(find_and_apply_method(sc, obj, method, set_plist_2(sc, x1, make_real(sc, x2)))); + return(wrong_type_argument_with_type(sc, method, 1, obj, typ)); +} + static s7_pointer method_or_bust_with_type_one_arg(s7_scheme *sc, s7_pointer obj, s7_pointer method, s7_pointer args, s7_pointer typ) { if (has_active_methods(sc, obj)) @@ -5707,6 +5763,13 @@ static s7_pointer method_or_bust_with_type_one_arg(s7_scheme *sc, s7_pointer obj return(simple_wrong_type_argument_with_type(sc, method, obj, typ)); } +static s7_pointer method_or_bust_with_type_one_arg_p(s7_scheme *sc, s7_pointer obj, s7_pointer method, s7_pointer typ) +{ + if (has_active_methods(sc, obj)) + return(find_and_apply_method(sc, obj, method, set_plist_1(sc, obj))); + return(simple_wrong_type_argument_with_type(sc, method, obj, typ)); +} + #define eval_error_any(Sc, ErrType, ErrMsg, Len, Obj) s7_error(Sc, ErrType, set_elist_2(Sc, wrap_string(Sc, ErrMsg, Len), Obj)) #define eval_error(Sc, ErrMsg, Len, Obj) eval_error_any(Sc, Sc->syntax_error_symbol, ErrMsg, Len, Obj) #define eval_error_with_caller(Sc, ErrMsg, Len, Caller, Obj) s7_error(Sc, Sc->syntax_error_symbol, set_elist_3(Sc, wrap_string(Sc, ErrMsg, Len), Caller, Obj)) @@ -5785,7 +5848,8 @@ static s7_pointer g_is_boolean(s7_scheme *sc, s7_pointer args) /* -------------------------------- constant? -------------------------------- */ -static inline s7_pointer symbol_to_slot(s7_scheme *sc, s7_pointer symbol); + +static inline s7_pointer lookup_slot_from(s7_pointer symbol, s7_pointer e); static inline bool is_constant_symbol(s7_scheme *sc, s7_pointer sym) { @@ -5794,7 +5858,7 @@ static inline bool is_constant_symbol(s7_scheme *sc, s7_pointer sym) if (is_possibly_constant(sym)) { s7_pointer slot; - slot = symbol_to_slot(sc, sym); + slot = lookup_slot_from(sym, sc->curlet); return((is_slot(slot)) && (is_immutable_slot(slot))); } return(false); @@ -5824,7 +5888,7 @@ static s7_pointer g_is_immutable(s7_scheme *sc, s7_pointer args) if (is_symbol(p)) { s7_pointer slot; - slot = symbol_to_slot(sc, p); + slot = lookup_slot_from(p, sc->curlet); if ((is_slot(slot)) && (is_immutable_slot(slot))) return(sc->T); } if (is_number(p)) return(sc->T); @@ -5848,7 +5912,7 @@ static s7_pointer g_immutable(s7_scheme *sc, s7_pointer args) if (is_symbol(p)) { s7_pointer slot; - slot = symbol_to_slot(sc, p); + slot = lookup_slot_from(p, sc->curlet); if (is_slot(slot)) { set_immutable(slot); @@ -6062,10 +6126,9 @@ static void process_input_port(s7_scheme *sc, s7_pointer s1) port_file(s1) = NULL; }} else - { - if (is_function_port(s1)) - close_input_function(sc, s1); - }} + if (is_function_port(s1)) + close_input_function(sc, s1); + } if (port_needs_free(s1)) free_port_data(sc, s1); @@ -6460,10 +6523,8 @@ static void gc_owlet_mark(s7_pointer tp) gc_mark(p); } else - { - if (!is_marked(tp)) - (*mark_function[unchecked_type(tp)])(tp); - } + if (!is_marked(tp)) + (*mark_function[unchecked_type(tp)])(tp); } #endif @@ -6812,8 +6873,7 @@ static void mark_rootlet(s7_scheme *sc) /* we're not marking slot_symbol above which makes me worry that a top-level gensym won't be protected * (apply define (gensym) '(32)), then try to get the GC to clobber {gensym}-0, * but I can't get it to break, so they must be protected somehow; apparently they are - * removed from the heap! At least: - * (define-macro (defit) (let ((n (gensym))) `(define (,n) (format #t "fun")))) (defit) + * removed from the heap! At least: (define-macro (defit) (let ((n (gensym))) `(define (,n) (format #t "fun")))) (defit) * removes the function from the heap (protecting the gensym). */ } @@ -6854,10 +6914,8 @@ static void unmark_permanent_objects(s7_scheme *sc) if (unchecked_type(g->p) == T_FREE) fprintf(stderr, "permanent let %p is free\n", g->p); else - { - if ((is_let(g->p)) && (unchecked_type(g->p->object.envr.nxt) == T_FREE)) - fprintf(stderr, "permanent outlet %p is free\n", g->p->object.envr.nxt); - } + if ((is_let(g->p)) && (unchecked_type(g->p->object.envr.nxt) == T_FREE)) + fprintf(stderr, "permanent outlet %p is free\n", g->p->object.envr.nxt); #endif /* used to clear_mark the history lists here */ } @@ -6880,10 +6938,8 @@ static void mark_lamlets(s7_scheme *sc) s7_pointer slot; slot = let_slots(lt); if (is_closure(slot_value(slot))) - { - for (slot = let_slots(closure_let(slot_value(slot))); tis_slot(slot); slot = next_slot(slot)) - slot_set_value(slot, sc->F); - } + for (slot = let_slots(closure_let(slot_value(slot))); tis_slot(slot); slot = next_slot(slot)) + slot_set_value(slot, sc->F); clear_slots_set(lt); } gc_mark(lt); @@ -7051,20 +7107,23 @@ static int64_t gc(s7_scheme *sc) #if S7_DEBUGGING #define gc_call(Tp) \ p = (*Tp++); \ - if (is_marked(T_Any(p))) \ - clear_mark(p); \ - else \ - { \ - if (!is_free_and_clear(p)) \ - { \ - p->debugger_bits = 0; p->gc_func = func; p->gc_line = line; \ - if (has_odd_bits(p)) \ - {char *s; fprintf(stderr, "odd bits: %s\n", s = describe_type_bits(sc, p)); free(s);} \ - clear_type(p); \ - (*fp++) = p; \ - }} + if (signed_type(p) > 0) \ + { \ + p->debugger_bits = 0; p->gc_func = func; p->gc_line = line; \ + if (has_odd_bits(p)) {char *s; fprintf(stderr, "odd bits: %s\n", s = describe_type_bits(sc, p)); free(s);} \ + signed_type(p) = 0; \ + (*fp++) = p; \ + } \ + else if (signed_type(p) < 0) clear_mark(p); #else - #define gc_call(Tp) p = (*Tp++); if (is_marked(p)) clear_mark(p); else {if (!is_free_and_clear(p)) {clear_type(p); (*fp++) = p;}} + #define gc_call(Tp) p = (*Tp++); if (signed_type(p) > 0) {signed_type(p) = 0; (*fp++) = p;} else if (signed_type(p) < 0) clear_mark(p); + /* this appears to be about 10% faster than the previous form + * if the sign bit is on, but no other bits, this version will take no action (it thinks the cell is on the free list), but + * it means we've marked a free cell as in-use: since types are set as soon as removed from the free list, this has to be a bug + * (this case is caught by has_odd_bits). If ignored, the type will be set, and later the bit cleared, so no problem? + * An alternate form that simply calls clear_mark (no check for < 0) appears to be the same speed even in cases with lots + * of long-lived objects. + */ #endif while (tp < heap_top) /* != here or ^ makes no difference, going to 64 doesn't matter (this is less than .1% in all cases) */ { @@ -7077,7 +7136,6 @@ static int64_t gc(s7_scheme *sc) /* I tried using pthreads here, since there is no need for a lock in this loop, but the *fp++ part needs to * be local to each thread, then merged at the end. In my timing tests, the current version was faster. * If NUM_THREADS=2, and all thread variables are local, surely there's no "false sharing"? - * Also marking the is_marked check as unlikely did not speed up the timing tests. */ sc->free_heap_top = fp; sweep(sc); @@ -7270,10 +7328,10 @@ s7_pointer s7_gc_on(s7_scheme *sc, bool on) } #if S7_DEBUGGING -static void check_heap_size_1(s7_scheme *sc, s7_int size, const char *func, int line) -#define check_heap_size(Sc, Size) check_heap_size_1(Sc, Size, __func__, __LINE__) +static void check_free_heap_size_1(s7_scheme *sc, s7_int size, const char *func, int line) +#define check_free_heap_size(Sc, Size) check_free_heap_size_1(Sc, Size, __func__, __LINE__) #else -static void check_heap_size(s7_scheme *sc, s7_int size) +static void check_free_heap_size(s7_scheme *sc, s7_int size) #endif { s7_int free_cells; @@ -7559,7 +7617,7 @@ static void push_stack_1(s7_scheme *sc, opcode_t op, s7_pointer args, s7_pointer if (sc->stop_at_error) abort(); } /* if (sc->stack_end >= sc->stack_resize_trigger) fprintf(stderr, "%s[%d]: resize missed\n", func, line); */ - + if (code) sc->stack_end[0] = T_Pos(code); sc->stack_end[1] = T_Lid(sc->curlet); if ((args) && (unchecked_type(args) != T_FREE)) sc->stack_end[2] = T_Pos(args); @@ -7808,7 +7866,7 @@ static inline s7_pointer new_symbol(s7_scheme *sc, const char *name, s7_int len, symbol_set_local_slot_unchecked(x, 0LL, sc->nil); symbol_set_tag(x, 0); symbol_set_tag2(x, 0); - symbol_set_ctr(x, 0); + symbol_clear_ctr(x); symbol_clear_type(x); symbol_set_position(x, PD_POSITION_UNSET); @@ -7994,7 +8052,7 @@ static void remove_gensym_from_symbol_table(s7_scheme *sc, s7_pointer sym) else { s7_pointer y; - for (y = x, x = cdr(x); is_pair(x); y = x, x = cdr(x)) + for (y = x, x = cdr(x); is_pair(x); y = x, x = cdr(x)) if (car(x) == sym) { set_cdr(y, cdr(x)); @@ -8112,7 +8170,7 @@ static s7_pointer g_gensym(s7_scheme *sc, s7_pointer args) set_global_slot(x, sc->undefined); /* set_initial_slot(x, sc->undefined); */ symbol_set_local_slot_unchecked(x, 0LL, sc->nil); - symbol_set_ctr(x, 0); + symbol_clear_ctr(x); symbol_set_tag(x, 0); symbol_set_tag2(x, 0); symbol_clear_type(x); @@ -8236,7 +8294,7 @@ static inline s7_pointer g_string_to_symbol_1(s7_scheme *sc, s7_pointer str, s7_ return(simple_wrong_type_argument_with_type(sc, caller, str, wrap_string(sc, "a non-null string", 17))); /* currently if the string has an embedded null, it marks the end of the new symbol name. */ } - return(method_or_bust_one_arg(sc, str, caller, list_1(sc, str), T_STRING)); + return(method_or_bust_one_arg_p(sc, str, caller, T_STRING)); } static s7_pointer g_string_to_symbol(s7_scheme *sc, s7_pointer args) @@ -8441,6 +8499,24 @@ static Inline s7_pointer add_slot_at_end(s7_scheme *sc, uint64_t id, s7_pointer return(slot); } +static inline void make_let_with_three_slots(s7_scheme *sc, s7_pointer func, s7_pointer val1, s7_pointer val2, s7_pointer val3) +{ + s7_pointer last_slot, cargs; + cargs = closure_args(func); + sc->curlet = make_let_with_two_slots(sc, closure_let(func), car(cargs), val1, cadr(cargs), val2); + last_slot = next_slot(let_slots(sc->curlet)); + add_slot_at_end(sc, let_id(sc->curlet), last_slot, caddr(cargs), val3); +} + +static void make_let_with_four_slots(s7_scheme *sc, s7_pointer func, s7_pointer val1, s7_pointer val2, s7_pointer val3, s7_pointer val4) +{ + s7_pointer last_slot; + sc->curlet = make_let_with_two_slots(sc, closure_let(func), car(closure_args(func)), val1, cadr(closure_args(func)), val2); + last_slot = next_slot(let_slots(sc->curlet)); + last_slot = add_slot_at_end(sc, let_id(sc->curlet), last_slot, caddr(closure_args(func)), val3); + add_slot_at_end(sc, let_id(sc->curlet), last_slot, cadddr(closure_args(func)), val4); +} + static s7_pointer reuse_as_let(s7_scheme *sc, s7_pointer let, s7_pointer next_let) { /* we're reusing let here as a let -- it was probably a pair */ @@ -8459,7 +8535,7 @@ static s7_pointer reuse_as_slot(s7_scheme *sc, s7_pointer slot, s7_pointer symbo { #if S7_DEBUGGING slot->debugger_bits = 0; - if (not_in_heap(slot)) fprintf(stderr, "reusing an unheaped cell?\n"); + if (not_in_heap(slot)) fprintf(stderr, "reusing a permanent cell?\n"); if (is_multiple_value(value)) { fprintf(stderr, "%s%s[%d]: multiple-value %s %s%s\n", BOLD_TEXT, __func__, __LINE__, display(value), display(sc->code), UNBOLD_TEXT); @@ -8472,58 +8548,72 @@ static s7_pointer reuse_as_slot(s7_scheme *sc, s7_pointer slot, s7_pointer symbo return(slot); } -#define update_slot(X, Val, Id) do {s7_pointer sym; slot_set_value(X, Val); sym = slot_symbol(X); symbol_set_local_slot(sym, Id, X);} while (0) +#define update_slot(Slot, Val, Id) do {s7_pointer sym; slot_set_value(Slot, Val); sym = slot_symbol(Slot); symbol_set_local_slot_unincremented(sym, Id, Slot);} while (0) static s7_pointer update_let_with_slot(s7_scheme *sc, s7_pointer let, s7_pointer val) { - s7_pointer x; + s7_pointer slot; uint64_t id; - id = ++sc->let_number; let_set_id(let, id); - x = let_slots(let); - update_slot(x, val, id); + slot = let_slots(let); + update_slot(slot, val, id); return(let); } static s7_pointer update_let_with_two_slots(s7_scheme *sc, s7_pointer let, s7_pointer val1, s7_pointer val2) { - s7_pointer x; + s7_pointer slot; uint64_t id; - id = ++sc->let_number; let_set_id(let, id); - x = let_slots(let); - update_slot(x, val1, id); - x = next_slot(x); - update_slot(x, val2, id); + slot = let_slots(let); + update_slot(slot, val1, id); + slot = next_slot(slot); + update_slot(slot, val2, id); return(let); } static s7_pointer update_let_with_three_slots(s7_scheme *sc, s7_pointer let, s7_pointer val1, s7_pointer val2, s7_pointer val3) { - s7_pointer x; + s7_pointer slot; uint64_t id; + id = ++sc->let_number; + let_set_id(let, id); + slot = let_slots(let); + update_slot(slot, val1, id); + slot = next_slot(slot); + update_slot(slot, val2, id); + slot = next_slot(slot); + update_slot(slot, val3, id); + return(let); +} +static s7_pointer update_let_with_four_slots(s7_scheme *sc, s7_pointer let, s7_pointer val1, s7_pointer val2, s7_pointer val3, s7_pointer val4) +{ + s7_pointer slot; + uint64_t id; id = ++sc->let_number; let_set_id(let, id); - x = let_slots(let); - update_slot(x, val1, id); - x = next_slot(x); - update_slot(x, val2, id); - x = next_slot(x); - update_slot(x, val3, id); + slot = let_slots(let); + update_slot(slot, val1, id); + slot = next_slot(slot); + update_slot(slot, val2, id); + slot = next_slot(slot); + update_slot(slot, val3, id); + slot = next_slot(slot); + update_slot(slot, val4, id); return(let); } static s7_pointer make_permanent_slot(s7_scheme *sc, s7_pointer symbol, s7_pointer value) { - s7_pointer x; - x = alloc_pointer(sc); - set_type(x, T_SLOT | T_UNHEAP); - slot_set_symbol(x, symbol); - slot_set_value(x, value); - return(x); + s7_pointer slot; + slot = alloc_pointer(sc); + set_type(slot, T_SLOT | T_UNHEAP); + slot_set_symbol(slot, symbol); + slot_set_value(slot, value); + return(slot); } static s7_pointer make_permanent_let(s7_scheme *sc, s7_pointer vars) @@ -8605,24 +8695,23 @@ static s7_pointer let_fill(s7_scheme *sc, s7_pointer args) return(val); } -static s7_pointer find_method(s7_scheme *sc, s7_pointer let, s7_pointer symbol) +static s7_pointer find_method(s7_scheme *sc, s7_pointer let, s7_pointer symbol) /* TODO: can this use standard searchers? */ { - s7_pointer x; if (symbol_id(symbol) == 0) /* this means the symbol has never been used locally, so how can it be a method? */ return(sc->undefined); if (let_id(let) == symbol_id(symbol)) return(slot_value(local_slot(symbol))); - - for (x = let; symbol_id(symbol) < let_id(x); x = let_outlet(x)); - - if (let_id(x) == symbol_id(symbol)) - return(slot_value(local_slot(symbol))); - - for (; is_let(x); x = let_outlet(x)) + if (symbol_id(symbol) < let_id(let)) + { + do {let = let_outlet(let);} while (symbol_id(symbol) < let_id(let)); + if (let_id(let) == symbol_id(symbol)) + return(slot_value(local_slot(symbol))); + } + for (; is_let(let); let = let_outlet(let)) { s7_pointer y; - for (y = let_slots(x); tis_slot(y); y = next_slot(y)) + for (y = let_slots(let); tis_slot(y); y = next_slot(y)) if (slot_symbol(y) == symbol) return(slot_value(y)); } @@ -8654,7 +8743,7 @@ static s7_int let_length(s7_scheme *sc, s7_pointer e) length_func = find_method(sc, e, sc->length_symbol); if (length_func != sc->undefined) { - p = call_method(sc, e, length_func, list_1(sc, e)); + p = call_method(sc, e, length_func, set_plist_1(sc, e)); return((s7_is_integer(p)) ? s7_integer_checked(sc, p) : -1); /* ?? */ }} for (i = 0, p = let_slots(e); tis_slot(p); i++, p = next_slot(p)); @@ -8788,11 +8877,10 @@ s7_pointer s7_make_slot(s7_scheme *sc, s7_pointer let, s7_pointer symbol, s7_poi if (symbol_id(symbol) == 0) /* never defined locally? */ { - if (!is_gensym(symbol)) - { - if (initial_slot(symbol) == sc->undefined) - set_initial_slot(symbol, make_permanent_slot(sc, symbol, value)); - } + if ((!is_gensym(symbol)) && + (initial_slot(symbol) == sc->undefined) && + (not_in_heap(value))) /* else initial_slot value can be GC'd if symbol set! (initial != global, initial unprotected) */ + set_initial_slot(symbol, make_permanent_slot(sc, symbol, value)); set_local_slot(symbol, slot); set_global(symbol); } @@ -8982,7 +9070,7 @@ static s7_pointer g_coverlet(s7_scheme *sc, s7_pointer args) e = car(args); sc->temp3 = e; - check_method_uncopied(sc, e, sc->coverlet_symbol, list_1(sc, e)); + check_method(sc, e, sc->coverlet_symbol, set_plist_1(sc, e)); sc->temp3 = sc->nil; if ((e == sc->rootlet) || (e == sc->s7_let)) s7_error(sc, sc->out_of_range_symbol, set_elist_2(sc, wrap_string(sc, "can't coverlet ~S", 17), e)); @@ -9039,10 +9127,9 @@ static void append_let(s7_scheme *sc, s7_pointer new_e, s7_pointer old_e) s7_gc_unprotect_at(sc, gc_loc); } else - { - for (x = let_slots(old_e); tis_slot(x); x = next_slot(x)) - make_slot_1(sc, new_e, slot_symbol(x), slot_value(x)); /* not add_slot here because we might run off the free heap end */ - }} + for (x = let_slots(old_e); tis_slot(x); x = next_slot(x)) + make_slot_1(sc, new_e, slot_symbol(x), slot_value(x)); /* not add_slot here because we might run off the free heap end */ + } } static s7_pointer check_c_object_let(s7_scheme *sc, s7_pointer old_e, s7_pointer caller) @@ -9170,8 +9257,8 @@ static s7_pointer g_cutlet(s7_scheme *sc, s7_pointer args) #define Q_cutlet s7_make_circular_signature(sc, 2, 3, sc->is_let_symbol, sc->is_let_symbol, sc->is_symbol_symbol) s7_pointer e, syms; - s7_int THE_UN_ID; - THE_UN_ID = ++sc->let_number; + s7_int the_un_id; + the_un_id = ++sc->let_number; e = car(args); if (is_null(e)) @@ -9204,7 +9291,7 @@ static s7_pointer g_cutlet(s7_scheme *sc, s7_pointer args) { if (is_slot(global_slot(sym))) { - symbol_set_id(sym, THE_UN_ID); + symbol_set_id(sym, the_un_id); slot_set_value(global_slot(sym), sc->undefined); }} else @@ -9219,7 +9306,7 @@ static s7_pointer g_cutlet(s7_scheme *sc, s7_pointer args) if (slot_symbol(slot) == sym) { let_set_slots(e, next_slot(let_slots(e))); - symbol_set_id(sym, THE_UN_ID); + symbol_set_id(sym, the_un_id); } else { @@ -9228,7 +9315,7 @@ static s7_pointer g_cutlet(s7_scheme *sc, s7_pointer args) for (slot = next_slot(let_slots(e)); tis_slot(slot); last_slot = slot, slot = next_slot(slot)) if (slot_symbol(slot) == sym) { - symbol_set_id(sym, THE_UN_ID); + symbol_set_id(sym, the_un_id); slot_set_next(last_slot, next_slot(slot)); break; }}}}} @@ -9293,10 +9380,9 @@ static s7_pointer sublet_1(s7_scheme *sc, s7_pointer e, s7_pointer bindings, s7_ if (sym == sc->let_ref_fallback_symbol) set_has_let_ref_fallback(new_e); else - { - if (sym == sc->let_set_fallback_symbol) - set_has_let_set_fallback(new_e); - }} + if (sym == sc->let_set_fallback_symbol) + set_has_let_set_fallback(new_e); + } sc->temp3 = sc->nil; } return(new_e); @@ -9457,7 +9543,6 @@ s7_pointer s7_let_to_list(s7_scheme *sc, s7_pointer let) sc->temp3 = sc->w; sc->w = sc->nil; - if (let == sc->rootlet) { s7_int i, lim2; @@ -9483,7 +9568,7 @@ s7_pointer s7_let_to_list(s7_scheme *sc, s7_pointer let) if ((has_active_methods(sc, let)) && ((func = find_method(sc, let, sc->make_iterator_symbol)) != sc->undefined)) - iter = call_method(sc, let, func, list_1(sc, let)); + iter = call_method(sc, let, func, set_plist_1(sc, let)); else { if (let == sc->s7_let) /* (let->list *s7*) via s7_let_make_iterator */ @@ -9495,10 +9580,8 @@ s7_pointer s7_let_to_list(s7_scheme *sc, s7_pointer let) } if (is_null(iter)) - { - for (x = let_slots(let); tis_slot(x); x = next_slot(x)) - sc->w = cons_unchecked(sc, cons(sc, slot_symbol(x), slot_value(x)), sc->w); - } + for (x = let_slots(let); tis_slot(x); x = next_slot(x)) + sc->w = cons_unchecked(sc, cons(sc, slot_symbol(x), slot_value(x)), sc->w); else { /* (begin (load "mockery.scm") (let ((lt ((*mock-pair* 'mock-pair) 1 2 3))) (format *stderr* "~{~A ~}" lt))) */ @@ -9533,10 +9616,8 @@ static s7_pointer g_let_to_list(s7_scheme *sc, s7_pointer args) if (is_c_object(let)) let = c_object_let(let); else - { - if (is_c_pointer(let)) - let = c_pointer_info(let); - } + if (is_c_pointer(let)) + let = c_pointer_info(let); if (!is_let(let)) return(simple_wrong_type_argument_with_type(sc, sc->let_to_list_symbol, let, a_let_string)); } @@ -9589,7 +9670,7 @@ inline s7_pointer s7_let_ref(s7_scheme *sc, s7_pointer let, s7_pointer symbol) } if (!is_global(sc->let_ref_symbol)) - check_method_uncopied(sc, let, sc->let_ref_symbol, list_2(sc, let, symbol)); + check_method(sc, let, sc->let_ref_symbol, set_plist_2(sc, let, symbol)); /* a let-ref method is almost impossible to write without creating an infinite loop: * any reference to the let will probably call let-ref somewhere, calling us again, and looping. * This is not a problem in c-objects and funclets because c-object-ref and funclet-ref don't exist. @@ -9760,11 +9841,9 @@ static s7_pointer let_set_1(s7_scheme *sc, s7_pointer let, s7_pointer symbol, s7 if (slot_symbol(y) == symbol) return(checked_slot_set_value(sc, y, value)); - if (has_methods(let)) - { - if (has_let_set_fallback(let)) - return(call_let_set_fallback(sc, let, symbol, value)); - } + if ((has_methods(let)) && + (has_let_set_fallback(let))) + return(call_let_set_fallback(sc, let, symbol, value)); return(s7_error(sc, sc->wrong_type_arg_symbol, set_elist_3(sc, wrap_string(sc, "let-set!: ~A is not defined in ~A", 33), symbol, let))); /* not sure about this -- what's the most useful choice? */ @@ -9781,7 +9860,7 @@ s7_pointer s7_let_set(s7_scheme *sc, s7_pointer let, s7_pointer symbol, s7_point return(wrong_type_argument_with_type(sc, sc->let_set_symbol, 2, symbol, a_symbol_string)); } if (!is_global(sc->let_set_symbol)) - check_method_uncopied(sc, let, sc->let_set_symbol, sc->w = list_3(sc, let, symbol, value)); + check_method(sc, let, sc->let_set_symbol, set_plist_3(sc, let, symbol, value)); return(let_set_1(sc, let, symbol, value)); } @@ -9824,11 +9903,10 @@ static s7_pointer g_lint_let_set(s7_scheme *sc, s7_pointer args) return(slot_value(y)); } - if (has_methods(lt)) - { - if (has_let_set_fallback(lt)) - return(call_let_set_fallback(sc, lt, sym, val)); - }} + if ((has_methods(lt)) && + (has_let_set_fallback(lt))) + return(call_let_set_fallback(sc, lt, sym, val)); + } y = global_slot(sym); if (is_slot(y)) @@ -9981,7 +10059,7 @@ static void update_symbol_ids(s7_scheme *sc, s7_pointer e) s7_pointer sym; sym = slot_symbol(p); if (symbol_id(sym) != sc->let_number) - symbol_set_local_slot(sym, sc->let_number, p); + symbol_set_local_slot_unincremented(sym, sc->let_number, p); } } @@ -10039,67 +10117,52 @@ static s7_pointer g_set_outlet(s7_scheme *sc, s7_pointer args) return(s7_wrong_type_arg_error(sc, "set! outlet", 2, new_outer, "a let")); if (let != sc->rootlet) - let_set_outlet(let, (new_outer == sc->rootlet) ? sc->nil : new_outer); + let_set_outlet(let, (new_outer == sc->rootlet) ? sc->nil : new_outer); /* outlet rootlet->() so that slot search can use is_let(outlet) I think */ return(new_outer); } /* -------------------------------- symbol lookup -------------------------------- */ -static inline s7_pointer symbol_to_slot(s7_scheme *sc, s7_pointer symbol) -{ - s7_pointer x; - if (let_id(sc->curlet) == symbol_id(symbol)) - return(local_slot(symbol)); - for (x = sc->curlet; symbol_id(symbol) < let_id(x); x = let_outlet(x)); - if (let_id(x) == symbol_id(symbol)) - return(local_slot(symbol)); - for (; is_let(x); x = let_outlet(x)) - { - s7_pointer y; - for (y = let_slots(x); tis_slot(y); y = next_slot(y)) - if (slot_symbol(y) == symbol) - return(y); - } - return(global_slot(symbol)); -} -static inline s7_pointer lookup_from(s7_scheme *sc, s7_pointer symbol, s7_pointer e) +static inline s7_pointer lookup_from(s7_scheme *sc, const s7_pointer symbol, s7_pointer e) { - s7_pointer x; if (let_id(e) == symbol_id(symbol)) return(slot_value(local_slot(symbol))); - for (x = e; symbol_id(symbol) < let_id(x); x = let_outlet(x)); - if (let_id(x) == symbol_id(symbol)) - return(slot_value(local_slot(symbol))); - for (; is_let(x); x = let_outlet(x)) + if (symbol_id(symbol) < let_id(e)) + { + do {e = let_outlet(e);} while (symbol_id(symbol) < let_id(e)); + if (let_id(e) == symbol_id(symbol)) + return(slot_value(local_slot(symbol))); + } + for (; is_let(e); e = let_outlet(e)) { s7_pointer y; - for (y = let_slots(x); tis_slot(y); y = next_slot(y)) + for (y = let_slots(e); tis_slot(y); y = next_slot(y)) if (slot_symbol(y) == symbol) return(slot_value(y)); } - x = global_slot(symbol); - if (is_slot(x)) return(slot_value(x)); - + if (is_slot(global_slot(symbol))) + return(slot_value(global_slot(symbol))); #if WITH_GCC return(NULL); /* much faster than various alternatives */ #else return(unbound_variable(sc, symbol)); #endif } -/* perhaps copy low-order symbol-location bit to the slot -- would that be faster than the == above? (callgrind says the struct traversal is more expensive) */ -static s7_pointer lookup_slot_from(s7_pointer symbol, s7_pointer e) +static inline s7_pointer lookup_slot_from(s7_pointer symbol, s7_pointer e) { - s7_pointer x; if (let_id(e) == symbol_id(symbol)) return(local_slot(symbol)); - for (x = e; symbol_id(symbol) < let_id(x); x = let_outlet(x)); - if (let_id(x) == symbol_id(symbol)) - return(local_slot(symbol)); - for (; is_let(x); x = let_outlet(x)) + if (symbol_id(symbol) < let_id(e)) + { + do {e = let_outlet(e);} while (symbol_id(symbol) < let_id(e)); + if (let_id(e) == symbol_id(symbol)) + return(local_slot(symbol)); + } + for (; is_let(e); e = let_outlet(e)) { s7_pointer y; - for (y = let_slots(x); tis_slot(y); y = next_slot(y)) + for (y = let_slots(e); tis_slot(y); y = next_slot(y)) if (slot_symbol(y) == symbol) return(y); } @@ -10107,15 +10170,15 @@ static s7_pointer lookup_slot_from(s7_pointer symbol, s7_pointer e) } #if WITH_GCC && S7_DEBUGGING -static s7_pointer lookup_1(s7_scheme *sc, s7_pointer symbol) +static s7_pointer lookup_1(s7_scheme *sc, const s7_pointer symbol) #else -static inline s7_pointer lookup(s7_scheme *sc, s7_pointer symbol) /* lookup_checked includes the unbound_variable call */ +static inline s7_pointer lookup(s7_scheme *sc, const s7_pointer symbol) /* lookup_checked includes the unbound_variable call */ #endif { return(lookup_from(sc, symbol, sc->curlet)); } -s7_pointer s7_slot(s7_scheme *sc, s7_pointer symbol) {return(symbol_to_slot(sc, symbol));} +s7_pointer s7_slot(s7_scheme *sc, s7_pointer symbol) {return(lookup_slot_from(symbol, sc->curlet));} s7_pointer s7_slot_value(s7_pointer slot) {return(slot_value(slot));} s7_pointer s7_slot_set_value(s7_scheme *sc, s7_pointer slot, s7_pointer value) @@ -10147,30 +10210,30 @@ static s7_pointer symbol_to_local_slot(s7_scheme *sc, s7_pointer symbol, s7_poin s7_pointer s7_symbol_value(s7_scheme *sc, s7_pointer sym) { s7_pointer x; - x = symbol_to_slot(sc, sym); + x = lookup_slot_from(sym, sc->curlet); return((is_slot(x)) ? slot_value(x) : sc->undefined); } -s7_pointer s7_symbol_local_value(s7_scheme *sc, s7_pointer sym, s7_pointer local_let) +s7_pointer s7_symbol_local_value(s7_scheme *sc, s7_pointer sym, s7_pointer let) /* TODO: can this use the funcs above? */ { - /* restrict the search to local_let outward */ - if ((local_let == sc->rootlet) || (is_global(sym))) + /* restrict the search to local let outward */ + if ((let == sc->rootlet) || (is_global(sym))) return((is_slot(global_slot(sym))) ? slot_value(global_slot(sym)) : sc->undefined); - if (is_let(local_let)) + if (is_let(let)) { - s7_pointer x; - - if (let_id(local_let) == symbol_id(sym)) - return(slot_value(local_slot(sym))); - for (x = local_let; symbol_id(sym) < let_id(x); x = let_outlet(x)); - if (let_id(x) == symbol_id(sym)) + if (let_id(let) == symbol_id(sym)) return(slot_value(local_slot(sym))); - - for (; is_let(x); x = let_outlet(x)) + if (symbol_id(sym) < let_id(let)) + { + do {let = let_outlet(let);} while (symbol_id(sym) < let_id(let)); + if (let_id(let) == symbol_id(sym)) + return(slot_value(local_slot(sym))); + } + for (; is_let(let); let = let_outlet(let)) { s7_pointer y; - for (y = let_slots(x); tis_slot(y); y = next_slot(y)) + for (y = let_slots(let); tis_slot(y); y = next_slot(y)) if (slot_symbol(y) == sym) return(slot_value(y)); } @@ -10232,7 +10295,7 @@ s7_pointer s7_symbol_set_value(s7_scheme *sc, s7_pointer sym, s7_pointer val) { s7_pointer x; /* if immutable should this return an error? */ - x = symbol_to_slot(sc, sym); + x = lookup_slot_from(sym, sc->curlet); if (is_slot(x)) slot_set_value(x, val); /* with_hook? */ return(val); @@ -10323,7 +10386,7 @@ static bool do_symbol_is_safe(s7_scheme *sc, s7_pointer sym, s7_pointer e) { return((is_slot(global_slot(sym))) || (direct_assq(sym, e)) || - (is_slot(symbol_to_slot(sc, sym)))); + (is_slot(lookup_slot_from(sym, sc->curlet)))); } static bool let_symbol_is_safe(s7_scheme *sc, s7_pointer sym, s7_pointer e) @@ -10333,7 +10396,7 @@ static bool let_symbol_is_safe(s7_scheme *sc, s7_pointer sym, s7_pointer e) if (is_null(e)) e = sc->rootlet; return((!is_with_let_let(e)) && - (is_slot(symbol_to_slot(sc, sym)))); + (is_slot(lookup_slot_from(sym, sc->curlet)))); } static bool let_symbol_is_safe_or_listed(s7_scheme *sc, s7_pointer sym, s7_pointer e) @@ -10346,7 +10409,7 @@ static bool let_star_symbol_is_safe(s7_scheme *sc, s7_pointer sym, s7_pointer e) { return((symbol_is_in_list(sc, sym)) || (is_slot(global_slot(sym))) || - ((is_let(e)) && (!is_with_let_let(e)) && (is_slot(symbol_to_slot(sc, sym))))); + ((is_let(e)) && (!is_with_let_let(e)) && (is_slot(lookup_slot_from(sym, sc->curlet))))); } static bool pair_symbol_is_safe(s7_scheme *sc, s7_pointer sym, s7_pointer e) @@ -10369,11 +10432,11 @@ static s7_pointer collect_parameters(s7_scheme *sc, s7_pointer lst, s7_pointer e { /* collect local variable names from lambda arglists (pre-error-check) */ s7_pointer p; - s7_int THE_UN_ID; - THE_UN_ID = ++sc->let_number; + s7_int the_un_id; + the_un_id = ++sc->let_number; if (is_symbol(lst)) { - symbol_set_id(lst, THE_UN_ID); + symbol_set_id(lst, the_un_id); return(cons(sc, add_symbol_to_list(sc, lst), e)); } sc->w = e; @@ -10385,12 +10448,12 @@ static s7_pointer collect_parameters(s7_scheme *sc, s7_pointer lst, s7_pointer e car_p = car(car_p); if (is_normal_symbol(car_p)) { - symbol_set_id(car_p, THE_UN_ID); + symbol_set_id(car_p, the_un_id); sc->w = cons(sc, add_symbol_to_list(sc, car_p), sc->w); }} if (is_symbol(p)) /* rest arg */ { - symbol_set_id(p, THE_UN_ID); + symbol_set_id(p, the_un_id); sc->w = cons(sc, add_symbol_to_list(sc, p), sc->w); } return(sc->w); @@ -10577,12 +10640,14 @@ static int32_t closure_length(s7_scheme *sc, s7_pointer e) s7_pointer length_func; length_func = find_method(sc, closure_let(e), sc->length_symbol); if (length_func != sc->undefined) - return((int32_t)s7_integer_checked(sc, call_method(sc, e, length_func, list_1(sc, e)))); + return((int32_t)s7_integer_checked(sc, call_method(sc, e, length_func, set_plist_1(sc, e)))); /* there are cases where this should raise a wrong-type-arg error, but for now... */ return(-1); } +static s7_pointer cons_unchecked_with_type(s7_scheme *sc, s7_pointer p, s7_pointer a, s7_pointer b); + static s7_pointer copy_tree_with_type(s7_scheme *sc, s7_pointer tree) { /* if sc->safety > NO_SAFETY, '(1 2) is set immutable by the reader, but eval (in that safety case) calls @@ -10724,7 +10789,7 @@ static s7_pointer copy_body(s7_scheme *sc, s7_pointer p) sc->w = p; if (tree_is_cyclic(sc, p)) s7_error(sc, sc->wrong_type_arg_symbol, wrap_string(sc, "copy: tree is cyclic", 20)); - check_heap_size(sc, tree_len(sc, p) * 2); + check_free_heap_size(sc, tree_len(sc, p) * 2); sc->w = (sc->safety > NO_SAFETY) ? copy_tree_with_type(sc, p) : copy_tree(sc, p); p = sc->w; sc->w = sc->nil; @@ -10802,7 +10867,7 @@ static s7_pointer g_is_defined(s7_scheme *sc, s7_pointer args) return((b == sc->T) ? sc->F : make_boolean(sc, is_slot(global_slot(sym)))); } - return((is_global(sym)) ? sc->T : make_boolean(sc, is_slot(symbol_to_slot(sc, sym)))); + return((is_global(sym)) ? sc->T : make_boolean(sc, is_slot(lookup_slot_from(sym, sc->curlet)))); } static s7_pointer g_is_defined_in_rootlet(s7_scheme *sc, s7_pointer args) @@ -10836,7 +10901,7 @@ bool s7_is_defined(s7_scheme *sc, const char *name) x = s7_symbol_table_find_name(sc, name); if (x) { - x = symbol_to_slot(sc, x); + x = lookup_slot_from(x, sc->curlet); return(is_slot(x)); } return(false); @@ -10846,7 +10911,7 @@ static bool is_defined_b_7p(s7_scheme *sc, s7_pointer p) { if (!is_symbol(p)) simple_wrong_type_argument(sc, sc->is_defined_symbol, p, T_SYMBOL); - return(is_slot(symbol_to_slot(sc, p))); + return(is_slot(lookup_slot_from(p, sc->curlet))); } static bool is_defined_b_7pp(s7_scheme *sc, s7_pointer p, s7_pointer e) {return(g_is_defined(sc, set_plist_2(sc, p, e)) != sc->F);} @@ -11102,7 +11167,7 @@ static s7_pointer g_c_pointer(s7_scheme *sc, s7_pointer args) static s7_pointer c_pointer_info_p_p(s7_scheme *sc, s7_pointer p) { if (!is_c_pointer(p)) - return(method_or_bust(sc, p, sc->c_pointer_info_symbol, list_1(sc, p), T_C_POINTER, 1)); + return(method_or_bust_p(sc, p, sc->c_pointer_info_symbol, T_C_POINTER)); return(c_pointer_info(p)); } @@ -11122,7 +11187,7 @@ s7_pointer s7_c_pointer_type(s7_pointer p) static s7_pointer c_pointer_type_p_p(s7_scheme *sc, s7_pointer p) { - return((is_c_pointer(p)) ? c_pointer_type(p) : method_or_bust(sc, p, sc->c_pointer_type_symbol, list_1(sc, p), T_C_POINTER, 1)); + return((is_c_pointer(p)) ? c_pointer_type(p) : method_or_bust_p(sc, p, sc->c_pointer_type_symbol, T_C_POINTER)); } static s7_pointer g_c_pointer_type(s7_scheme *sc, s7_pointer args) @@ -11136,7 +11201,7 @@ static s7_pointer g_c_pointer_type(s7_scheme *sc, s7_pointer args) /* -------------------------------- c-pointer-weak1/2 -------------------------------- */ static s7_pointer c_pointer_weak1_p_p(s7_scheme *sc, s7_pointer p) { - return((is_c_pointer(p)) ? c_pointer_weak1(p) : method_or_bust(sc, p, sc->c_pointer_weak1_symbol, list_1(sc, p), T_C_POINTER, 1)); + return((is_c_pointer(p)) ? c_pointer_weak1(p) : method_or_bust_p(sc, p, sc->c_pointer_weak1_symbol, T_C_POINTER)); } static s7_pointer g_c_pointer_weak1(s7_scheme *sc, s7_pointer args) @@ -11148,7 +11213,7 @@ static s7_pointer g_c_pointer_weak1(s7_scheme *sc, s7_pointer args) static s7_pointer c_pointer_weak2_p_p(s7_scheme *sc, s7_pointer p) { - return((is_c_pointer(p)) ? c_pointer_weak2(p) : method_or_bust(sc, p, sc->c_pointer_weak2_symbol, list_1(sc, p), T_C_POINTER, 1)); + return((is_c_pointer(p)) ? c_pointer_weak2(p) : method_or_bust_p(sc, p, sc->c_pointer_weak2_symbol, T_C_POINTER)); } static s7_pointer g_c_pointer_weak2(s7_scheme *sc, s7_pointer args) @@ -11197,14 +11262,13 @@ static bool s7_is_continuation(s7_pointer p) {return(is_continuation(p));} static s7_pointer check_wrap_return(s7_pointer lst) { s7_pointer fast, slow; - for (fast = lst, slow = lst; is_pair(fast); fast = cdr(fast)) + for (fast = lst, slow = lst; is_pair(fast); slow = cdr(slow), fast = cdr(fast)) { if (is_matched_pair(fast)) fprintf(stderr, "matched_pair not cleared\n"); fast = cdr(fast); if (!is_pair(fast)) return(lst); if (fast == slow) return(lst); if (is_matched_pair(fast)) fprintf(stderr, "matched_pair not cleared\n"); - slow = cdr(slow); } return(lst); } @@ -11219,7 +11283,7 @@ static s7_pointer copy_any_list(s7_scheme *sc, s7_pointer a) #define wrap_return(W) do {fast = W; W = sc->nil; return(fast);} while (0) #endif - sc->w = cons(sc, car(a), sc->nil); + sc->w = list_1(sc, car(a)); p = sc->w; slow = cdr(a); @@ -11234,7 +11298,7 @@ static s7_pointer copy_any_list(s7_scheme *sc, s7_pointer a) wrap_return(sc->w); } - set_cdr(p, cons(sc, car(fast), sc->nil)); + set_cdr(p, list_1(sc, car(fast))); p = cdr(p); fast = cdr(fast); @@ -11246,7 +11310,7 @@ static s7_pointer copy_any_list(s7_scheme *sc, s7_pointer a) wrap_return(sc->w); } /* if unrolled further, it's a lot slower? */ - set_cdr(p, cons(sc, car(fast), sc->nil)); + set_cdr(p, list_1(sc, car(fast))); p = cdr(p); fast = cdr(fast); @@ -11787,84 +11851,80 @@ static void call_with_exit(s7_scheme *sc) /* look for dynamic-wind in the stack section that we are jumping out of */ for (i = current_stack_top(sc) - 1; i > new_stack_top; i -= 4) - { - opcode_t op; - - op = stack_op(sc->stack, i); - switch (op) + switch (stack_op(sc->stack, i)) + { + case OP_DYNAMIC_WIND: { - case OP_DYNAMIC_WIND: - { - s7_pointer lx; - lx = stack_code(sc->stack, i); - if (dynamic_wind_state(lx) == DWIND_BODY) - { - dynamic_wind_state(lx) = DWIND_FINISH; - if (dynamic_wind_out(lx) != sc->F) - { - push_stack_direct(sc, OP_EVAL_DONE); - sc->args = sc->nil; - sc->code = dynamic_wind_out(lx); - eval(sc, OP_APPLY); - }}} - break; - - case OP_DYNAMIC_UNWIND: - case OP_DYNAMIC_UNWIND_PROFILE: - stack_element(sc->stack, i) = (s7_pointer)OP_GC_PROTECT; - dynamic_unwind(sc, stack_code(sc->stack, i), stack_args(sc->stack, i)); - break; - - case OP_EVAL_STRING: - s7_close_input_port(sc, current_input_port(sc)); - pop_input_port(sc); - break; - - case OP_BARRIER: /* oops -- we almost certainly went too far */ - goto SET_VALUE; - - case OP_DEACTIVATE_GOTO: /* here we're jumping into an unrelated call-with-exit block */ - call_exit_active(stack_args(sc->stack, i)) = false; - break; - - case OP_LET_TEMP_DONE: - let_temp_done(sc, stack_args(sc->stack, i), stack_code(sc->stack, i), stack_let(sc->stack, i)); - break; - - case OP_LET_TEMP_UNWIND: - let_temp_unwind(sc, stack_code(sc->stack, i), stack_args(sc->stack, i)); - break; - - case OP_LET_TEMP_S7_UNWIND: - g_s7_let_set_fallback(sc, set_plist_3(sc, sc->s7_let, stack_code(sc->stack, i), stack_args(sc->stack, i))); - break; - - /* call/cc does not close files, but I think call-with-exit should */ - case OP_GET_OUTPUT_STRING: - case OP_UNWIND_OUTPUT: - { - s7_pointer x; - x = stack_code(sc->stack, i); /* "code" = port that we opened */ - s7_close_output_port(sc, x); - x = stack_args(sc->stack, i); /* "args" = port that we shadowed, if not #<unused> */ - if (x != sc->unused) - set_current_output_port(sc, x); - } - break; - - case OP_UNWIND_INPUT: - s7_close_input_port(sc, stack_code(sc->stack, i)); /* "code" = port that we opened */ - if (stack_args(sc->stack, i) != sc->unused) - set_current_input_port(sc, stack_args(sc->stack, i)); /* "args" = port that we shadowed */ - break; - - case OP_EVAL_DONE: /* goto called in a method -- put off the inner eval return(s) until we clean up the stack */ - quit++; - break; - - default: - break; - }} + s7_pointer lx; + lx = stack_code(sc->stack, i); + if (dynamic_wind_state(lx) == DWIND_BODY) + { + dynamic_wind_state(lx) = DWIND_FINISH; + if (dynamic_wind_out(lx) != sc->F) + { + push_stack_direct(sc, OP_EVAL_DONE); + sc->args = sc->nil; + sc->code = dynamic_wind_out(lx); + eval(sc, OP_APPLY); + }}} + break; + + case OP_DYNAMIC_UNWIND: + case OP_DYNAMIC_UNWIND_PROFILE: + stack_element(sc->stack, i) = (s7_pointer)OP_GC_PROTECT; + dynamic_unwind(sc, stack_code(sc->stack, i), stack_args(sc->stack, i)); + break; + + case OP_EVAL_STRING: + s7_close_input_port(sc, current_input_port(sc)); + pop_input_port(sc); + break; + + case OP_BARRIER: /* oops -- we almost certainly went too far */ + goto SET_VALUE; + + case OP_DEACTIVATE_GOTO: /* here we're jumping into an unrelated call-with-exit block */ + call_exit_active(stack_args(sc->stack, i)) = false; + break; + + case OP_LET_TEMP_DONE: + let_temp_done(sc, stack_args(sc->stack, i), stack_code(sc->stack, i), stack_let(sc->stack, i)); + break; + + case OP_LET_TEMP_UNWIND: + let_temp_unwind(sc, stack_code(sc->stack, i), stack_args(sc->stack, i)); + break; + + case OP_LET_TEMP_S7_UNWIND: + g_s7_let_set_fallback(sc, set_plist_3(sc, sc->s7_let, stack_code(sc->stack, i), stack_args(sc->stack, i))); + break; + + /* call/cc does not close files, but I think call-with-exit should */ + case OP_GET_OUTPUT_STRING: + case OP_UNWIND_OUTPUT: + { + s7_pointer x; + x = stack_code(sc->stack, i); /* "code" = port that we opened */ + s7_close_output_port(sc, x); + x = stack_args(sc->stack, i); /* "args" = port that we shadowed, if not #<unused> */ + if (x != sc->unused) + set_current_output_port(sc, x); + } + break; + + case OP_UNWIND_INPUT: + s7_close_input_port(sc, stack_code(sc->stack, i)); /* "code" = port that we opened */ + if (stack_args(sc->stack, i) != sc->unused) + set_current_input_port(sc, stack_args(sc->stack, i)); /* "args" = port that we shadowed */ + break; + + case OP_EVAL_DONE: /* goto called in a method -- put off the inner eval return(s) until we clean up the stack */ + quit++; + break; + + default: + break; + } /* is this right? maybe the SET_VALUE should skip setting stack_end? */ SET_VALUE: @@ -11927,7 +11987,7 @@ static s7_pointer g_call_with_exit(s7_scheme *sc, s7_pointer args) /* (call-wi if ((is_any_c_function(p)) && (s7_is_aritable(sc, p, 1))) { call_exit_active(x) = false; - return((is_c_function(p)) ? c_function_call(p)(sc, list_1(sc, x)) : s7_apply_function_star(sc, p, list_1(sc, x))); + return((is_c_function(p)) ? c_function_call(p)(sc, list_1(sc, x)) : s7_apply_function_star(sc, p, set_plist_1(sc, x))); } push_stack(sc, OP_DEACTIVATE_GOTO, x, p); /* this means call-with-exit is not tail-recursive */ push_stack(sc, OP_APPLY, cons_unchecked(sc, x, sc->nil), p); @@ -11955,20 +12015,24 @@ static void op_call_with_exit_o(s7_scheme *sc) static bool op_implicit_goto(s7_scheme *sc) { - set_opt1_goto(sc->code, lookup_checked(sc, car(sc->code))); - if (!is_goto(opt1_goto(sc->code))) {sc->last_function = opt1_goto(sc->code); return(false);} + s7_pointer g; + g = lookup_checked(sc, car(sc->code)); + if (!is_goto(g)) {sc->last_function = g; return(false);} + set_opt1_goto(sc->code, g); + sc->code = g; sc->args = sc->nil; - sc->code = T_Got(opt1_goto(sc->code)); call_with_exit(sc); return(true); } static bool op_implicit_goto_a(s7_scheme *sc) { - set_opt1_goto(sc->code, lookup_checked(sc, car(sc->code))); - if (!is_goto(opt1_goto(sc->code))) {sc->last_function = opt1_goto(sc->code); return(false);} - sc->args = list_1(sc, fx_call(sc, cdr(sc->code))); - sc->code = T_Got(opt1_goto(sc->code)); + s7_pointer g; + g = lookup_checked(sc, car(sc->code)); + if (!is_goto(g)) {sc->last_function = g; return(false);} + set_opt1_goto(sc->code, g); + sc->args = list_1(sc, fx_call(sc, cdr(sc->code))); /* if dynamic-wind exited, eval might be called, so plist not safe here */ + sc->code = g; call_with_exit(sc); return(true); } @@ -12324,7 +12388,7 @@ static bool is_integer_via_method(s7_scheme *sc, s7_pointer p) s7_pointer f; f = find_method_with_let(sc, p, sc->is_integer_symbol); if (f != sc->undefined) - return(is_true(sc, call_method(sc, p, f, list_1(sc, p)))); + return(is_true(sc, call_method(sc, p, f, set_plist_1(sc, p)))); } return(false); } @@ -12732,13 +12796,9 @@ static s7_pointer string_to_either_complex(s7_scheme *sc, char *q, char *slash1, p_rl = string_to_either_complex_1(sc, q, slash1, ex1, has_dec_point1, radix, &d_rl); p_im = string_to_either_complex_1(sc, plus, slash2, ex2, has_dec_point2, radix, &d_im); - if (d_im == 0.0) - { - /* 1.0+0.0000000000000000000000000000i */ - if ((!p_im) || - (s7_is_zero(p_im))) - return((p_rl) ? p_rl : make_real(sc, d_rl)); - } + if ((d_im == 0.0) && /* 1.0+0.0000000000000000000000000000i */ + ((!p_im) || (s7_is_zero(p_im)))) + return((p_rl) ? p_rl : make_real(sc, d_rl)); if ((!p_rl) && (!p_im)) return(s7_make_complex(sc, d_rl, (has_plus_or_minus == -1) ? (-d_im) : d_im)); @@ -13184,7 +13244,7 @@ s7_pointer s7_rationalize(s7_scheme *sc, s7_double x, s7_double error) s7_pointer s7_make_integer(s7_scheme *sc, s7_int n) { s7_pointer x; - if (is_small(n)) + if (is_small_int(n)) return(small_int(n)); new_cell(sc, x, T_INTEGER); integer(x) = n; @@ -13201,7 +13261,7 @@ static s7_pointer make_mutable_integer(s7_scheme *sc, s7_int n) static s7_pointer make_permanent_integer(s7_int i) { - if (is_small(i)) return(small_int(i)); + if (is_small_int(i)) return(small_int(i)); if (i == MAX_ARITY) return(max_arity); if (i == CLOSURE_ARITY_NOT_SET) return(arity_not_set); @@ -13381,7 +13441,7 @@ static s7_pointer exact_to_inexact(s7_scheme *sc, s7_pointer x) return(x); /* apparently (exact->inexact 1+i) is not an error */ default: - return(method_or_bust_with_type_one_arg(sc, x, sc->exact_to_inexact_symbol, list_1(sc, x), a_number_string)); + return(method_or_bust_with_type_one_arg_p(sc, x, sc->exact_to_inexact_symbol, a_number_string)); } } @@ -13425,7 +13485,7 @@ static s7_pointer inexact_to_exact(s7_scheme *sc, s7_pointer x) } default: - return(method_or_bust_one_arg(sc, x, sc->inexact_to_exact_symbol, list_1(sc, x), T_REAL)); + return(method_or_bust_one_arg_p(sc, x, sc->inexact_to_exact_symbol, T_REAL)); } return(x); } @@ -13592,8 +13652,8 @@ static bool s7_is_zero(s7_pointer x) static bool s7_is_one(s7_pointer x) { - return(((is_t_integer(x)) && (integer(x) == 1)) || - ((is_t_real(x)) && (real(x) == 1.0))); + return(((is_t_integer(x)) && (integer(x) == 1)) || + ((is_t_real(x)) && (real(x) == 1.0))); } @@ -13953,10 +14013,9 @@ static int dtoa_emit_digits(char* digits, int ndigits, char* dest, int K, bool n exp -= dec * 10; } else - { - if (cent) - dest[idx++] = '0'; - } + if (cent) + dest[idx++] = '0'; + dest[idx++] = exp % 10 + '0'; return(idx); } @@ -14730,10 +14789,8 @@ static void backchar(char c, s7_pointer pt) if (is_file_port(pt)) ungetc(c, port_file(pt)); else - { - if (port_position(pt) > 0) - port_position(pt)--; - } + if (port_position(pt) > 0) + port_position(pt)--; } static void resize_strbuf(s7_scheme *sc, s7_int needed_size) @@ -14755,7 +14812,7 @@ static s7_pointer unknown_sharp_constant(s7_scheme *sc, char *name, s7_pointer p bool old_history_enabled; old_history_enabled = s7_set_history_enabled(sc, false); /* see sc->error_hook for a more robust way to handle this */ - result = s7_call(sc, sc->read_error_hook, list_2(sc, sc->T, s7_make_string_wrapper(sc, name))); + result = s7_call(sc, sc->read_error_hook, set_plist_2(sc, sc->T, s7_make_string_wrapper(sc, name))); s7_set_history_enabled(sc, old_history_enabled); if (result != sc->unspecified) return(result); @@ -15323,10 +15380,9 @@ static s7_double string_to_double_with_radix_1(const char *ur_str, int32_t radix frac_part = digits[(int32_t)(*str++)] + (frac_part * radix); }} else - { - while (str <= fend) - frac_part = digits[(int32_t)(*str++)] + (frac_part * radix); - } + while (str <= fend) + frac_part = digits[(int32_t)(*str++)] + (frac_part * radix); + dval += frac_part * dpow(radix, exponent - frac_len); /* 0.6: frac: 6, exp: 0.10000000000000000555, val: 0.60000000000000008882 @@ -15986,7 +16042,7 @@ static inline s7_pointer abs_p_p(s7_scheme *sc, s7_pointer x) #endif default: - return(method_or_bust_one_arg(sc, x, sc->abs_symbol, list_1(sc, x), T_REAL)); + return(method_or_bust_one_arg_p(sc, x, sc->abs_symbol, T_REAL)); } } @@ -15994,6 +16050,9 @@ static s7_pointer g_abs(s7_scheme *sc, s7_pointer args) { #define H_abs "(abs x) returns the absolute value of the real number x" #define Q_abs s7_make_signature(sc, 2, sc->is_real_symbol, sc->is_real_symbol) + s7_pointer x; + x = car(args); + if (is_t_integer(x)) {if (integer(x) >= 0) return(x); if (integer(x) > S7_INT64_MIN) return(make_integer(sc, -integer(x)));} return(abs_p_p(sc, car(args))); } @@ -16048,7 +16107,7 @@ static s7_pointer magnitude_p_p(s7_scheme *sc, s7_pointer x) #endif default: - return(method_or_bust_with_type_one_arg(sc, x, sc->magnitude_symbol, list_1(sc, x), a_number_string)); + return(method_or_bust_with_type_one_arg_p(sc, x, sc->magnitude_symbol, a_number_string)); } } @@ -16992,7 +17051,7 @@ static s7_pointer sin_p_p(s7_scheme *sc, s7_pointer x) #endif default: - return(method_or_bust_with_type_one_arg(sc, x, sc->sin_symbol, list_1(sc, x), a_number_string)); + return(method_or_bust_with_type_one_arg_p(sc, x, sc->sin_symbol, a_number_string)); } /* sin is inaccurate over about 1e30. There's a way to get true results, but it involves fancy "range reduction" techniques. * (sin 1e32): 0.5852334864823946 @@ -17105,7 +17164,7 @@ static s7_pointer cos_p_p(s7_scheme *sc, s7_pointer x) #endif default: - return(method_or_bust_with_type_one_arg(sc, x, sc->cos_symbol, list_1(sc, x), a_number_string)); + return(method_or_bust_with_type_one_arg_p(sc, x, sc->cos_symbol, a_number_string)); } } @@ -17206,7 +17265,7 @@ static s7_pointer tan_p_p(s7_scheme *sc, s7_pointer x) #endif default: - return(method_or_bust_with_type_one_arg(sc, x, sc->tan_symbol, list_1(sc, x), a_number_string)); + return(method_or_bust_with_type_one_arg_p(sc, x, sc->tan_symbol, a_number_string)); } } @@ -17306,7 +17365,7 @@ static s7_pointer g_asin(s7_scheme *sc, s7_pointer args) #endif default: - return(method_or_bust_with_type_one_arg(sc, p, sc->asin_symbol, list_1(sc, p), a_number_string)); + return(method_or_bust_with_type_one_arg_p(sc, p, sc->asin_symbol, a_number_string)); } } @@ -17402,7 +17461,7 @@ static s7_pointer g_acos(s7_scheme *sc, s7_pointer args) #endif default: - return(method_or_bust_with_type_one_arg(sc, p, sc->acos_symbol, list_1(sc, p), a_number_string)); + return(method_or_bust_with_type_one_arg_p(sc, p, sc->acos_symbol, a_number_string)); } } @@ -17791,7 +17850,7 @@ static s7_pointer g_asinh(s7_scheme *sc, s7_pointer args) #endif default: - return(method_or_bust_with_type_one_arg(sc, x, sc->asinh_symbol, list_1(sc, x), a_number_string)); + return(method_or_bust_with_type_one_arg_p(sc, x, sc->asinh_symbol, a_number_string)); } } @@ -17851,7 +17910,7 @@ static s7_pointer g_acosh(s7_scheme *sc, s7_pointer args) #endif default: - return(method_or_bust_with_type_one_arg(sc, x, sc->acosh_symbol, list_1(sc, x), a_number_string)); + return(method_or_bust_with_type_one_arg_p(sc, x, sc->acosh_symbol, a_number_string)); } } @@ -17921,7 +17980,7 @@ static s7_pointer g_atanh(s7_scheme *sc, s7_pointer args) #endif default: - return(method_or_bust_with_type_one_arg(sc, x, sc->atanh_symbol, list_1(sc, x), a_number_string)); + return(method_or_bust_with_type_one_arg_p(sc, x, sc->atanh_symbol, a_number_string)); } } @@ -18057,7 +18116,7 @@ static s7_pointer sqrt_p_p(s7_scheme *sc, s7_pointer p) #endif default: - return(method_or_bust_with_type_one_arg(sc, p, sc->sqrt_symbol, list_1(sc, p), a_number_string)); + return(method_or_bust_with_type_one_arg_p(sc, p, sc->sqrt_symbol, a_number_string)); } } @@ -18126,10 +18185,8 @@ static s7_pointer big_expt(s7_scheme *sc, s7_pointer args) return(division_by_zero_error(sc, sc->expt_symbol, args)); } else - { - if (s7_is_negative(real_part_p_p(sc, y))) /* handle big_complex as well as complex */ - return(division_by_zero_error(sc, sc->expt_symbol, args)); - } + if (s7_is_negative(real_part_p_p(sc, y))) /* handle big_complex as well as complex */ + return(division_by_zero_error(sc, sc->expt_symbol, args)); if ((s7_is_rational(x)) && (s7_is_rational(y))) @@ -18560,11 +18617,10 @@ static s7_pointer big_lcm(s7_scheme *sc, s7_int num, s7_int den, s7_pointer args return(wrong_type_argument_with_type(sc, sc->lcm_symbol, position_of(x, args), rat, a_rational_string)); default: - { - s7_pointer lst; - lst = cons(sc, mpz_to_rational(sc, sc->mpz_3, sc->mpz_4), x); - return(method_or_bust_with_type(sc, rat, sc->lcm_symbol, lst, a_rational_string, position_of(x, args))); - }}} + return(method_or_bust_with_type(sc, rat, sc->lcm_symbol, + set_ulist_1(sc, mpz_to_rational(sc, sc->mpz_3, sc->mpz_4), x), + a_rational_string, position_of(x, args))); + }} return(mpz_to_rational(sc, sc->mpz_3, sc->mpz_4)); } #endif @@ -18618,7 +18674,7 @@ static s7_pointer g_lcm(s7_scheme *sc, s7_pointer args) s7_pointer f; f = find_method_with_let(sc, x1, sc->is_rational_symbol); if ((f == sc->undefined) || - (is_false(sc, call_method(sc, x1, f, cons(sc, x1, sc->nil))))) + (is_false(sc, call_method(sc, x1, f, set_plist_1(sc, x1))))) return(wrong_type_argument_with_type(sc, sc->lcm_symbol, position_of(p, args), x1, a_rational_string)); } else return(wrong_type_argument_with_type(sc, sc->lcm_symbol, position_of(p, args), x1, a_rational_string)); @@ -18688,7 +18744,8 @@ static s7_pointer g_lcm(s7_scheme *sc, s7_pointer args) return(wrong_type_argument_with_type(sc, sc->lcm_symbol, position_of(p, args), x, a_rational_string)); default: - return(method_or_bust_with_type(sc, x, sc->lcm_symbol, cons(sc, (d <= 1) ? make_integer(sc, n) : s7_make_ratio(sc, n, d), p), + return(method_or_bust_with_type(sc, x, sc->lcm_symbol, + set_ulist_1(sc, (d <= 1) ? make_integer(sc, n) : s7_make_ratio(sc, n, d), p), a_rational_string, position_of(p, args))); }} @@ -18737,11 +18794,10 @@ static s7_pointer big_gcd(s7_scheme *sc, s7_int num, s7_int den, s7_pointer args return(wrong_type_argument_with_type(sc, sc->gcd_symbol, position_of(x, args), rat, a_rational_string)); default: - { - s7_pointer lst; - lst = cons(sc, mpz_to_rational(sc, sc->mpz_3, sc->mpz_4), x); - return(method_or_bust_with_type(sc, rat, sc->gcd_symbol, lst, a_rational_string, position_of(x, args))); - }}} + return(method_or_bust_with_type(sc, rat, sc->gcd_symbol, + set_ulist_1(sc, mpz_to_rational(sc, sc->mpz_3, sc->mpz_4), x), + a_rational_string, position_of(x, args))); + }} return(mpz_to_rational(sc, sc->mpz_3, sc->mpz_4)); } #endif @@ -18816,7 +18872,8 @@ static s7_pointer g_gcd(s7_scheme *sc, s7_pointer args) return(wrong_type_argument_with_type(sc, sc->gcd_symbol, position_of(p, args), x, a_rational_string)); default: - return(method_or_bust_with_type(sc, x, sc->gcd_symbol, cons(sc, (d <= 1) ? make_integer(sc, n) : s7_make_ratio(sc, n, d), p), + return(method_or_bust_with_type(sc, x, sc->gcd_symbol, + set_ulist_1(sc, (d <= 1) ? make_integer(sc, n) : s7_make_ratio(sc, n, d), p), a_rational_string, position_of(p, args))); }} return((d <= 1) ? make_integer(sc, n) : make_simple_ratio(sc, n, d)); @@ -18890,7 +18947,7 @@ static s7_pointer floor_p_p(s7_scheme *sc, s7_pointer x) return(s7_wrong_type_arg_error(sc, "floor", 0, x, "a real number")); default: - return(method_or_bust_one_arg(sc, x, sc->floor_symbol, list_1(sc, x), T_REAL)); + return(method_or_bust_one_arg_p(sc, x, sc->floor_symbol, T_REAL)); } } @@ -18918,10 +18975,7 @@ static s7_int floor_i_7p(s7_scheme *sc, s7_pointer p) if (is_t_integer(p)) return(integer(p)); if (is_t_real(p)) return(floor_i_7d(sc, real(p))); if (is_t_ratio(p)) return((s7_int)(floor(fraction(p)))); - if (has_active_methods(sc, p)) - return(s7_integer_checked(sc, find_and_apply_method(sc, p, sc->floor_symbol, list_1(sc, p)))); - s7_wrong_type_arg_error(sc, "floor", 0, p, "a real number"); - return(0); + return(s7_integer_checked(sc, method_or_bust_p(sc, p, sc->floor_symbol, T_REAL))); } #endif @@ -19011,10 +19065,7 @@ static s7_int ceiling_i_7p(s7_scheme *sc, s7_pointer p) if (is_t_integer(p)) return(integer(p)); if (is_t_real(p)) return(ceiling_i_7d(sc, real(p))); if (is_t_ratio(p)) return((s7_int)(ceil(fraction(p)))); - if (has_active_methods(sc, p)) - return(s7_integer_checked(sc, find_and_apply_method(sc, p, sc->ceiling_symbol, list_1(sc, p)))); - s7_wrong_type_arg_error(sc, "ceiling", 0, p, "a real number"); - return(0); + return(s7_integer_checked(sc, method_or_bust_p(sc, p, sc->ceiling_symbol, T_REAL))); } #endif @@ -19072,7 +19123,7 @@ static s7_pointer truncate_p_p(s7_scheme *sc, s7_pointer x) #endif case T_COMPLEX: default: - return(method_or_bust_one_arg(sc, x, sc->truncate_symbol, list_1(sc, x), T_REAL)); + return(method_or_bust_one_arg_p(sc, x, sc->truncate_symbol, T_REAL)); } } @@ -19180,11 +19231,10 @@ static s7_pointer g_round(s7_scheme *sc, s7_pointer args) mpz_add(sc->mpz_1, sc->mpz_1, sc->mpz_2); else { - if (rnd == 0) - { - if (mpz_odd_p(sc->mpz_1)) - mpz_add_ui(sc->mpz_1, sc->mpz_1, 1); - }} + if ((rnd == 0) && + (mpz_odd_p(sc->mpz_1))) + mpz_add_ui(sc->mpz_1, sc->mpz_1, 1); + } return(mpz_to_integer(sc, sc->mpz_1)); } @@ -19269,6 +19319,7 @@ static s7_pointer integer_ratio_add_if_overflow_to_real_or_rational(s7_scheme *s } #define parcel_out_fractions(X, Y) do {d1 = denominator(x); n1 = numerator(x); d2 = denominator(y); n2 = numerator(y);} while (0) +/* add_out_x|y here (as in lt_out_x|y) gives a small speed-up, say 3-7 callgrind units, about 2% */ static s7_pointer add_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) { @@ -19311,7 +19362,7 @@ static s7_pointer add_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) return(mpc_to_number(sc, sc->mpc_1)); #endif default: - return(method_or_bust_with_type(sc, y, sc->add_symbol, list_2(sc, x, y), a_number_string, 2)); + return(method_or_bust_with_type_pp(sc, y, sc->add_symbol, x, y, a_number_string, 2)); } case T_RATIO: @@ -19392,7 +19443,7 @@ static s7_pointer add_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) return(mpc_to_number(sc, sc->mpc_1)); #endif default: - return(method_or_bust_with_type(sc, y, sc->add_symbol, list_2(sc, x, y), a_number_string, 2)); + return(method_or_bust_with_type_pp(sc, y, sc->add_symbol, x, y, a_number_string, 2)); } case T_REAL: @@ -19432,7 +19483,7 @@ static s7_pointer add_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) return(mpc_to_number(sc, sc->mpc_1)); #endif default: - return(method_or_bust_with_type(sc, y, sc->add_symbol, list_2(sc, x, y), a_number_string, 2)); + return(method_or_bust_with_type_pp(sc, y, sc->add_symbol, x, y, a_number_string, 2)); } case T_COMPLEX: @@ -19467,7 +19518,7 @@ static s7_pointer add_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) return(mpc_to_number(sc, sc->mpc_1)); #endif default: - return(method_or_bust_with_type(sc, y, sc->add_symbol, list_2(sc, x, y), a_number_string, 2)); + return(method_or_bust_with_type_pp(sc, y, sc->add_symbol, x, y, a_number_string, 2)); } #if WITH_GMP @@ -19509,7 +19560,7 @@ static s7_pointer add_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) mpc_add(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); return(mpc_to_number(sc, sc->mpc_1)); default: - return(method_or_bust_with_type(sc, y, sc->add_symbol, list_2(sc, x, y), a_number_string, 2)); + return(method_or_bust_with_type_pp(sc, y, sc->add_symbol, x, y, a_number_string, 2)); } case T_BIG_RATIO: @@ -19550,7 +19601,7 @@ static s7_pointer add_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) mpc_add(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); return(mpc_to_number(sc, sc->mpc_1)); default: - return(method_or_bust_with_type(sc, y, sc->add_symbol, list_2(sc, x, y), a_number_string, 2)); + return(method_or_bust_with_type_pp(sc, y, sc->add_symbol, x, y, a_number_string, 2)); } case T_BIG_REAL: @@ -19584,7 +19635,7 @@ static s7_pointer add_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) mpc_add_fr(sc->mpc_1, big_complex(y), big_real(x), MPC_RNDNN); return(mpc_to_number(sc, sc->mpc_1)); default: - return(method_or_bust_with_type(sc, y, sc->add_symbol, list_2(sc, x, y), a_number_string, 2)); + return(method_or_bust_with_type_pp(sc, y, sc->add_symbol, x, y, a_number_string, 2)); } case T_BIG_COMPLEX: switch (type(y)) @@ -19622,11 +19673,11 @@ static s7_pointer add_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) mpc_add(sc->mpc_1, big_complex(x), big_complex(y), MPC_RNDNN); return(mpc_to_number(sc, sc->mpc_1)); default: - return(method_or_bust_with_type(sc, y, sc->add_symbol, list_2(sc, x, y), a_number_string, 2)); + return(method_or_bust_with_type_pp(sc, y, sc->add_symbol, x, y, a_number_string, 2)); } #endif default: - return(method_or_bust_with_type(sc, x, sc->add_symbol, list_2(sc, x, y), a_number_string, 1)); + return(method_or_bust_with_type_pp(sc, x, sc->add_symbol, x, y, a_number_string, 1)); } } @@ -19738,7 +19789,7 @@ static s7_pointer g_add_x1(s7_scheme *sc, s7_pointer args) case T_RATIO: return(add_p_pp(sc, x, int_one)); case T_REAL: return(make_real(sc, real(x) + 1.0)); case T_COMPLEX: return(s7_make_complex(sc, real_part(x) + 1.0, imag_part(x))); - default: return(method_or_bust_with_type(sc, x, sc->add_symbol, list_2(sc, x, int_one), a_number_string, 1)); + default: return(method_or_bust_with_type_pp(sc, x, sc->add_symbol, x, int_one, a_number_string, 1)); } return(x); } @@ -19765,8 +19816,7 @@ static s7_pointer g_add_xi(s7_scheme *sc, s7_pointer x, s7_int y) case T_BIG_COMPLEX: return(add_p_pp(sc, x, wrap_integer1(sc, y))); #endif - default: - return(method_or_bust_with_type(sc, x, sc->add_symbol, list_2(sc, x, make_integer(sc, y)), a_number_string, 1)); + default: return(method_or_bust_with_type_pi(sc, x, sc->add_symbol, x, y, a_number_string)); } return(x); } @@ -19783,8 +19833,7 @@ static s7_pointer g_add_xf(s7_scheme *sc, s7_pointer x, s7_double y) case T_BIG_INTEGER: case T_BIG_RATIO: case T_BIG_REAL: case T_BIG_COMPLEX: return(add_p_pp(sc, x, wrap_real1(sc, y))); #endif - default: - return(method_or_bust_with_type(sc, x, sc->add_symbol, list_2(sc, x, make_real(sc, y)), a_number_string, 1)); + default: return(method_or_bust_with_type_pf(sc, x, sc->add_symbol, x, y, a_number_string)); } return(x); } @@ -19877,10 +19926,8 @@ static s7_pointer argument_type(s7_scheme *sc, s7_pointer arg1) /* perhaps add closure sig if we can depend on it (immutable func etc) */ } else - { - if (!is_symbol(arg1)) - return(s7_type_of(sc, arg1)); - } + if (!is_symbol(arg1)) + return(s7_type_of(sc, arg1)); return(NULL); } @@ -19993,7 +20040,7 @@ static s7_pointer negate_p_p(s7_scheme *sc, s7_pointer p) /* can't use "nega #endif default: - return(method_or_bust_with_type(sc, p, sc->subtract_symbol, list_1(sc, p), a_number_string, 1)); + return(method_or_bust_with_type_one_arg_p(sc, p, sc->subtract_symbol, a_number_string)); } } @@ -20083,7 +20130,7 @@ static s7_pointer subtract_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) return(mpc_to_number(sc, sc->mpc_1)); #endif default: - return(method_or_bust_with_type(sc, y, sc->subtract_symbol, list_2(sc, x, y), a_number_string, 2)); + return(method_or_bust_with_type_pp(sc, y, sc->subtract_symbol, x, y, a_number_string, 2)); } case T_RATIO: @@ -20186,7 +20233,7 @@ static s7_pointer subtract_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) return(mpc_to_number(sc, sc->mpc_1)); #endif default: - return(method_or_bust_with_type(sc, y, sc->subtract_symbol, list_2(sc, x, y), a_number_string, 2)); + return(method_or_bust_with_type_pp(sc, y, sc->subtract_symbol, x, y, a_number_string, 2)); } case T_REAL: @@ -20226,7 +20273,7 @@ static s7_pointer subtract_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) return(mpc_to_number(sc, sc->mpc_1)); #endif default: - return(method_or_bust_with_type(sc, y, sc->subtract_symbol, list_2(sc, x, y), a_number_string, 2)); + return(method_or_bust_with_type_pp(sc, y, sc->subtract_symbol, x, y, a_number_string, 2)); } case T_COMPLEX: @@ -20261,7 +20308,7 @@ static s7_pointer subtract_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) return(mpc_to_number(sc, sc->mpc_1)); #endif default: - return(method_or_bust_with_type(sc, y, sc->subtract_symbol, list_2(sc, x, y), a_number_string, 2)); + return(method_or_bust_with_type_pp(sc, y, sc->subtract_symbol, x, y, a_number_string, 2)); } #if WITH_GMP @@ -20304,7 +20351,7 @@ static s7_pointer subtract_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) mpc_sub(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); return(mpc_to_number(sc, sc->mpc_1)); default: - return(method_or_bust_with_type(sc, y, sc->subtract_symbol, list_2(sc, x, y), a_number_string, 2)); + return(method_or_bust_with_type_pp(sc, y, sc->subtract_symbol, x, y, a_number_string, 2)); } case T_BIG_RATIO: @@ -20346,7 +20393,7 @@ static s7_pointer subtract_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) mpc_sub(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); return(mpc_to_number(sc, sc->mpc_1)); default: - return(method_or_bust_with_type(sc, y, sc->subtract_symbol, list_2(sc, x, y), a_number_string, 2)); + return(method_or_bust_with_type_pp(sc, y, sc->subtract_symbol, x, y, a_number_string, 2)); } case T_BIG_REAL: @@ -20380,7 +20427,7 @@ static s7_pointer subtract_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) mpc_fr_sub(sc->mpc_1, big_real(x), big_complex(y), MPC_RNDNN); return(mpc_to_number(sc, sc->mpc_1)); default: - return(method_or_bust_with_type(sc, y, sc->subtract_symbol, list_2(sc, x, y), a_number_string, 2)); + return(method_or_bust_with_type_pp(sc, y, sc->subtract_symbol, x, y, a_number_string, 2)); } case T_BIG_COMPLEX: switch (type(y)) @@ -20418,11 +20465,11 @@ static s7_pointer subtract_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) mpc_sub(sc->mpc_1, big_complex(x), big_complex(y), MPC_RNDNN); return(mpc_to_number(sc, sc->mpc_1)); default: - return(method_or_bust_with_type(sc, y, sc->subtract_symbol, list_2(sc, x, y), a_number_string, 2)); + return(method_or_bust_with_type_pp(sc, y, sc->subtract_symbol, x, y, a_number_string, 2)); } #endif default: - return(method_or_bust_with_type(sc, x, sc->subtract_symbol, list_2(sc, x, y), a_number_string, 1)); + return(method_or_bust_with_type_pp(sc, x, sc->subtract_symbol, x, y, a_number_string, 1)); } } @@ -20459,7 +20506,7 @@ static s7_pointer minus_c1(s7_scheme *sc, s7_pointer x) return(subtract_p_pp(sc, x, int_one)); #endif default: - return(method_or_bust_with_type(sc, x, sc->subtract_symbol, list_2(sc, x, int_one), a_number_string, 1)); + return(method_or_bust_with_type_pp(sc, x, sc->subtract_symbol, x, int_one, a_number_string, 1)); } return(x); } @@ -20554,8 +20601,7 @@ static s7_pointer g_sub_xi(s7_scheme *sc, s7_pointer x, s7_int y) case T_BIG_COMPLEX: return(subtract_p_pp(sc, x, wrap_integer1(sc, y))); #endif - default: - return(method_or_bust_with_type(sc, x, sc->subtract_symbol, list_2(sc, x, make_integer(sc, y)), a_number_string, 1)); + default: return(method_or_bust_with_type_pi(sc, x, sc->subtract_symbol, x, y, a_number_string)); } return(x); } @@ -20671,7 +20717,7 @@ static s7_pointer multiply_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) return(mpc_to_number(sc, sc->mpc_1)); /* x might be 0 */ #endif default: - return(method_or_bust_with_type(sc, y, sc->multiply_symbol, list_2(sc, x, y), a_number_string, 2)); + return(method_or_bust_with_type_pp(sc, y, sc->multiply_symbol, x, y, a_number_string, 2)); } case T_RATIO: @@ -20741,7 +20787,7 @@ static s7_pointer multiply_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) return(mpc_to_number(sc, sc->mpc_1)); #endif default: - return(method_or_bust_with_type(sc, y, sc->multiply_symbol, list_2(sc, x, y), a_number_string, 2)); + return(method_or_bust_with_type_pp(sc, y, sc->multiply_symbol, x, y, a_number_string, 2)); } case T_REAL: @@ -20791,7 +20837,7 @@ static s7_pointer multiply_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) return(mpc_to_number(sc, sc->mpc_1)); /* x might = 0.0 */ #endif default: - return(method_or_bust_with_type(sc, y, sc->multiply_symbol, list_2(sc, x, y), a_number_string, 2)); + return(method_or_bust_with_type_pp(sc, y, sc->multiply_symbol, x, y, a_number_string, 2)); } case T_COMPLEX: @@ -20833,7 +20879,7 @@ static s7_pointer multiply_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) return(mpc_to_number(sc, sc->mpc_1)); #endif default: - return(method_or_bust_with_type(sc, y, sc->multiply_symbol, list_2(sc, x, y), a_number_string, 2)); + return(method_or_bust_with_type_pp(sc, y, sc->multiply_symbol, x, y, a_number_string, 2)); } #if WITH_GMP @@ -20874,7 +20920,7 @@ static s7_pointer multiply_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) mpc_mul(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); return(mpc_to_number(sc, sc->mpc_1)); default: - return(method_or_bust_with_type(sc, y, sc->multiply_symbol, list_2(sc, x, y), a_number_string, 2)); + return(method_or_bust_with_type_pp(sc, y, sc->multiply_symbol, x, y, a_number_string, 2)); } case T_BIG_RATIO: @@ -20915,7 +20961,7 @@ static s7_pointer multiply_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) mpc_mul(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); return(mpc_to_number(sc, sc->mpc_1)); default: - return(method_or_bust_with_type(sc, y, sc->multiply_symbol, list_2(sc, x, y), a_number_string, 2)); + return(method_or_bust_with_type_pp(sc, y, sc->multiply_symbol, x, y, a_number_string, 2)); } case T_BIG_REAL: @@ -20949,7 +20995,7 @@ static s7_pointer multiply_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) mpc_mul_fr(sc->mpc_1, big_complex(y), big_real(x), MPC_RNDNN); return(mpc_to_number(sc, sc->mpc_1)); /* 0.0? */ default: - return(method_or_bust_with_type(sc, y, sc->multiply_symbol, list_2(sc, x, y), a_number_string, 2)); + return(method_or_bust_with_type_pp(sc, y, sc->multiply_symbol, x, y, a_number_string, 2)); } case T_BIG_COMPLEX: switch (type(y)) @@ -20986,11 +21032,11 @@ static s7_pointer multiply_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) mpc_mul(sc->mpc_1, big_complex(x), big_complex(y), MPC_RNDNN); return(mpc_to_number(sc, sc->mpc_1)); default: - return(method_or_bust_with_type(sc, y, sc->multiply_symbol, list_2(sc, x, y), a_number_string, 2)); + return(method_or_bust_with_type_pp(sc, y, sc->multiply_symbol, x, y, a_number_string, 2)); } #endif default: - return(method_or_bust_with_type(sc, x, sc->multiply_symbol, list_2(sc, x, y), a_number_string, 1)); + return(method_or_bust_with_type_pp(sc, x, sc->multiply_symbol, x, y, a_number_string, 1)); } } @@ -21053,7 +21099,7 @@ static s7_pointer g_mul_xi(s7_scheme *sc, s7_pointer x, s7_int n) #endif default: /* we can get here from mul_2_xi for example so the non-integer argument might not be a symbol */ - return(method_or_bust_with_type(sc, x, sc->multiply_symbol, list_2(sc, x, make_integer(sc, n)), a_number_string, 1)); + return(method_or_bust_with_type_pi(sc, x, sc->multiply_symbol, x, n, a_number_string)); } return(x); } @@ -21083,8 +21129,7 @@ static s7_pointer g_mul_xf(s7_scheme *sc, s7_pointer x, s7_double y) mpc_mul_fr(sc->mpc_1, big_complex(x), sc->mpfr_1, MPC_RNDNN); return(mpc_to_number(sc, sc->mpc_1)); #endif - default: - return(method_or_bust_with_type(sc, x, sc->multiply_symbol, list_2(sc, make_real(sc, y), x), a_number_string, 1)); + default: return(method_or_bust_with_type_pf(sc, x, sc->multiply_symbol, x, y, a_number_string)); } return(x); } @@ -21267,7 +21312,7 @@ static s7_pointer invert_p_p(s7_scheme *sc, s7_pointer p) return(mpc_to_number(sc, sc->mpc_1)); /* x might be 0+0i if real-part is inf? */ #endif default: - check_method(sc, p, sc->divide_symbol, list_1(sc, p)); + check_method(sc, p, sc->divide_symbol, set_plist_1(sc, p)); return(wrong_type_argument_with_type(sc, sc->divide_symbol, 1, p, a_number_string)); } } @@ -21365,7 +21410,7 @@ static s7_pointer divide_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) #endif default: - return(method_or_bust_with_type(sc, y, sc->divide_symbol, list_2(sc, x, y), a_number_string, 2)); + return(method_or_bust_with_type_pp(sc, y, sc->divide_symbol, x, y, a_number_string, 2)); } break; @@ -21467,7 +21512,7 @@ static s7_pointer divide_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) return(mpc_to_number(sc, sc->mpc_1)); #endif default: - return(method_or_bust_with_type(sc, y, sc->divide_symbol, list_2(sc, x, y), a_number_string, 2)); + return(method_or_bust_with_type_pp(sc, y, sc->divide_symbol, x, y, a_number_string, 2)); } /* -------- real x -------- */ @@ -21533,7 +21578,7 @@ static s7_pointer divide_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) return(mpc_to_number(sc, sc->mpc_1)); #endif default: - return(method_or_bust_with_type(sc, y, sc->divide_symbol, list_2(sc, x, y), a_number_string, 2)); + return(method_or_bust_with_type_pp(sc, y, sc->divide_symbol, x, y, a_number_string, 2)); } /* -------- complex x -------- */ @@ -21609,7 +21654,7 @@ static s7_pointer divide_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) #endif default: - return(method_or_bust_with_type(sc, y, sc->divide_symbol, list_2(sc, x, y), a_number_string, 2)); + return(method_or_bust_with_type_pp(sc, y, sc->divide_symbol, x, y, a_number_string, 2)); } #if WITH_GMP @@ -21670,7 +21715,7 @@ static s7_pointer divide_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) mpc_div(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); return(mpc_to_number(sc, sc->mpc_1)); default: - return(method_or_bust_with_type(sc, y, sc->divide_symbol, list_2(sc, x, y), a_number_string, 2)); + return(method_or_bust_with_type_pp(sc, y, sc->divide_symbol, x, y, a_number_string, 2)); } case T_BIG_RATIO: switch (type(y)) @@ -21724,7 +21769,7 @@ static s7_pointer divide_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) mpc_div(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); return(mpc_to_number(sc, sc->mpc_1)); default: - return(method_or_bust_with_type(sc, y, sc->divide_symbol, list_2(sc, x, y), a_number_string, 2)); + return(method_or_bust_with_type_pp(sc, y, sc->divide_symbol, x, y, a_number_string, 2)); } case T_BIG_REAL: switch (type(y)) @@ -21770,7 +21815,7 @@ static s7_pointer divide_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) mpc_fr_div(sc->mpc_1, big_real(x), big_complex(y), MPC_RNDNN); return(mpc_to_number(sc, sc->mpc_1)); default: - return(method_or_bust_with_type(sc, y, sc->divide_symbol, list_2(sc, x, y), a_number_string, 2)); + return(method_or_bust_with_type_pp(sc, y, sc->divide_symbol, x, y, a_number_string, 2)); } case T_BIG_COMPLEX: switch (type(y)) @@ -21821,13 +21866,13 @@ static s7_pointer divide_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) mpc_div(sc->mpc_1, big_complex(x), big_complex(y), MPC_RNDNN); return(mpc_to_number(sc, sc->mpc_1)); default: - return(method_or_bust_with_type(sc, y, sc->divide_symbol, list_2(sc, x, y), a_number_string, 2)); + return(method_or_bust_with_type_pp(sc, y, sc->divide_symbol, x, y, a_number_string, 2)); } #endif /* x is not a built-in number */ default: - return(method_or_bust_with_type(sc, x, sc->divide_symbol, list_2(sc, x, y), a_number_string, 1)); /* not args here! y = apply * to cdr(args) */ + return(method_or_bust_with_type_pp(sc, x, sc->divide_symbol, x, y, a_number_string, 1)); /* not args here! y = apply * to cdr(args) */ } return(NULL); /* make the compiler happy */ @@ -21929,7 +21974,7 @@ static s7_pointer g_divide_by_2(s7_scheme *sc, s7_pointer args) return(mpc_to_number(sc, sc->mpc_1)); #endif default: - return(method_or_bust_with_type(sc, num, sc->divide_symbol, list_2(sc, num, int_two), a_number_string, 1)); + return(method_or_bust_with_type_pp(sc, num, sc->divide_symbol, num, int_two, a_number_string, 1)); } } @@ -22048,7 +22093,7 @@ static s7_pointer quotient_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) }} return(mpz_to_integer(sc, sc->mpz_1)); } - return(method_or_bust(sc, (s7_is_real(x)) ? y : x, sc->quotient_symbol, list_2(sc, x, y), T_REAL, (s7_is_real(x)) ? 2 : 1)); + return(method_or_bust_pp(sc, (s7_is_real(x)) ? y : x, sc->quotient_symbol, x, y, T_REAL, (s7_is_real(x)) ? 2 : 1)); #else s7_int d1, d2, n1, n2; @@ -22079,7 +22124,7 @@ static s7_pointer quotient_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) return(s7_truncate(sc, sc->quotient_symbol, (s7_double)integer(x) / real(y))); /* s7_truncate returns an integer */ default: - return(method_or_bust(sc, y, sc->quotient_symbol, list_2(sc, x, y), T_REAL, 2)); + return(method_or_bust_pp(sc, y, sc->quotient_symbol, x, y, T_REAL, 2)); } case T_RATIO: @@ -22125,7 +22170,7 @@ static s7_pointer quotient_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) return(s7_truncate(sc, sc->quotient_symbol, (s7_double)fraction(x) / real(y))); default: - return(method_or_bust(sc, y, sc->quotient_symbol, list_2(sc, x, y), T_REAL, 2)); + return(method_or_bust_pp(sc, y, sc->quotient_symbol, x, y, T_REAL, 2)); } case T_REAL: @@ -22145,11 +22190,11 @@ static s7_pointer quotient_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) case T_RATIO: return(s7_truncate(sc, sc->quotient_symbol, real(x) / (s7_double)fraction(y))); case T_REAL: return(make_integer(sc, c_quo_dbl(sc, real(x), real(y)))); /* c_quo_dbl returns an integer */ - default: return(method_or_bust(sc, y, sc->quotient_symbol, list_2(sc, x, y), T_REAL, 2)); + default: return(method_or_bust_pp(sc, y, sc->quotient_symbol, x, y, T_REAL, 2)); } default: - return(method_or_bust(sc, x, sc->quotient_symbol, list_2(sc, x, y), T_REAL, 2)); + return(method_or_bust_pp(sc, x, sc->quotient_symbol, x, y, T_REAL, 2)); } #endif } @@ -22205,7 +22250,7 @@ static s7_pointer big_mod_or_rem(s7_scheme *sc, s7_pointer x, s7_pointer y, bool mpq_canonicalize(sc->mpq_1); return(mpq_to_rational(sc, sc->mpq_1)); } - return(method_or_bust(sc, (s7_is_real(x)) ? y : x, (use_floor) ? sc->modulo_symbol : sc->remainder_symbol, list_2(sc, x, y), T_REAL, (s7_is_real(x)) ? 2 : 1)); + return(method_or_bust_pp(sc, (s7_is_real(x)) ? y : x, (use_floor) ? sc->modulo_symbol : sc->remainder_symbol, x, y, T_REAL, (s7_is_real(x)) ? 2 : 1)); } #endif @@ -22282,7 +22327,7 @@ static s7_pointer remainder_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) return(make_real(sc, integer(x) - real(y) * quo)); default: - return(method_or_bust(sc, y, sc->remainder_symbol, list_2(sc, x, y), T_REAL, 2)); + return(method_or_bust_pp(sc, y, sc->remainder_symbol, x, y, T_REAL, 2)); } case T_RATIO: @@ -22367,7 +22412,7 @@ static s7_pointer remainder_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) } default: - return(method_or_bust(sc, y, sc->remainder_symbol, list_2(sc, x, y), T_REAL, 2)); + return(method_or_bust_pp(sc, y, sc->remainder_symbol, x, y, T_REAL, 2)); } case T_REAL: @@ -22414,11 +22459,11 @@ static s7_pointer remainder_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) */ default: - return(method_or_bust(sc, y, sc->remainder_symbol, list_2(sc, x, y), T_REAL, 2)); + return(method_or_bust_pp(sc, y, sc->remainder_symbol, x, y, T_REAL, 2)); } default: - return(method_or_bust(sc, x, sc->remainder_symbol, list_2(sc, x, y), T_REAL, 1)); + return(method_or_bust_pp(sc, x, sc->remainder_symbol, x, y, T_REAL, 1)); } #endif } @@ -22484,7 +22529,7 @@ static s7_pointer modulo_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) { if (s7_is_real(x)) return(x); - return(method_or_bust(sc, x, sc->modulo_symbol, list_2(sc, x, y), T_REAL, 1)); + return(method_or_bust_pp(sc, x, sc->modulo_symbol, x, y, T_REAL, 1)); } return(big_mod_or_rem(sc, x, y, true)); #else @@ -22518,7 +22563,7 @@ static s7_pointer modulo_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) goto REAL_MOD; default: - return(method_or_bust(sc, y, sc->modulo_symbol, list_2(sc, x, y), T_REAL, 2)); + return(method_or_bust_pp(sc, y, sc->modulo_symbol, x, y, T_REAL, 2)); } case T_RATIO: @@ -22608,7 +22653,7 @@ static s7_pointer modulo_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) return(make_real(sc, a - b * (s7_int)floor(a / b))); default: - return(method_or_bust(sc, y, sc->modulo_symbol, list_2(sc, x, y), T_REAL, 2)); + return(method_or_bust_pp(sc, y, sc->modulo_symbol, x, y, T_REAL, 2)); } case T_REAL: @@ -22616,7 +22661,7 @@ static s7_pointer modulo_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) s7_double c; a = real(x); if (!is_real(y)) - return(method_or_bust(sc, y, sc->modulo_symbol, list_2(sc, x, y), T_REAL, 2)); + return(method_or_bust_pp(sc, y, sc->modulo_symbol, x, y, T_REAL, 2)); if (is_NaN(a)) return(x); if (is_inf(a)) return(real_NaN); /* not b */ if (fabs(a) > 1e17) @@ -22649,11 +22694,11 @@ static s7_pointer modulo_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) return(make_real(sc, a - b * (s7_int)floor(c))); default: - return(method_or_bust(sc, y, sc->modulo_symbol, list_2(sc, x, y), T_REAL, 2)); + return(method_or_bust_pp(sc, y, sc->modulo_symbol, x, y, T_REAL, 2)); }} default: - return(method_or_bust(sc, x, sc->modulo_symbol, list_2(sc, x, y), T_REAL, 1)); + return(method_or_bust_pp(sc, x, sc->modulo_symbol, x, y, T_REAL, 1)); } #endif } @@ -22676,25 +22721,14 @@ static bool is_real_via_method_1(s7_scheme *sc, s7_pointer p) s7_pointer f; f = find_method_with_let(sc, p, sc->is_real_symbol); if (f != sc->undefined) - return(is_true(sc, call_method(sc, p, f, cons(sc, p, sc->nil)))); + return(is_true(sc, call_method(sc, p, f, set_plist_1(sc, p)))); return(false); } #define is_real_via_method(sc, p) ((s7_is_real(p)) || ((has_active_methods(sc, p)) && (is_real_via_method_1(sc, p)))) -static s7_pointer max_out_x(s7_scheme *sc, s7_pointer x, s7_pointer y) -{ - if (has_active_methods(sc, x)) - return(find_and_apply_method(sc, x, sc->max_symbol, list_2(sc, x, y))); - return(simple_wrong_type_argument(sc, sc->max_symbol, x, T_REAL)); -} - -static s7_pointer max_out_y(s7_scheme *sc, s7_pointer x, s7_pointer y) -{ - if (has_active_methods(sc, y)) - return(find_and_apply_method(sc, y, sc->max_symbol, list_2(sc, x, y))); - return(simple_wrong_type_argument(sc, sc->max_symbol, y, T_REAL)); -} +#define max_out_x(Sc, X, Y) method_or_bust_pp(Sc, X, Sc->max_symbol, X, Y, T_REAL, 1) +#define max_out_y(Sc, X, Y) method_or_bust_pp(Sc, Y, Sc->max_symbol, X, Y, T_REAL, 2) static s7_pointer max_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) { @@ -22876,9 +22910,7 @@ static s7_pointer g_max(s7_scheme *sc, s7_pointer args) if (is_null(cdr(args))) { if (s7_is_real(x)) return(x); - if (has_active_methods(sc, x)) - return(find_and_apply_method(sc, x, sc->max_symbol, list_1(sc, x))); - return(wrong_type_argument(sc, sc->max_symbol, 1, x, T_REAL)); + return(method_or_bust_p(sc, x, sc->max_symbol, T_REAL)); } for (p = cdr(args); is_pair(p); p = cdr(p)) x = max_p_pp(sc, x, car(p)); @@ -22894,19 +22926,8 @@ static s7_double max_d_dddd(s7_double x1, s7_double x2, s7_double x3, s7_double /* ---------------------------------------- min ---------------------------------------- */ -static s7_pointer min_out_x(s7_scheme *sc, s7_pointer x, s7_pointer y) -{ - if (has_active_methods(sc, x)) - return(find_and_apply_method(sc, x, sc->min_symbol, list_2(sc, x, y))); - return(simple_wrong_type_argument(sc, sc->min_symbol, x, T_REAL)); -} - -static s7_pointer min_out_y(s7_scheme *sc, s7_pointer x, s7_pointer y) -{ - if (has_active_methods(sc, y)) - return(find_and_apply_method(sc, y, sc->min_symbol, list_2(sc, x, y))); - return(simple_wrong_type_argument(sc, sc->min_symbol, y, T_REAL)); -} +#define min_out_x(Sc, X, Y) method_or_bust_pp(Sc, X, Sc->min_symbol, X, Y, T_REAL, 1) +#define min_out_y(Sc, X, Y) method_or_bust_pp(Sc, Y, Sc->min_symbol, X, Y, T_REAL, 2) static s7_pointer min_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) { @@ -23082,9 +23103,7 @@ static s7_pointer g_min(s7_scheme *sc, s7_pointer args) if (is_null(cdr(args))) { if (s7_is_real(x)) return(x); - if (has_active_methods(sc, x)) - return(find_and_apply_method(sc, x, sc->min_symbol, list_1(sc, x))); - return(wrong_type_argument(sc, sc->min_symbol, 1, x, T_REAL)); + return(method_or_bust_p(sc, x, sc->min_symbol, T_REAL)); } for (p = cdr(args); is_pair(p); p = cdr(p)) x = min_p_pp(sc, x, car(p)); @@ -23103,7 +23122,7 @@ static s7_double min_d_dddd(s7_double x1, s7_double x2, s7_double x3, s7_double static bool eq_out_x(s7_scheme *sc, s7_pointer x, s7_pointer y) { if (has_active_methods(sc, x)) - return(find_and_apply_method(sc, x, sc->num_eq_symbol, list_2(sc, x, y)) != sc->F); + return(find_and_apply_method(sc, x, sc->num_eq_symbol, set_plist_2(sc, x, y)) != sc->F); wrong_type_argument_with_type(sc, sc->num_eq_symbol, 1, x, a_number_string); return(false); } @@ -23111,7 +23130,7 @@ static bool eq_out_x(s7_scheme *sc, s7_pointer x, s7_pointer y) static bool eq_out_y(s7_scheme *sc, s7_pointer x, s7_pointer y) { if (has_active_methods(sc, y)) - return(find_and_apply_method(sc, y, sc->num_eq_symbol, list_2(sc, x, y)) != sc->F); + return(find_and_apply_method(sc, y, sc->num_eq_symbol, set_plist_2(sc, x, y)) != sc->F); wrong_type_argument_with_type(sc, sc->num_eq_symbol, 2, y, a_number_string); return(false); } @@ -23174,8 +23193,7 @@ static bool num_eq_b_7pp(s7_scheme *sc, s7_pointer x, s7_pointer y) case T_BIG_COMPLEX: return(false); #endif - default: - return(eq_out_y(sc, x, y)); + default: return(eq_out_y(sc, x, y)); } break; @@ -23198,8 +23216,7 @@ static bool num_eq_b_7pp(s7_scheme *sc, s7_pointer x, s7_pointer y) case T_BIG_COMPLEX: return(false); #endif - default: - return(eq_out_y(sc, x, y)); + default: return(eq_out_y(sc, x, y)); } break; @@ -23227,8 +23244,7 @@ static bool num_eq_b_7pp(s7_scheme *sc, s7_pointer x, s7_pointer y) case T_BIG_COMPLEX: return(false); #endif - default: - return(eq_out_y(sc, x, y)); + default: return(eq_out_y(sc, x, y)); } break; @@ -23260,8 +23276,7 @@ static bool num_eq_b_7pp(s7_scheme *sc, s7_pointer x, s7_pointer y) return(false); case T_BIG_REAL: return((!mpfr_nan_p(big_real(y))) && (mpfr_cmp_z(big_real(y), big_integer(x)) == 0)); - default: - return(eq_out_y(sc, x, y)); + default: return(eq_out_y(sc, x, y)); } case T_BIG_RATIO: switch (type(y)) @@ -23277,8 +23292,7 @@ static bool num_eq_b_7pp(s7_scheme *sc, s7_pointer x, s7_pointer y) return(false); case T_BIG_REAL: return((!mpfr_nan_p(big_real(y))) && (mpfr_cmp_q(big_real(y), big_ratio(x)) == 0)); - default: - return(eq_out_y(sc, x, y)); + default: return(eq_out_y(sc, x, y)); } case T_BIG_REAL: @@ -23298,8 +23312,7 @@ static bool num_eq_b_7pp(s7_scheme *sc, s7_pointer x, s7_pointer y) return(mpfr_cmp_q(big_real(x), big_ratio(y)) == 0); case T_COMPLEX: case T_BIG_COMPLEX: return(false); - default: - return(eq_out_y(sc, x, y)); + default: return(eq_out_y(sc, x, y)); } case T_BIG_COMPLEX: @@ -23313,13 +23326,11 @@ static bool num_eq_b_7pp(s7_scheme *sc, s7_pointer x, s7_pointer y) return(false); mpc_set_d_d(sc->mpc_1, real_part(y), imag_part(y), MPC_RNDNN); return(mpc_cmp(big_complex(x), sc->mpc_1) == 0); /* NaN's not allowed! */ - default: - return(eq_out_y(sc, x, y)); + default: return(eq_out_y(sc, x, y)); } #endif - default: - return(eq_out_x(sc, x, y)); + default: return(eq_out_x(sc, x, y)); } return(false); } @@ -23333,7 +23344,7 @@ static bool is_number_via_method(s7_scheme *sc, s7_pointer p) s7_pointer f; f = find_method_with_let(sc, p, sc->is_number_symbol); if (f != sc->undefined) - return(is_true(sc, call_method(sc, p, f, cons(sc, p, sc->nil)))); + return(is_true(sc, call_method(sc, p, f, set_plist_1(sc, p)))); } return(false); } @@ -23452,7 +23463,7 @@ static s7_pointer num_eq_chooser(s7_scheme *sc, s7_pointer ur_f, int32_t args, s static bool lt_out_x(s7_scheme *sc, s7_pointer x, s7_pointer y) { if (has_active_methods(sc, x)) - return(find_and_apply_method(sc, x, sc->lt_symbol, list_2(sc, x, y)) != sc->F); + return(find_and_apply_method(sc, x, sc->lt_symbol, set_plist_2(sc, x, y)) != sc->F); wrong_type_argument(sc, sc->lt_symbol, 1, x, T_REAL); return(false); } @@ -23460,7 +23471,7 @@ static bool lt_out_x(s7_scheme *sc, s7_pointer x, s7_pointer y) static bool lt_out_y(s7_scheme *sc, s7_pointer x, s7_pointer y) { if (has_active_methods(sc, y)) - return(find_and_apply_method(sc, y, sc->lt_symbol, list_2(sc, x, y)) != sc->F); + return(find_and_apply_method(sc, y, sc->lt_symbol, set_plist_2(sc, x, y)) != sc->F); wrong_type_argument(sc, sc->lt_symbol, 2, y, T_REAL); return(false); } @@ -23595,8 +23606,7 @@ static bool lt_b_7pp(s7_scheme *sc, s7_pointer x, s7_pointer y) } #endif - default: - return(lt_out_x(sc, x, y)); + default: return(lt_out_x(sc, x, y)); } return(true); } @@ -23766,10 +23776,11 @@ static s7_pointer less_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_poi /* ---------------------------------------- <= ---------------------------------------- */ + static bool leq_out_x(s7_scheme *sc, s7_pointer x, s7_pointer y) { if (has_active_methods(sc, x)) - return(find_and_apply_method(sc, x, sc->leq_symbol, list_2(sc, x, y)) != sc->F); + return(find_and_apply_method(sc, x, sc->leq_symbol, set_plist_2(sc, x, y)) != sc->F); wrong_type_argument(sc, sc->leq_symbol, 1, x, T_REAL); return(false); } @@ -23777,7 +23788,7 @@ static bool leq_out_x(s7_scheme *sc, s7_pointer x, s7_pointer y) static bool leq_out_y(s7_scheme *sc, s7_pointer x, s7_pointer y) { if (has_active_methods(sc, y)) - return(find_and_apply_method(sc, y, sc->leq_symbol, list_2(sc, x, y)) != sc->F); + return(find_and_apply_method(sc, y, sc->leq_symbol, set_plist_2(sc, x, y)) != sc->F); wrong_type_argument(sc, sc->leq_symbol, 2, y, T_REAL); return(false); } @@ -23934,17 +23945,14 @@ static s7_pointer g_less_or_equal(s7_scheme *sc, s7_pointer args) if (is_null(cdr(p))) return(make_boolean(sc, leq_b_7pp(sc, x, car(p)))); - for (; is_pair(p); p = cdr(p)) - { - if (!leq_b_7pp(sc, x, car(p))) - { - for (p = cdr(p); is_pair(p); p = cdr(p)) - if (!is_real_via_method(sc, car(p))) - return(wrong_type_argument(sc, sc->leq_symbol, position_of(p, args), car(p), T_REAL)); - return(sc->F); - } - x = car(p); - } + for (; is_pair(p); x = car(p), p = cdr(p)) + if (!leq_b_7pp(sc, x, car(p))) + { + for (p = cdr(p); is_pair(p); p = cdr(p)) + if (!is_real_via_method(sc, car(p))) + return(wrong_type_argument(sc, sc->leq_symbol, position_of(p, args), car(p), T_REAL)); + return(sc->F); + } return(sc->T); } @@ -24033,10 +24041,11 @@ static s7_pointer leq_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_poin /* ---------------------------------------- > ---------------------------------------- */ + static bool gt_out_x(s7_scheme *sc, s7_pointer x, s7_pointer y) { if (has_active_methods(sc, x)) - return(find_and_apply_method(sc, x, sc->gt_symbol, list_2(sc, x, y)) != sc->F); + return(find_and_apply_method(sc, x, sc->gt_symbol, set_plist_2(sc, x, y)) != sc->F); wrong_type_argument(sc, sc->gt_symbol, 1, x, T_REAL); return(false); } @@ -24044,7 +24053,7 @@ static bool gt_out_x(s7_scheme *sc, s7_pointer x, s7_pointer y) static bool gt_out_y(s7_scheme *sc, s7_pointer x, s7_pointer y) { if (has_active_methods(sc, y)) - return(find_and_apply_method(sc, y, sc->gt_symbol, list_2(sc, x, y)) != sc->F); + return(find_and_apply_method(sc, y, sc->gt_symbol, set_plist_2(sc, x, y)) != sc->F); wrong_type_argument(sc, sc->gt_symbol, 2, y, T_REAL); return(false); } @@ -24179,7 +24188,7 @@ static bool gt_b_7pp(s7_scheme *sc, s7_pointer x, s7_pointer y) } #endif - default: return(gt_out_x(sc, x, y)); + default: return(gt_out_x(sc, x, y)); } return(true); } @@ -24196,17 +24205,14 @@ static s7_pointer g_greater(s7_scheme *sc, s7_pointer args) if (is_null(cdr(p))) return(make_boolean(sc, gt_b_7pp(sc, x, car(p)))); - for (; is_pair(p); p = cdr(p)) - { - if (!gt_b_7pp(sc, x, car(p))) - { - for (p = cdr(p); is_pair(p); p = cdr(p)) - if (!is_real_via_method(sc, car(p))) - return(wrong_type_argument(sc, sc->gt_symbol, position_of(p, args), car(p), T_REAL)); - return(sc->F); - } - x = car(p); - } + for (; is_pair(p); x = car(p), p = cdr(p)) + if (!gt_b_7pp(sc, x, car(p))) + { + for (p = cdr(p); is_pair(p); p = cdr(p)) + if (!is_real_via_method(sc, car(p))) + return(wrong_type_argument(sc, sc->gt_symbol, position_of(p, args), car(p), T_REAL)); + return(sc->F); + } return(sc->T); } @@ -24375,10 +24381,11 @@ static s7_pointer greater_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_ /* ---------------------------------------- >= ---------------------------------------- */ + static bool geq_out_x(s7_scheme *sc, s7_pointer x, s7_pointer y) { if (has_active_methods(sc, x)) - return(find_and_apply_method(sc, x, sc->geq_symbol, list_2(sc, x, y)) != sc->F); + return(find_and_apply_method(sc, x, sc->geq_symbol, set_plist_2(sc, x, y)) != sc->F); wrong_type_argument(sc, sc->geq_symbol, 1, x, T_REAL); return(false); } @@ -24386,7 +24393,7 @@ static bool geq_out_x(s7_scheme *sc, s7_pointer x, s7_pointer y) static bool geq_out_y(s7_scheme *sc, s7_pointer x, s7_pointer y) { if (has_active_methods(sc, y)) - return(find_and_apply_method(sc, y, sc->geq_symbol, list_2(sc, x, y)) != sc->F); + return(find_and_apply_method(sc, y, sc->geq_symbol, set_plist_2(sc, x, y)) != sc->F); wrong_type_argument(sc, sc->geq_symbol, 2, y, T_REAL); return(false); } @@ -24523,7 +24530,7 @@ static bool geq_b_7pp(s7_scheme *sc, s7_pointer x, s7_pointer y) default: return(geq_out_y(sc, x, y)); } #endif - default: return(geq_out_x(sc, x, y)); + default: return(geq_out_x(sc, x, y)); } return(true); } @@ -24540,17 +24547,14 @@ static s7_pointer g_greater_or_equal(s7_scheme *sc, s7_pointer args) if (is_null(cdr(p))) return(make_boolean(sc, geq_b_7pp(sc, x, car(p)))); - for (; is_pair(p); p = cdr(p)) - { - if (!geq_b_7pp(sc, x, car(p))) - { - for (p = cdr(p); is_pair(p); p = cdr(p)) - if (!is_real_via_method(sc, car(p))) - return(wrong_type_argument(sc, sc->geq_symbol, position_of(p, args), car(p), T_REAL)); - return(sc->F); - } - x = car(p); - } + for (; is_pair(p); x = car(p), p = cdr(p)) + if (!geq_b_7pp(sc, x, car(p))) + { + for (p = cdr(p); is_pair(p); p = cdr(p)) + if (!is_real_via_method(sc, car(p))) + return(wrong_type_argument(sc, sc->geq_symbol, position_of(p, args), car(p), T_REAL)); + return(sc->F); + } return(sc->T); } @@ -24692,7 +24696,7 @@ static s7_pointer real_part_p_p(s7_scheme *sc, s7_pointer p) #endif default: - return(method_or_bust_with_type_one_arg(sc, p, sc->real_part_symbol, list_1(sc, p), a_number_string)); + return(method_or_bust_with_type_one_arg_p(sc, p, sc->real_part_symbol, a_number_string)); } } @@ -24750,7 +24754,7 @@ static s7_pointer imag_part_p_p(s7_scheme *sc, s7_pointer p) #endif default: - return(method_or_bust_with_type_one_arg(sc, p, sc->imag_part_symbol, list_1(sc, p), a_number_string)); + return(method_or_bust_with_type_one_arg_p(sc, p, sc->imag_part_symbol, a_number_string)); } } @@ -24773,7 +24777,7 @@ static s7_int numerator_i_7p(s7_scheme *sc, s7_pointer p) if (is_t_big_ratio(p)) return(mpz_get_si(mpq_numref(big_ratio(p)))); if (is_t_big_integer(p)) return(mpz_get_si(big_integer(p))); #endif - return(integer(method_or_bust_with_type_one_arg(sc, p, sc->numerator_symbol, list_1(sc, p), a_rational_string))); + return(integer(method_or_bust_with_type_one_arg_p(sc, p, sc->numerator_symbol, a_rational_string))); } static s7_pointer g_numerator(s7_scheme *sc, s7_pointer args) @@ -24823,7 +24827,7 @@ static s7_int denominator_i_7p(s7_scheme *sc, s7_pointer p) if (is_t_big_ratio(p)) return(mpz_get_si(mpq_denref(big_ratio(p)))); if (is_t_big_integer(p)) return(1); #endif - return(integer(method_or_bust_with_type_one_arg(sc, p, sc->denominator_symbol, list_1(sc, p), a_rational_string))); + return(integer(method_or_bust_with_type_one_arg_p(sc, p, sc->denominator_symbol, a_rational_string))); } @@ -24919,7 +24923,7 @@ static bool is_nan_b_7p(s7_scheme *sc, s7_pointer x) #endif default: if (s7_is_number(x)) - return(method_or_bust_with_type_one_arg(sc, x, sc->is_nan_symbol, list_1(sc, x), a_number_string) != sc->F); + return(method_or_bust_with_type_one_arg_p(sc, x, sc->is_nan_symbol, a_number_string) != sc->F); } return(false); } @@ -24951,7 +24955,7 @@ static bool is_infinite_b_7p(s7_scheme *sc, s7_pointer x) #endif default: if (s7_is_number(x)) - return(method_or_bust_with_type_one_arg(sc, x, sc->is_infinite_symbol, list_1(sc, x), a_number_string) != sc->F); + return(method_or_bust_with_type_one_arg_p(sc, x, sc->is_infinite_symbol, a_number_string) != sc->F); } return(false); } @@ -24993,7 +24997,7 @@ static s7_pointer g_is_even(s7_scheme *sc, s7_pointer args) if (is_t_big_integer(p)) return(make_boolean(sc, mpz_even_p(big_integer(p)))); #endif - return(method_or_bust_one_arg(sc, p, sc->is_even_symbol, list_1(sc, p), T_INTEGER)); + return(method_or_bust_one_arg_p(sc, p, sc->is_even_symbol, T_INTEGER)); } @@ -25010,7 +25014,7 @@ static s7_pointer g_is_odd(s7_scheme *sc, s7_pointer args) if (is_t_big_integer(p)) return(make_boolean(sc, mpz_odd_p(big_integer(p)))); #endif - return(method_or_bust_one_arg(sc, p, sc->is_odd_symbol, list_1(sc, p), T_INTEGER)); + return(method_or_bust_one_arg_p(sc, p, sc->is_odd_symbol, T_INTEGER)); } static bool is_odd_b_7p(s7_scheme *sc, s7_pointer p) @@ -25049,7 +25053,7 @@ static s7_pointer g_is_zero(s7_scheme *sc, s7_pointer args) case T_BIG_COMPLEX: return(sc->F); #endif default: - return(method_or_bust_with_type_one_arg(sc, x, sc->is_zero_symbol, list_1(sc, x), a_number_string)); + return(method_or_bust_with_type_one_arg_p(sc, x, sc->is_zero_symbol, a_number_string)); } } @@ -25110,7 +25114,7 @@ static s7_pointer g_is_positive(s7_scheme *sc, s7_pointer args) case T_BIG_REAL: return(make_boolean(sc, (mpfr_cmp_ui(big_real(x), 0) > 0))); #endif default: - return(method_or_bust_one_arg(sc, x, sc->is_positive_symbol, list_1(sc, x), T_REAL)); + return(method_or_bust_one_arg_p(sc, x, sc->is_positive_symbol, T_REAL)); } } @@ -25167,7 +25171,7 @@ static s7_pointer is_negative_p_p(s7_scheme *sc, s7_pointer x) case T_BIG_REAL: return(make_boolean(sc, (mpfr_cmp_ui(big_real(x), 0) < 0))); #endif default: - return(method_or_bust_one_arg(sc, x, sc->is_negative_symbol, list_1(sc, x), T_REAL)); + return(method_or_bust_one_arg_p(sc, x, sc->is_negative_symbol, T_REAL)); } } @@ -25375,7 +25379,7 @@ sign of 'x' (1 = positive, -1 = negative). (integer-decode-float 0.0): (0 0 1)" #if WITH_GMP static s7_pointer big_logior(s7_scheme *sc, s7_int start, s7_pointer args) { - s7_pointer x, lst; + s7_pointer x; mpz_set_si(sc->mpz_1, start); for (x = args; is_not_null(x); x = cdr(x)) @@ -25396,8 +25400,9 @@ static s7_pointer big_logior(s7_scheme *sc, s7_int start, s7_pointer args) default: if (!is_integer_via_method(sc, i)) return(wrong_type_argument(sc, sc->logior_symbol, position_of(x, args), i, T_INTEGER)); - lst = cons(sc, mpz_to_integer(sc, sc->mpz_1), x); - return(method_or_bust(sc, i, sc->logior_symbol, lst, T_INTEGER, position_of(x, args))); + return(method_or_bust(sc, i, sc->logior_symbol, + set_ulist_1(sc, mpz_to_integer(sc, sc->mpz_1), x), + T_INTEGER, position_of(x, args))); }} return(mpz_to_integer(sc, sc->mpz_1)); } @@ -25417,7 +25422,9 @@ static s7_pointer g_logior(s7_scheme *sc, s7_pointer args) return(big_logior(sc, result, x)); #endif if (!is_t_integer(car(x))) - return(method_or_bust(sc, car(x), sc->logior_symbol, (result == 0) ? x : cons(sc, make_integer(sc, result), x), T_INTEGER, position_of(x, args))); + return(method_or_bust(sc, car(x), sc->logior_symbol, + (result == 0) ? x : set_ulist_1(sc, make_integer(sc, result), x), + T_INTEGER, position_of(x, args))); result |= integer(car(x)); } return(make_integer(sc, result)); @@ -25431,7 +25438,7 @@ static s7_int logior_i_iii(s7_int i1, s7_int i2, s7_int i3) {return(i1 | i2 | i3 #if WITH_GMP static s7_pointer big_logxor(s7_scheme *sc, s7_int start, s7_pointer args) { - s7_pointer x, lst; + s7_pointer x; mpz_set_si(sc->mpz_1, start); for (x = args; is_not_null(x); x = cdr(x)) @@ -25452,8 +25459,9 @@ static s7_pointer big_logxor(s7_scheme *sc, s7_int start, s7_pointer args) default: if (!is_integer_via_method(sc, i)) return(wrong_type_argument(sc, sc->logxor_symbol, position_of(x, args), i, T_INTEGER)); - lst = cons(sc, mpz_to_integer(sc, sc->mpz_1), x); - return(method_or_bust(sc, i, sc->logxor_symbol, lst, T_INTEGER, position_of(x, args))); + return(method_or_bust(sc, i, sc->logxor_symbol, + set_ulist_1(sc, mpz_to_integer(sc, sc->mpz_1), x), + T_INTEGER, position_of(x, args))); }} return(mpz_to_integer(sc, sc->mpz_1)); } @@ -25473,7 +25481,9 @@ static s7_pointer g_logxor(s7_scheme *sc, s7_pointer args) return(big_logxor(sc, result, x)); #endif if (!is_t_integer(car(x))) - return(method_or_bust(sc, car(x), sc->logxor_symbol, (result == 0) ? x : cons(sc, make_integer(sc, result), x), T_INTEGER, position_of(x, args))); + return(method_or_bust(sc, car(x), sc->logxor_symbol, + (result == 0) ? x : set_ulist_1(sc, make_integer(sc, result), x), + T_INTEGER, position_of(x, args))); result ^= integer(car(x)); } return(make_integer(sc, result)); @@ -25487,7 +25497,7 @@ static s7_int logxor_i_iii(s7_int i1, s7_int i2, s7_int i3) {return(i1 ^ i2 ^ i3 #if WITH_GMP static s7_pointer big_logand(s7_scheme *sc, s7_int start, s7_pointer args) { - s7_pointer x, lst; + s7_pointer x; mpz_set_si(sc->mpz_1, start); for (x = args; is_not_null(x); x = cdr(x)) @@ -25508,8 +25518,9 @@ static s7_pointer big_logand(s7_scheme *sc, s7_int start, s7_pointer args) default: if (!is_integer_via_method(sc, i)) return(wrong_type_argument(sc, sc->logand_symbol, position_of(x, args), i, T_INTEGER)); - lst = cons(sc, mpz_to_integer(sc, sc->mpz_1), x); - return(method_or_bust(sc, i, sc->logand_symbol, lst, T_INTEGER, position_of(x, args))); + return(method_or_bust(sc, i, sc->logand_symbol, + set_ulist_1(sc, mpz_to_integer(sc, sc->mpz_1), x), + T_INTEGER, position_of(x, args))); }} return(mpz_to_integer(sc, sc->mpz_1)); } @@ -25529,7 +25540,9 @@ static s7_pointer g_logand(s7_scheme *sc, s7_pointer args) return(big_logand(sc, result, x)); #endif if (!is_t_integer(car(x))) - return(method_or_bust(sc, car(x), sc->logand_symbol, (result == -1) ? x : cons(sc, make_integer(sc, result), x), T_INTEGER, position_of(x, args))); + return(method_or_bust(sc, car(x), sc->logand_symbol, + (result == -1) ? x : set_ulist_1(sc, make_integer(sc, result), x), + T_INTEGER, position_of(x, args))); result &= integer(car(x)); } return(make_integer(sc, result)); @@ -25611,7 +25624,7 @@ static bool logbit_b_7ii(s7_scheme *sc, s7_int i1, s7_int i2) { if (i2 < 0) { - out_of_range(sc, sc->logbit_symbol, int_two, make_integer(sc, i1), its_negative_string); + out_of_range(sc, sc->logbit_symbol, int_two, wrap_integer1(sc, i1), its_negative_string); return(false); } if (i2 >= S7_INT_BITS) @@ -25725,10 +25738,9 @@ static s7_pointer g_ash(s7_scheme *sc, s7_pointer args) if (shift > 0) /* left */ mpz_mul_2exp(sc->mpz_1, sc->mpz_1, shift); else - { - if (shift < 0) /* right */ - mpz_fdiv_q_2exp(sc->mpz_1, sc->mpz_1, (uint32_t)(-shift)); - } + if (shift < 0) /* right */ + mpz_fdiv_q_2exp(sc->mpz_1, sc->mpz_1, (uint32_t)(-shift)); + return(mpz_to_integer(sc, sc->mpz_1)); } /* else fall through */ @@ -26181,7 +26193,7 @@ static s7_pointer g_char_to_integer(s7_scheme *sc, s7_pointer args) static s7_int char_to_integer_i_7p(s7_scheme *sc, s7_pointer p) { if (!s7_is_character(p)) - return(integer(method_or_bust_one_arg(sc, p, sc->char_to_integer_symbol, list_1(sc, p), T_CHARACTER))); + return(integer(method_or_bust_one_arg_p(sc, p, sc->char_to_integer_symbol, T_CHARACTER))); return(character(p)); } @@ -26189,7 +26201,7 @@ static s7_pointer integer_to_char_p_p(s7_scheme *sc, s7_pointer x) { s7_int ind; if (!s7_is_integer(x)) - return(method_or_bust_one_arg(sc, x, sc->integer_to_char_symbol, list_1(sc, x), T_INTEGER)); + return(method_or_bust_one_arg_p(sc, x, sc->integer_to_char_symbol, T_INTEGER)); ind = s7_integer_checked(sc, x); if ((ind >= 0) && (ind < NUM_CHARS)) return(s7_make_character(sc, (uint8_t)ind)); @@ -26207,7 +26219,7 @@ static s7_pointer integer_to_char_p_i(s7_scheme *sc, s7_int ind) { if ((ind >= 0) && (ind < NUM_CHARS)) return(s7_make_character(sc, (uint8_t)ind)); - return(s7_out_of_range_error(sc, "integer->char", 1, make_integer(sc, ind), "it doen't fit in an unsigned byte")); + return(s7_out_of_range_error(sc, "integer->char", 1, wrap_integer2(sc, ind), "it doen't fit in an unsigned byte")); /* int2 s7_out... uses 1 */ } @@ -26284,7 +26296,7 @@ static void init_chars(void) static s7_pointer char_upcase_p_p(s7_scheme *sc, s7_pointer c) { if (!s7_is_character(c)) - return(method_or_bust_one_arg(sc, c, sc->char_upcase_symbol, list_1(sc, c), T_CHARACTER)); + return(method_or_bust_one_arg_p(sc, c, sc->char_upcase_symbol, T_CHARACTER)); return(s7_make_character(sc, upper_character(c))); } @@ -26374,7 +26386,7 @@ static bool is_char_whitespace_b_7p(s7_scheme *sc, s7_pointer c) s7_pointer f; f = find_method_with_let(sc, c, sc->is_char_whitespace_symbol); if (f != sc->undefined) - return(is_true(sc, call_method(sc, c, f, cons(sc, c, sc->nil)))); + return(is_true(sc, call_method(sc, c, f, set_plist_1(sc, c)))); } simple_wrong_type_argument(sc, sc->is_char_whitespace_symbol, c, T_CHARACTER); return(false); @@ -26387,6 +26399,8 @@ static s7_pointer is_char_whitespace_p_p(s7_scheme *sc, s7_pointer c) return(make_boolean(sc, is_char_whitespace(c))); } +static s7_pointer is_char_whitespace_p_p_unchecked(s7_scheme *sc, s7_pointer c) {return(make_boolean(sc, is_char_whitespace(c)));} + /* -------------------------------- char-upper-case? char-lower-case? -------------------------------- */ static s7_pointer g_is_char_upper_case(s7_scheme *sc, s7_pointer args) @@ -26471,7 +26485,7 @@ static bool is_character_via_method(s7_scheme *sc, s7_pointer p) s7_pointer f; f = find_method_with_let(sc, p, sc->is_char_symbol); if (f != sc->undefined) - return(is_true(sc, call_method(sc, p, f, cons(sc, p, sc->nil)))); + return(is_true(sc, call_method(sc, p, f, set_plist_1(sc, p)))); } return(false); } @@ -26493,13 +26507,12 @@ static s7_pointer g_char_cmp(s7_scheme *sc, s7_pointer args, int32_t val, s7_poi if (!s7_is_character(y)) return(method_or_bust(sc, y, sym, args, T_CHARACTER, 1)); - for (x = cdr(args); is_pair(x); x = cdr(x)) + for (x = cdr(args); is_pair(x); y = car(x), x = cdr(x)) { if (!s7_is_character(car(x))) - return(method_or_bust(sc, car(x), sym, cons(sc, y, x), T_CHARACTER, position_of(x, args))); + return(method_or_bust(sc, car(x), sym, set_ulist_1(sc, y, x), T_CHARACTER, position_of(x, args))); if (charcmp(character(y), character(car(x))) != val) return(char_with_error_check(sc, x, args, sym)); - y = car(x); } return(sc->T); } @@ -26512,13 +26525,12 @@ static s7_pointer g_char_cmp_not(s7_scheme *sc, s7_pointer args, int32_t val, s7 if (!s7_is_character(y)) return(method_or_bust(sc, y, sym, args, T_CHARACTER, 1)); - for (x = cdr(args); is_pair(x); x = cdr(x)) + for (x = cdr(args); is_pair(x); y = car(x), x = cdr(x)) { if (!s7_is_character(car(x))) - return(method_or_bust(sc, car(x), sym, cons(sc, y, x), T_CHARACTER, position_of(x, args))); + return(method_or_bust(sc, car(x), sym, set_ulist_1(sc, y, x), T_CHARACTER, position_of(x, args))); if (charcmp(character(y), character(car(x))) == val) return(char_with_error_check(sc, x, args, sym)); - y = car(x); } return(sc->T); } @@ -26537,7 +26549,7 @@ static s7_pointer g_chars_are_equal(s7_scheme *sc, s7_pointer args) for (x = cdr(args); is_pair(x); x = cdr(x)) { if (!s7_is_character(car(x))) - return(method_or_bust(sc, car(x), sc->char_eq_symbol, cons(sc, y, x), T_CHARACTER, position_of(x, args))); + return(method_or_bust(sc, car(x), sc->char_eq_symbol, set_ulist_1(sc, y, x), T_CHARACTER, position_of(x, args))); if (car(x) != y) return(char_with_error_check(sc, x, args, sc->char_eq_symbol)); } @@ -26706,13 +26718,12 @@ static s7_pointer g_char_cmp_ci(s7_scheme *sc, s7_pointer args, int32_t val, s7_ if (!s7_is_character(y)) return(method_or_bust(sc, y, sym, args, T_CHARACTER, 1)); - for (x = cdr(args); is_pair(x); x = cdr(x)) + for (x = cdr(args); is_pair(x); y = car(x), x = cdr(x)) { if (!s7_is_character(car(x))) - return(method_or_bust(sc, car(x), sym, cons(sc, y, x), T_CHARACTER, position_of(x, args))); + return(method_or_bust(sc, car(x), sym, set_ulist_1(sc, y, x), T_CHARACTER, position_of(x, args))); if (charcmp(upper_character(y), upper_character(car(x))) != val) return(char_with_error_check(sc, x, args, sym)); - y = car(x); } return(sc->T); } @@ -26724,13 +26735,12 @@ static s7_pointer g_char_cmp_ci_not(s7_scheme *sc, s7_pointer args, int32_t val, y = car(args); if (!s7_is_character(y)) return(method_or_bust(sc, y, sym, args, T_CHARACTER, 1)); - for (x = cdr(args); is_pair(x); x = cdr(x)) + for (x = cdr(args); is_pair(x); y = car(x), x = cdr(x)) { if (!s7_is_character(car(x))) - return(method_or_bust(sc, car(x), sym, cons(sc, y, x), T_CHARACTER, position_of(x, args))); + return(method_or_bust(sc, car(x), sym, set_ulist_1(sc, y, x), T_CHARACTER, position_of(x, args))); if (charcmp(upper_character(y), upper_character(car(x))) == val) return(char_with_error_check(sc, x, args, sym)); - y = car(x); } return(sc->T); } @@ -27015,7 +27025,9 @@ static s7_pointer wrap_string(s7_scheme *sc, const char *str, s7_int len) { s7_pointer x; #if S7_DEBUGGING - if ((strcmp(func, "g_substring_uncopied") != 0) && (strcmp(func, "read_sharp") != 0) && (strcmp(func, "g_get_output_string_uncopied") != 0) && (len != safe_strlen(str))) + if ((strcmp(func, "g_substring_uncopied") != 0) && (strcmp(func, "read_sharp") != 0) && + (strcmp(func, "g_get_output_string_uncopied") != 0) && (strcmp(func, "substring_uncopied_p_pii") != 0) && + (len != safe_strlen(str))) fprintf(stderr, "%s[%d]: %" print_s7_int " != %" print_s7_int ", %s\n", func, line, len, safe_strlen(str), str); #endif x = sc->string_wrappers[sc->string_wrapper_pos]; @@ -27227,7 +27239,7 @@ static s7_pointer g_make_string(s7_scheme *sc, s7_pointer args) static s7_pointer make_string_p_i(s7_scheme *sc, s7_int len) { if ((len < 0) || (len > sc->max_string_length)) - return(out_of_range(sc, sc->make_string_symbol, int_one, make_integer(sc, len), (len < 0) ? its_negative_string : its_too_large_string)); + return(out_of_range(sc, sc->make_string_symbol, int_one, wrap_integer1(sc, len), (len < 0) ? its_negative_string : its_too_large_string)); return(make_empty_string(sc, len, '\0')); } @@ -27248,7 +27260,7 @@ static s7_pointer g_string_length(s7_scheme *sc, s7_pointer args) static s7_int string_length_i_7p(s7_scheme *sc, s7_pointer p) { if (!is_string(p)) - return(integer(method_or_bust_one_arg(sc, p, sc->string_length_symbol, list_1(sc, p), T_STRING))); + return(integer(method_or_bust_one_arg_p(sc, p, sc->string_length_symbol, T_STRING))); return(string_length(p)); } #endif @@ -27266,7 +27278,7 @@ static s7_pointer g_string_downcase(s7_scheme *sc, s7_pointer args) p = car(args); if (!is_string(p)) - return(method_or_bust_one_arg(sc, p, sc->string_downcase_symbol, list_1(sc, p), T_STRING)); + return(method_or_bust_one_arg_p(sc, p, sc->string_downcase_symbol, T_STRING)); len = string_length(p); newstr = make_empty_string(sc, len, 0); @@ -27299,7 +27311,7 @@ static s7_pointer g_string_upcase(s7_scheme *sc, s7_pointer args) p = car(args); if (!is_string(p)) - return(method_or_bust_one_arg(sc, p, sc->string_upcase_symbol, list_1(sc, p), T_STRING)); + return(method_or_bust_one_arg_p(sc, p, sc->string_upcase_symbol, T_STRING)); len = string_length(p); newstr = make_empty_string(sc, len, 0); @@ -27329,7 +27341,7 @@ static s7_pointer string_ref_1(s7_scheme *sc, s7_pointer strng, s7_pointer index s7_int ind; if (!s7_is_integer(index)) - return(method_or_bust(sc, index, sc->string_ref_symbol, list_2(sc, strng, index), T_INTEGER, 2)); + return(method_or_bust_pp(sc, index, sc->string_ref_symbol, strng, index, T_INTEGER, 2)); ind = s7_integer_checked(sc, index); if (ind < 0) return(out_of_range(sc, sc->string_ref_symbol, int_two, index, a_non_negative_integer_string)); @@ -27365,7 +27377,7 @@ static s7_pointer string_ref_p_pi(s7_scheme *sc, s7_pointer p1, s7_int i1) static s7_pointer string_ref_p_pp(s7_scheme *sc, s7_pointer p1, s7_pointer i1) { if (!is_string(p1)) - return(method_or_bust(sc, p1, sc->string_ref_symbol, set_plist_2(sc, p1, i1), T_STRING, 1)); + return(method_or_bust_pp(sc, p1, sc->string_ref_symbol, p1, i1, T_STRING, 1)); return(string_ref_1(sc, p1, i1)); } @@ -27378,14 +27390,14 @@ static s7_pointer string_ref_p_p0(s7_scheme *sc, s7_pointer p1, s7_pointer i1) / out_of_range(sc, sc->string_ref_symbol, int_two, int_zero, its_too_large_string); return(p1); } - return(method_or_bust(sc, p1, sc->string_ref_symbol, set_plist_2(sc, p1, int_zero), T_STRING, 1)); + return(method_or_bust_pp(sc, p1, sc->string_ref_symbol, p1, int_zero, T_STRING, 1)); } static s7_pointer string_plast_via_method(s7_scheme *sc, s7_pointer p1) { s7_pointer len; - len = method_or_bust_one_arg(sc, p1, sc->length_symbol, list_1(sc, p1), T_STRING); - return(method_or_bust(sc, p1, sc->string_ref_symbol, set_plist_2(sc, p1, make_integer(sc, integer(len) - 1)), T_STRING, 1)); + len = method_or_bust_one_arg_p(sc, p1, sc->length_symbol, T_STRING); + return(method_or_bust_with_type_pi(sc, p1, sc->string_ref_symbol, p1, integer(len) - 1, sc->prepackaged_type_names[T_STRING])); } static s7_pointer string_ref_p_plast(s7_scheme *sc, s7_pointer p1, s7_pointer i1) @@ -27394,7 +27406,7 @@ static s7_pointer string_ref_p_plast(s7_scheme *sc, s7_pointer p1, s7_pointer i1 { if (string_length(p1) > 0) return(chars[((uint8_t *)string_value(p1))[string_length(p1) - 1]]); - out_of_range(sc, sc->string_ref_symbol, int_two, make_integer(sc, string_length(p1) - 1), its_too_large_string); + out_of_range(sc, sc->string_ref_symbol, int_two, wrap_integer1(sc, string_length(p1) - 1), its_too_large_string); return(p1); } return(string_plast_via_method(sc, p1)); @@ -27459,7 +27471,7 @@ static s7_pointer string_set_p_pip_unchecked(s7_scheme *sc, s7_pointer p1, s7_in { if ((i1 >= 0) && (i1 < string_length(p1))) string_value(p1)[i1] = s7_character(p2); - else out_of_range(sc, sc->string_set_symbol, int_two,make_integer(sc, i1), (i1 < 0) ? its_negative_string : its_too_large_string); + else out_of_range(sc, sc->string_set_symbol, int_two, wrap_integer1(sc, i1), (i1 < 0) ? its_negative_string : its_too_large_string); return(p2); } @@ -27504,7 +27516,7 @@ static s7_pointer g_string_append_1(s7_scheme *sc, s7_pointer args, s7_pointer c for (pos = string_value(newstr), y = args; y != x; pos += string_length(car(y)), y = cdr(y)) memcpy(pos, string_value(car(y)), string_length(car(y))); unstack(sc); - return(call_method(sc, p, func, cons(sc, newstr, x))); + return(call_method(sc, p, func, set_ulist_1(sc, newstr, x))); }} return(wrong_type_argument(sc, caller, position_of(x, args), p, T_STRING)); } @@ -27581,13 +27593,11 @@ static s7_pointer string_append_chooser(s7_scheme *sc, s7_pointer f, int32_t arg /* -------------------------------- substring -------------------------------- */ -static s7_pointer start_and_end(s7_scheme *sc, s7_pointer caller, s7_pointer args, int32_t position, s7_int *start, s7_int *end) +static s7_pointer start_and_end(s7_scheme *sc, s7_pointer caller, s7_pointer args, int32_t position, s7_pointer index_args, s7_int *start, s7_int *end) { /* we assume that *start=0 and *end=length, that end is "exclusive", return true if the start/end points are not changed */ - s7_pointer pstart, index_args; - s7_int i, index; - - for (i = 0, index_args = args; (i < (position - 1)) && (is_pair(index_args)); i++, index_args = cdr(index_args)) {} + s7_pointer pstart; + s7_int index; pstart = car(index_args); if (!s7_is_integer(pstart)) @@ -27630,7 +27640,7 @@ end: (substring \"01234\" 1 2) -> \"1\"" end = string_length(str); if (!is_null(cdr(args))) { - x = start_and_end(sc, sc->substring_symbol, args, 2, &start, &end); + x = start_and_end(sc, sc->substring_symbol, args, 2, cdr(args), &start, &end); if (x != sc->unused) return(x); } s = string_value(str); @@ -27653,12 +27663,24 @@ static s7_pointer g_substring_uncopied(s7_scheme *sc, s7_pointer args) if (!is_null(cdr(args))) { s7_pointer x; - x = start_and_end(sc, sc->substring_symbol, args, 2, &start, &end); + x = start_and_end(sc, sc->substring_symbol, args, 2, cdr(args), &start, &end); if (x != sc->unused) return(x); } return(wrap_string(sc, (char *)(string_value(str) + start), end - start)); } +static s7_pointer substring_uncopied_p_pii(s7_scheme *sc, s7_pointer str, s7_int start, s7_int end) +{ + if (!is_string(str)) + return(method_or_bust(sc, str, sc->substring_symbol, list_3(sc, str, make_integer(sc, start), make_integer(sc, end)), T_STRING, 1)); + if ((end < start) || (end > string_length(str))) + return(out_of_range(sc, sc->substring_symbol, int_three, wrap_integer1(sc, end), (end < start) ? its_too_small_string : its_too_large_string)); + if ((start < 0) || (start > end)) + return(out_of_range(sc, sc->substring_symbol, int_two, wrap_integer1(sc, start), (start < 0) ? its_negative_string : its_too_large_string)); + + return(wrap_string(sc, (char *)(string_value(str) + start), end - start)); +} + static s7_pointer g_get_output_string(s7_scheme *sc, s7_pointer args); static void check_for_substring_temp(s7_scheme *sc, s7_pointer expr) @@ -27689,10 +27711,9 @@ static void check_for_substring_temp(s7_scheme *sc, s7_pointer expr) if (c_callee(arg) == g_symbol_to_string) set_c_function(arg, sc->symbol_to_string_uncopied); else - { - if ((c_callee(arg) == g_get_output_string) && (is_null(cddr(arg)))) - set_c_function(arg, sc->get_output_string_uncopied); - }}}}} + if ((c_callee(arg) == g_get_output_string) && (is_null(cddr(arg)))) + set_c_function(arg, sc->get_output_string_uncopied); + }}}} if ((pairs > 0) && (pairs == substrs)) { @@ -27763,8 +27784,7 @@ static s7_pointer g_string_copy(s7_scheme *sc, s7_pointer args) static s7_pointer string_copy_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool ops) { - if (args == 1) - check_for_substring_temp(sc, expr); + if (args == 1) check_for_substring_temp(sc, expr); return(f); } @@ -27812,7 +27832,6 @@ static int32_t scheme_strcmp(s7_pointer s1, s7_pointer s2) if ((uint8_t)str1[pos] > (uint8_t)str2[pos]) return(1); }} - if (len1 < len2) return(-1); return((len1 > len2) ? 1 : 0); @@ -27827,7 +27846,7 @@ static bool is_string_via_method(s7_scheme *sc, s7_pointer p) s7_pointer f; f = find_method_with_let(sc, p, sc->is_string_symbol); if (f != sc->undefined) - return(is_true(sc, call_method(sc, p, f, cons(sc, p, sc->nil)))); + return(is_true(sc, call_method(sc, p, f, set_plist_1(sc, p)))); } return(false); } @@ -27840,19 +27859,17 @@ static s7_pointer g_string_cmp(s7_scheme *sc, s7_pointer args, int32_t val, s7_p if (!is_string(y)) return(method_or_bust(sc, y, sym, args, T_STRING, 1)); - for (x = cdr(args); is_not_null(x); x = cdr(x)) + for (x = cdr(args); is_not_null(x); y = car(x), x = cdr(x)) { if (!is_string(car(x))) - return(method_or_bust(sc, car(x), sym, cons(sc, y, x), T_STRING, position_of(x, args))); + return(method_or_bust(sc, car(x), sym, set_ulist_1(sc, y, x), T_STRING, position_of(x, args))); if (scheme_strcmp(y, car(x)) != val) { for (y = cdr(x); is_pair(y); y = cdr(y)) if (!is_string_via_method(sc, car(y))) return(wrong_type_argument(sc, sym, position_of(y, args), car(y), T_STRING)); return(sc->F); - } - y = car(x); - } + }} return(sc->T); } @@ -27864,19 +27881,17 @@ static s7_pointer g_string_cmp_not(s7_scheme *sc, s7_pointer args, int32_t val, if (!is_string(y)) return(method_or_bust(sc, y, sym, args, T_STRING, 1)); - for (x = cdr(args); is_not_null(x); x = cdr(x)) + for (x = cdr(args); is_not_null(x); y = car(x), x = cdr(x)) { if (!is_string(car(x))) - return(method_or_bust(sc, car(x), sym, cons(sc, y, x), T_STRING, position_of(x, args))); + return(method_or_bust(sc, car(x), sym, set_ulist_1(sc, y, x), T_STRING, position_of(x, args))); if (scheme_strcmp(y, car(x)) == val) { for (y = cdr(x); is_pair(y); y = cdr(y)) if (!is_string_via_method(sc, car(y))) return(wrong_type_argument(sc, sym, position_of(y, args), car(y), T_STRING)); return(sc->F); - } - y = car(x); - } + }} return(sc->T); } @@ -27908,7 +27923,7 @@ static s7_pointer g_strings_are_equal(s7_scheme *sc, s7_pointer args) if (y != p) { if (!is_string(p)) - return(method_or_bust(sc, p, sc->string_eq_symbol, cons(sc, y, x), T_STRING, position_of(x, args))); + return(method_or_bust(sc, p, sc->string_eq_symbol, set_ulist_1(sc, y, x), T_STRING, position_of(x, args))); if (happy) happy = scheme_strings_are_equal(p, y); }} @@ -28108,21 +28123,18 @@ static s7_pointer g_string_ci_cmp(s7_scheme *sc, s7_pointer args, int32_t val, s if (!is_string(y)) return(method_or_bust(sc, y, sym, args, T_STRING, 1)); - for (x = cdr(args); is_not_null(x); x = cdr(x)) + for (x = cdr(args); is_not_null(x); y = car(x), x = cdr(x)) { if (!is_string(car(x))) - return(method_or_bust(sc, car(x), sym, cons(sc, y, x), T_STRING, position_of(x, args))); + return(method_or_bust(sc, car(x), sym, set_ulist_1(sc, y, x), T_STRING, position_of(x, args))); if (val == 0) { if (!scheme_strequal_ci(y, car(x))) return(string_check_method(sc, sym, x, y, args)); } else - { - if (scheme_strcasecmp(y, car(x)) != val) - return(string_check_method(sc, sym, x, y, args)); - } - y = car(x); + if (scheme_strcasecmp(y, car(x)) != val) + return(string_check_method(sc, sym, x, y, args)); } return(sc->T); } @@ -28135,13 +28147,12 @@ static s7_pointer g_string_ci_cmp_not(s7_scheme *sc, s7_pointer args, int32_t va if (!is_string(y)) return(method_or_bust(sc, y, sym, args, T_STRING, 1)); - for (x = cdr(args); is_not_null(x); x = cdr(x)) + for (x = cdr(args); is_not_null(x); y = car(x), x = cdr(x)) { if (!is_string(car(x))) - return(method_or_bust(sc, car(x), sym, cons(sc, y, x), T_STRING, position_of(x, args))); + return(method_or_bust(sc, car(x), sym, set_ulist_1(sc, y, x), T_STRING, position_of(x, args))); if (scheme_strcasecmp(y, car(x)) == val) return(string_check_method(sc, sym, x, y, args)); - y = car(x); } return(sc->T); } @@ -28236,7 +28247,7 @@ static s7_pointer g_string_fill_1(s7_scheme *sc, s7_pointer caller, s7_pointer a if (!is_null(cddr(args))) { s7_pointer p; - p = start_and_end(sc, caller, args, 3, &start, &end); + p = start_and_end(sc, caller, args, 3, cddr(args), &start, &end); if (p != sc->unused) return(p); if (start == end) return(chr); @@ -28351,7 +28362,7 @@ static s7_pointer s7_string_to_list(s7_scheme *sc, const char *str, s7_int len) s7_pointer result; if (len == 0) return(sc->nil); - check_heap_size(sc, len); + check_free_heap_size(sc, len); sc->v = sc->nil; for (i = len - 1; i >= 0; i--) sc->v = cons_unchecked(sc, s7_make_character(sc, ((uint8_t)str[i])), sc->v); @@ -28376,22 +28387,19 @@ static s7_pointer g_string_to_list(s7_scheme *sc, s7_pointer args) end = string_length(str); if (!is_null(cdr(args))) { - p = start_and_end(sc, sc->string_to_list_symbol, args, 2, &start, &end); + p = start_and_end(sc, sc->string_to_list_symbol, args, 2, cdr(args), &start, &end); if (p != sc->unused) return(p); if (start == end) return(sc->nil); } - else + else if (end == 0) return(sc->nil); if ((end - start) > sc->max_list_length) return(out_of_range(sc, sc->string_to_list_symbol, int_one, car(args), its_too_large_string)); - if ((start == 0) && (end == string_length(str))) - return(s7_string_to_list(sc, string_value(str), string_length(str))); - sc->w = sc->nil; + check_free_heap_size(sc, end - start); for (i = end - 1; i >= start; i--) - sc->w = cons(sc, s7_make_character(sc, ((uint8_t)string_value(str)[i])), sc->w); - + sc->w = cons_unchecked(sc, s7_make_character(sc, ((uint8_t)string_value(str)[i])), sc->w); p = sc->w; sc->w = sc->nil; return(p); @@ -28507,7 +28515,7 @@ static s7_pointer c_port_line_number(s7_scheme *sc, s7_pointer x) { if ((!(is_input_port(x))) || (port_is_closed(x))) - return(method_or_bust_with_type_one_arg(sc, x, sc->port_line_number_symbol, list_1(sc, x), an_input_port_string)); + return(method_or_bust_with_type_one_arg_p(sc, x, sc->port_line_number_symbol, an_input_port_string)); return(make_integer(sc, port_line_number(x))); } @@ -28573,7 +28581,7 @@ static s7_pointer c_port_filename(s7_scheme *sc, s7_pointer x) return(make_string_with_length(sc, "", 0)); /* otherwise (eval-string (port-filename)) and (string->symbol (port-filename)) segfault */ } - return(method_or_bust_with_type_one_arg(sc, x, sc->port_filename_symbol, list_1(sc, x), an_open_port_string)); + return(method_or_bust_with_type_one_arg_p(sc, x, sc->port_filename_symbol, an_open_port_string)); } static s7_pointer g_port_filename(s7_scheme *sc, s7_pointer args) @@ -28593,7 +28601,7 @@ static s7_pointer g_pair_line_number(s7_scheme *sc, s7_pointer args) p = car(args); if (!is_pair(p)) - return(method_or_bust_one_arg(sc, p, sc->pair_line_number_symbol, set_plist_1(sc, p), T_PAIR)); + return(method_or_bust_one_arg_p(sc, p, sc->pair_line_number_symbol, T_PAIR)); return((has_location(p)) ? make_integer(sc, pair_line_number(p)) : sc->F); /* was 0 21-Mar-17 */ } @@ -28601,7 +28609,7 @@ static s7_pointer g_pair_line_number(s7_scheme *sc, s7_pointer args) static s7_pointer pair_line_number_p_p(s7_scheme *sc, s7_pointer p) { if (!is_pair(p)) - return(method_or_bust_one_arg(sc, p, sc->pair_line_number_symbol, set_plist_1(sc, p), T_PAIR)); + return(method_or_bust_one_arg_p(sc, p, sc->pair_line_number_symbol, T_PAIR)); return((has_location(p)) ? make_integer(sc, pair_line_number(p)) : sc->F); } @@ -28870,7 +28878,7 @@ static s7_pointer g_close_input_port(s7_scheme *sc, s7_pointer args) pt = car(args); if (!is_input_port(pt)) - return(method_or_bust_with_type_one_arg(sc, pt, sc->close_input_port_symbol, set_plist_1(sc, pt), an_input_port_string)); + return(method_or_bust_with_type_one_arg_p(sc, pt, sc->close_input_port_symbol, an_input_port_string)); if ((!is_immutable_port(pt)) && /* (close-input-port *stdin*) */ (!is_loader_port(pt))) /* top-level unmatched (close-input-port (current-input-port)) should not clobber the loader's input port */ s7_close_input_port(sc, pt); @@ -28927,11 +28935,9 @@ static void close_output_file(s7_scheme *sc, s7_pointer p) } if (port_file(p)) { - if (port_position(p) > 0) - { - if (fwrite((void *)(port_data(p)), 1, port_position(p), port_file(p)) != (size_t)port_position(p)) - s7_warn(sc, 64, "fwrite trouble in close-output-port\n"); - } + if ((port_position(p) > 0) && + (fwrite((void *)(port_data(p)), 1, port_position(p), port_file(p)) != (size_t)port_position(p))) + s7_warn(sc, 64, "fwrite trouble in close-output-port\n"); fflush(port_file(p)); fclose(port_file(p)); port_file(p) = NULL; @@ -28971,7 +28977,7 @@ static s7_pointer g_close_output_port(s7_scheme *sc, s7_pointer args) if (!is_output_port(pt)) { if (pt == sc->F) return(sc->unspecified); - return(method_or_bust_with_type_one_arg(sc, pt, sc->close_output_port_symbol, set_plist_1(sc, pt), an_output_port_string)); + return(method_or_bust_with_type_one_arg_p(sc, pt, sc->close_output_port_symbol, an_output_port_string)); } s7_close_output_port(sc, pt); return(sc->unspecified); @@ -29240,7 +29246,7 @@ static void stderr_write_string(s7_scheme *sc, const char *str, s7_int len, s7_p static void string_write_string_resized(s7_scheme *sc, const char *str, s7_int len, s7_pointer pt) { - s7_int new_len; /* len is known to be non-zero, str may not be 0-terminated */ + s7_int new_len; /* len is known to be non-zero, str might not be 0-terminated */ new_len = port_position(pt) + len; resize_port_data(sc, pt, new_len * 2); memcpy((void *)(port_data(pt) + port_position(pt)), (void *)str, len); @@ -29343,7 +29349,7 @@ static s7_pointer g_write_string(s7_scheme *sc, s7_pointer args) if (!is_null(inds)) { s7_pointer p; - p = start_and_end(sc, sc->write_string_symbol, args, 3, &start, &end); + p = start_and_end(sc, sc->write_string_symbol, args, 3, inds, &start, &end); if (p != sc->unused) return(p); }} else port = current_output_port(sc); @@ -29368,12 +29374,12 @@ static s7_pointer g_write_string(s7_scheme *sc, s7_pointer args) static s7_pointer write_string_p_pp(s7_scheme *sc, s7_pointer str, s7_pointer port) { if (!is_string(str)) - return(method_or_bust(sc, str, sc->write_string_symbol, list_2(sc, str, port), T_STRING, 1)); + return(method_or_bust_pp(sc, str, sc->write_string_symbol, str, port, T_STRING, 1)); if (!is_output_port(port)) { if (port == sc->F) return(str); - return(method_or_bust_with_type(sc, port, sc->write_string_symbol, list_2(sc, str, port), an_output_port_string, 2)); + return(method_or_bust_with_type_pp(sc, port, sc->write_string_symbol, str, port, an_output_port_string, 2)); } if (string_length(str) > 0) port_write_string(port)(sc, string_value(str), string_length(str), port); @@ -30056,7 +30062,7 @@ static s7_pointer open_input_string(s7_scheme *sc, const char *input_string, s7_ #if S7_DEBUGGING if (input_string[len] != '\0') { - fprintf(stderr, "read_white_space string is not terminated: %ld %c%c %s", len, input_string[len - 1], input_string[len], input_string); + fprintf(stderr, "read_white_space string is not terminated: %" print_s7_int " %c%c %s", len, input_string[len - 1], input_string[len], input_string); abort(); } #endif @@ -30153,7 +30159,7 @@ static void check_get_output_string_port(s7_scheme *sc, s7_pointer p) if (port_position(p) > sc->max_string_length) s7_error(sc, sc->out_of_range_symbol, - set_elist_2(sc, wrap_string(sc, "port-position ~D is greater than (*s7* 'max-string-length)", 58), make_integer(sc, port_position(p)))); + set_elist_2(sc, wrap_string(sc, "port-position ~D is greater than (*s7* 'max-string-length)", 58), wrap_integer1(sc, port_position(p)))); } static s7_pointer g_get_output_string(s7_scheme *sc, s7_pointer args) @@ -30439,7 +30445,7 @@ static s7_pointer g_read_char(s7_scheme *sc, s7_pointer args) static s7_pointer read_char_p_p(s7_scheme *sc, s7_pointer port) { if (!is_input_port(port)) - return(method_or_bust_with_type_one_arg(sc, port, sc->read_char_symbol, list_1(sc, port), an_input_port_string)); + return(method_or_bust_with_type_one_arg_p(sc, port, sc->read_char_symbol, an_input_port_string)); return(chars[port_read_character(port)(sc, port)]); } @@ -30469,10 +30475,10 @@ s7_pointer s7_write_char(s7_scheme *sc, s7_pointer c, s7_pointer pt) static s7_pointer write_char_p_pp(s7_scheme *sc, s7_pointer c, s7_pointer port) { if (!s7_is_character(c)) - return(method_or_bust(sc, c, sc->write_char_symbol, list_2(sc, c, port), T_CHARACTER, 1)); + return(method_or_bust_pp(sc, c, sc->write_char_symbol, c, port, T_CHARACTER, 1)); if (port == sc->F) return(c); if (!is_output_port(port)) - return(method_or_bust_with_type(sc, port, sc->write_char_symbol, list_2(sc, c, port), an_output_port_string, 2)); + return(method_or_bust_with_type_pp(sc, port, sc->write_char_symbol, c, port, an_output_port_string, 2)); port_write_character(port)(sc, s7_character(c), port); return(c); } @@ -30487,7 +30493,7 @@ static s7_pointer g_write_char(s7_scheme *sc, s7_pointer args) static s7_pointer write_char_p_p(s7_scheme *sc, s7_pointer c) { if (!s7_is_character(c)) - return(method_or_bust(sc, c, sc->write_char_symbol, list_1(sc, c), T_CHARACTER, 1)); + return(method_or_bust_p(sc, c, sc->write_char_symbol, T_CHARACTER)); if (current_output_port(sc) == sc->F) return(c); port_write_character(current_output_port(sc))(sc, s7_character(c), current_output_port(sc)); return(c); @@ -30622,14 +30628,14 @@ If 'with-eol' is not #f, read-line includes the trailing end-of-line character." static s7_pointer read_line_p_pp(s7_scheme *sc, s7_pointer port, s7_pointer with_eol) { if (!is_input_port(port)) - return(method_or_bust_with_type(sc, port, sc->read_line_symbol, list_2(sc, port, with_eol), an_input_port_string, 1)); + return(method_or_bust_with_type_pp(sc, port, sc->read_line_symbol, port, with_eol, an_input_port_string, 1)); return(port_read_line(port)(sc, port, with_eol != sc->F)); } static s7_pointer read_line_p_p(s7_scheme *sc, s7_pointer port) { if (!is_input_port(port)) - return(method_or_bust_with_type(sc, port, sc->read_line_symbol, list_1(sc, port), an_input_port_string, 1)); + return(method_or_bust_with_type_one_arg_p(sc, port, sc->read_line_symbol, an_input_port_string)); return(port_read_line(port)(sc, port, false)); /* with_eol default is #f */ } @@ -30652,9 +30658,9 @@ static s7_pointer g_read_string(s7_scheme *sc, s7_pointer args) return(method_or_bust(sc, k, sc->read_string_symbol, args, T_INTEGER, 1)); nchars = s7_integer_checked(sc, k); if (nchars < 0) - return(wrong_type_argument_with_type(sc, sc->read_string_symbol, 1, wrap_integer1(sc, nchars), a_non_negative_integer_string)); + return(wrong_type_argument_with_type(sc, sc->read_string_symbol, 1, k, a_non_negative_integer_string)); if (nchars > sc->max_string_length) - return(out_of_range(sc, sc->read_string_symbol, int_one, wrap_integer1(sc, nchars), its_too_large_string)); + return(out_of_range(sc, sc->read_string_symbol, int_one, k, its_too_large_string)); if (!is_null(cdr(args))) port = cadr(args); @@ -30664,7 +30670,7 @@ static s7_pointer g_read_string(s7_scheme *sc, s7_pointer args) if (!port) return(eof_object); } if (!is_input_port(port)) - return(method_or_bust_with_type(sc, port, sc->read_string_symbol, list_2(sc, make_integer(sc, nchars), port), an_input_port_string, 2)); + return(method_or_bust_with_type_pp(sc, port, sc->read_string_symbol, k, port, an_input_port_string, 2)); if (port_is_closed(port)) return(simple_wrong_type_argument_with_type(sc, sc->read_string_symbol, port, an_open_port_string)); @@ -30914,15 +30920,15 @@ static block_t *full_filename(s7_scheme *sc, const char *filename) if (filename[0] == '/') { len = safe_strlen(filename); - block = mallocate(sc, len); + block = mallocate(sc, len + 1); rtn = (char *)block_data(block); memcpy((void *)rtn, (void *)filename, len); - rtn[len - 1] = '\0'; + rtn[len] = '\0'; } else { char *pwd = getcwd(NULL, 0); /* docs say this means it will return a new string of the right size */ - len = safe_strlen(pwd) + safe_strlen(filename) + 1; + len = safe_strlen(pwd) + safe_strlen(filename) + 2; /* not 1! we need room for the '/' and the terminating 0 */ block = mallocate(sc, len); rtn = (char *)block_data(block); if (pwd) @@ -30931,10 +30937,10 @@ static block_t *full_filename(s7_scheme *sc, const char *filename) catstrs(rtn, len, pwd, "/", filename, (char *)NULL); free(pwd); } - else + else /* isn't this an error? -- perhaps warn about getcwd, strerror(errno) */ { memcpy((void *)rtn, (void *)filename, len); - rtn[len - 1] = '\0'; + rtn[len] = '\0'; }} return(block); } @@ -30995,7 +31001,7 @@ static s7_pointer load_shared_object(s7_scheme *sc, const char *fname, s7_pointe void *init_func; if (hook_has_functions(sc->load_hook)) - s7_apply_function(sc, sc->load_hook, list_1(sc, sc->temp6 = s7_make_string(sc, (pname) ? (const char *)pwd_name : fname))); + s7_apply_function(sc, sc->load_hook, set_plist_1(sc, sc->temp6 = s7_make_string(sc, (pname) ? (const char *)pwd_name : fname))); init_name = symbol_name(init); init_func = dlsym(library, init_name); @@ -31079,7 +31085,7 @@ static FILE *open_file_with_load_path(s7_scheme *sc, const char *fname) FILE *fp; fp = fopen((const char *)block_data(b), "r"); if ((fp) && (hook_has_functions(sc->load_hook))) - s7_apply_function(sc, sc->load_hook, list_1(sc, sc->temp6 = s7_make_string(sc, (const char *)block_data(b)))); + s7_apply_function(sc, sc->load_hook, set_plist_1(sc, sc->temp6 = s7_make_string(sc, (const char *)block_data(b)))); liberate(sc, b); return(fp); } @@ -31125,7 +31131,7 @@ s7_pointer s7_load_with_environment(s7_scheme *sc, const char *filename, s7_poin if (fp) { if (hook_has_functions(sc->load_hook)) - s7_apply_function(sc, sc->load_hook, list_1(sc, sc->temp6 = s7_make_string(sc, filename))); + s7_apply_function(sc, sc->load_hook, set_plist_1(sc, sc->temp6 = s7_make_string(sc, filename))); } else { @@ -31156,10 +31162,7 @@ s7_pointer s7_load_with_environment(s7_scheme *sc, const char *filename, s7_poin return(sc->value); } -s7_pointer s7_load(s7_scheme *sc, const char *filename) -{ - return(s7_load_with_environment(sc, filename, sc->nil)); -} +s7_pointer s7_load(s7_scheme *sc, const char *filename) {return(s7_load_with_environment(sc, filename, sc->nil));} s7_pointer s7_load_c_string_with_environment(s7_scheme *sc, const char *content, s7_int bytes, s7_pointer e) { @@ -31252,7 +31255,7 @@ defaults to the rootlet. To load into the current environment instead, pass (cu if (fp) { if (hook_has_functions(sc->load_hook)) - s7_apply_function(sc, sc->load_hook, list_1(sc, sc->temp6 = s7_make_string(sc, fname))); + s7_apply_function(sc, sc->load_hook, set_plist_1(sc, sc->temp6 = s7_make_string(sc, fname))); } else { @@ -31484,7 +31487,7 @@ static s7_pointer g_autoloader(s7_scheme *sc, s7_pointer args) sym = car(args); if (!is_symbol(sym)) { - check_method(sc, sym, sc->autoloader_symbol, list_1(sc, sym)); + check_method(sc, sym, sc->autoloader_symbol, set_plist_1(sc, sym)); return(s7_wrong_type_arg_error(sc, "*autoload*", 1, sym, "a symbol")); } if (sc->autoload_names) @@ -31540,7 +31543,7 @@ The symbols refer to the argument to \"provide\". (require lint.scm)" if (is_string(f)) { if (hook_has_functions(sc->autoload_hook)) - s7_apply_function(sc, sc->autoload_hook, list_2(sc, sym, f)); + s7_apply_function(sc, sc->autoload_hook, set_plist_2(sc, sym, f)); s7_load_with_environment(sc, string_value(f), sc->curlet); } else return(s7_error(sc, sc->autoload_error_symbol, set_elist_2(sc, wrap_string(sc, "require: no autoload info for ~S", 32), sym))); @@ -31548,7 +31551,9 @@ The symbols refer to the argument to \"provide\". (require lint.scm)" * but loading the symbol as a string worries me. */ }} - unstack(sc); + + if (((opcode_t)sc->stack_end[-1]) == OP_GC_PROTECT) + unstack(sc); return(sc->T); } @@ -31562,7 +31567,7 @@ static s7_pointer g_is_provided(s7_scheme *sc, s7_pointer args) sym = car(args); if (!is_symbol(sym)) - return(method_or_bust_one_arg(sc, sym, sc->is_provided_symbol, list_1(sc, sym), T_SYMBOL)); + return(method_or_bust_one_arg_p(sc, sym, sc->is_provided_symbol, T_SYMBOL)); /* here the *features* list is spread out (or can be anyway) along the curlet chain, * so we need to travel back all the way to the top level checking each *features* list in turn. @@ -31610,7 +31615,7 @@ static s7_pointer c_provide(s7_scheme *sc, s7_pointer sym) */ s7_pointer p; if (!is_symbol(sym)) - return(method_or_bust_one_arg(sc, sym, sc->provide_symbol, list_1(sc, sym), T_SYMBOL)); + return(method_or_bust_one_arg_p(sc, sym, sc->provide_symbol, T_SYMBOL)); if ((sc->curlet == sc->rootlet) || (sc->curlet == sc->shadow_rootlet)) p = global_slot(sc->features_symbol); @@ -31620,14 +31625,13 @@ static s7_pointer c_provide(s7_scheme *sc, s7_pointer sym) else { s7_pointer lst; - lst = slot_value(symbol_to_slot(sc, sc->features_symbol)); /* in either case, we want the current *features* list */ + lst = slot_value(lookup_slot_from(sc->features_symbol, sc->curlet)); /* in either case, we want the current *features* list */ if (p == sc->undefined) make_slot_1(sc, sc->curlet, sc->features_symbol, cons(sc, sym, lst)); else - { - if ((!is_memq(sym, lst)) && (!is_memq(sym, slot_value(p)))) - slot_set_value(p, cons(sc, sym, slot_value(p))); - }} + if ((!is_memq(sym, lst)) && (!is_memq(sym, slot_value(p)))) + slot_set_value(p, cons(sc, sym, slot_value(p))); + } return(sym); } @@ -31855,7 +31859,7 @@ static s7_pointer g_with_input_from_string(s7_scheme *sc, s7_pointer args) if (!is_string(str)) return(method_or_bust(sc, str, sc->with_input_from_string_symbol, args, T_STRING, 1)); - if (cadr(args) == slot_value(global_slot(sc->read_symbol))) /* if chooser for this, make_function_with_class needs to handle unsafe functions */ + if (cadr(args) == slot_value(global_slot(sc->read_symbol))) { if (string_length(str) == 0) return(eof_object); @@ -32283,7 +32287,7 @@ static s7_pointer find_make_iterator_method(s7_scheme *sc, s7_pointer e) ((func = find_method_with_let(sc, e, sc->make_iterator_symbol)) != sc->undefined)) { s7_pointer it; - it = call_method(sc, e, func, list_1(sc, e)); + it = call_method(sc, e, func, set_plist_1(sc, e)); if (!is_iterator(it)) return(s7_error(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "make-iterator method must return an iterator: ~S", 48), it))); return(it); @@ -32405,7 +32409,7 @@ s7_pointer s7_make_iterator(s7_scheme *sc, s7_pointer e) case T_CLOSURE: case T_CLOSURE_STAR: if (is_iterable_closure(sc, e)) { - p = cons(sc, int_zero, sc->nil); + p = list_1(sc, int_zero); iterator_current(iter) = p; set_mark_seq(iter); iterator_next(iter) = closure_iterate; @@ -32470,10 +32474,9 @@ in the sequence each time it is called. When it reaches the end, it returns " I set_mark_seq(iter); } else /* (let-temporarily (((*s7* 'safety) 1)) (make-iterator "asdf" (cons 1 2))) */ - { - if (sc->safety > MORE_SAFETY_WARNINGS) - s7_warn(sc, 256, "(make-iterator %s %s) does not need the second argument\n", display_80(seq), display_80(carrier)); - }}} + if (sc->safety > MORE_SAFETY_WARNINGS) + s7_warn(sc, 256, "(make-iterator %s %s) does not need the second argument\n", display_80(seq), display_80(carrier)); + }} return(iter); } @@ -32494,7 +32497,7 @@ static s7_pointer g_iterate(s7_scheme *sc, s7_pointer args) static s7_pointer iterate_p_p(s7_scheme *sc, s7_pointer iter) { if (!is_iterator(iter)) - return(method_or_bust_one_arg(sc, iter, sc->iterate_symbol, set_plist_1(sc, iter), T_ITERATOR)); + return(method_or_bust_one_arg_p(sc, iter, sc->iterate_symbol, T_ITERATOR)); return((iterator_next(iter))(sc, iter)); } @@ -32590,7 +32593,7 @@ static void flip_ref(shared_info_t *ci, s7_pointer p) int32_t i; s7_pointer *objs; - objs = ci->objs; + objs = ci->objs; for (i = 0; i < ci->top; i++) if (objs[i] == p) { @@ -32827,17 +32830,16 @@ static bool collect_shared_info(s7_scheme *sc, shared_info_t *ci, s7_pointer top { s7_pointer p, q; for (q = top; is_let(q) && (q != sc->rootlet); q = let_outlet(q)) - { - for (p = let_slots(q); tis_slot(p); p = next_slot(p)) - if ((has_structure(slot_value(p))) && - (collect_shared_info(sc, ci, slot_value(p), stop_at_print_length))) - { - top_cyclic = true; - if ((is_c_pointer(slot_value(p))) || - (is_iterator(slot_value(p))) || - (is_c_object(slot_value(p)))) - check_collected(top, ci); - }}} + for (p = let_slots(q); tis_slot(p); p = next_slot(p)) + if ((has_structure(slot_value(p))) && + (collect_shared_info(sc, ci, slot_value(p), stop_at_print_length))) + { + top_cyclic = true; + if ((is_c_pointer(slot_value(p))) || + (is_iterator(slot_value(p))) || + (is_c_object(slot_value(p)))) + check_collected(top, ci); + }} break; case T_CLOSURE: @@ -33056,8 +33058,9 @@ static s7_pointer cyclic_sequences(s7_scheme *sc, s7_pointer obj) int32_t i; s7_pointer lst; sc->w = sc->nil; + check_free_heap_size(sc, ci->top); for (i = 0; i < ci->top; i++) - sc->w = cons(sc, ci->objs[i], sc->w); + sc->w = cons_unchecked(sc, ci->objs[i], sc->w); lst = sc->w; sc->w = sc->nil; return(lst); @@ -33349,10 +33352,9 @@ static inline void symbol_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port if (use_write == P_READABLE) port_write_character(port)(sc, '\'', port); else - { - if (use_write == P_KEY) - port_write_character(port)(sc, ':', port); - }} + if (use_write == P_KEY) + port_write_character(port)(sc, ':', port); + } if (is_string_port(port)) { s7_int new_len; @@ -33443,10 +33445,9 @@ static void make_vector_to_port(s7_scheme *sc, s7_pointer vect, s7_pointer port) if (is_int_vector(vect)) vtyp = "int-"; else - { - if (is_byte_vector(vect)) - vtyp = "byte-"; - }} + if (is_byte_vector(vect)) + vtyp = "byte-"; + } vlen = vector_length(vect); if (vector_rank(vect) == 1) @@ -33698,10 +33699,9 @@ static int32_t print_vector_length(s7_scheme *sc, s7_pointer vect, s7_pointer po if (is_int_vector(vect)) vtype = "i"; else - { - if (is_byte_vector(vect)) - vtype = "u"; - } + if (is_byte_vector(vect)) + vtype = "u"; + len = vector_length(vect); if (len == 0) { @@ -33789,7 +33789,6 @@ static void int_vector_to_port(s7_scheme *sc, s7_pointer vect, s7_pointer port, }} else { - /* an experiment */ s7_int new_len, next_len; uint8_t *dbuf; new_len = port_position(port); @@ -34013,10 +34012,9 @@ static void string_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_w else slashify_string_to_port(sc, port, string_value(obj), string_length(obj), IN_QUOTES); }} else - { - if (use_write != P_DISPLAY) - port_write_string(port)(sc, "\"\"", 2, port); - } + if (use_write != P_DISPLAY) + port_write_string(port)(sc, "\"\"", 2, port); + if (immutable) port_write_character(port)(sc, ')', port); } @@ -34446,11 +34444,9 @@ static void hash_table_to_port(s7_scheme *sc, s7_pointer hash, s7_pointer port, s7_pointer key_val; port_write_character(port)(sc, ' ', port); key_val = hash_table_iterate(sc, iterator); - if (use_write != P_READABLE) - { - if (is_normal_symbol(car(key_val))) - port_write_character(port)(sc, '\'', port); - } + if ((use_write != P_READABLE) && + (is_normal_symbol(car(key_val)))) + port_write_character(port)(sc, '\'', port); object_to_port_with_circle_check(sc, car(key_val), port, NOT_P_DISPLAY(use_write), ci); port_write_character(port)(sc, ' ', port); object_to_port_with_circle_check(sc, cdr(key_val), port, NOT_P_DISPLAY(use_write), ci); @@ -34466,8 +34462,7 @@ static void hash_table_to_port(s7_scheme *sc, s7_pointer hash, s7_pointer port, s7_gc_unprotect_at(sc, gc_iter); iterator_current(iterator) = sc->nil; - free_cell(sc, p); - /* free_cell(sc, iterator); */ /* 18-Dec-18 removed */ + free_cell(sc, p); /* free_cell(sc, iterator); */ /* 18-Dec-18 removed */ } static int32_t slot_to_port_1(s7_scheme *sc, s7_pointer x, s7_pointer port, use_write_t use_write, shared_info_t *ci, int32_t n) @@ -34481,10 +34476,9 @@ static int32_t slot_to_port_1(s7_scheme *sc, s7_pointer x, s7_pointer port, use_ object_to_port_with_circle_check(sc, x, port, use_write, ci); } else - { - if (n == (sc->print_length + 1)) - port_write_string(port)(sc, " ...", 4, port); - }} + if (n == (sc->print_length + 1)) + port_write_string(port)(sc, " ...", 4, port); + } return(n + 1); } @@ -34614,8 +34608,8 @@ static void let_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_writ clear_has_methods(obj); if (use_write == P_WRITE) - p = call_method(sc, obj, print_func, list_1(sc, obj)); - else p = call_method(sc, obj, print_func, list_2(sc, obj, (use_write == P_DISPLAY) ? sc->F : sc->key_readable_symbol)); + p = call_method(sc, obj, print_func, set_plist_1(sc, obj)); + else p = call_method(sc, obj, print_func, set_plist_2(sc, obj, (use_write == P_DISPLAY) ? sc->F : sc->key_readable_symbol)); set_has_methods(obj); if ((is_string(p)) && @@ -34838,10 +34832,8 @@ static void collect_locals(s7_scheme *sc, s7_pointer body, s7_pointer e, s7_poin collect_locals(sc, cdr(body), e, args, gc_loc); } else - { - if (is_symbol(body)) - collect_symbol(sc, body, e, args, gc_loc); - } + if (is_symbol(body)) + collect_symbol(sc, body, e, args, gc_loc); } static void collect_specials(s7_scheme *sc, s7_pointer e, s7_pointer args, s7_int gc_loc) @@ -34960,14 +34952,13 @@ static void write_closure_name(s7_scheme *sc, s7_pointer closure, s7_pointer por if (is_pair(y)) y = car(y); else - { - if (y == sc->key_rest_symbol) - { - port_write_string(port)(sc, ":rest ", 6, port); - args = cdr(args); - y = cadr(args); - if (is_pair(y)) y = car(y); - }}} + if (y == sc->key_rest_symbol) + { + port_write_string(port)(sc, ":rest ", 6, port); + args = cdr(args); + y = cadr(args); + if (is_pair(y)) y = car(y); + }} else { port_write_string(port)(sc, ". ", 2, port); @@ -35011,7 +35002,7 @@ static void write_closure_readably_1(s7_scheme *sc, s7_pointer obj, s7_pointer a if ((is_pair(arglist)) && (allows_other_keys(arglist))) { - sc->temp9 = pair_append(sc, arglist, cons(sc, sc->key_allow_other_keys_symbol, sc->nil)); + sc->temp9 = pair_append(sc, arglist, list_1(sc, sc->key_allow_other_keys_symbol)); object_to_port(sc, sc->temp9, port, P_WRITE, NULL); sc->temp9 = sc->nil; } @@ -35466,7 +35457,7 @@ static void closure_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_ if (print_func != sc->undefined) { s7_pointer p; - p = call_method(sc, obj, print_func, list_1(sc, obj)); + p = call_method(sc, obj, print_func, set_plist_1(sc, obj)); if (string_length(p) > 0) port_write_string(port)(sc, string_value(p), string_length(p), port); return; @@ -36011,7 +36002,7 @@ static s7_pointer g_object_to_string(s7_scheme *sc, s7_pointer args) { s7_int i; if (choice == P_READABLE) /* (object->string #r(1 2 3) :readable 4) */ - return(out_of_range(sc, sc->object_to_string_symbol, int_three, make_integer(sc, out_len), wrap_string(sc, "the readable string is too long", 31))); + return(out_of_range(sc, sc->object_to_string_symbol, int_three, wrap_integer1(sc, out_len), wrap_string(sc, "the readable string is too long", 31))); out_len = pending_max; if (out_len < 3) @@ -36069,7 +36060,7 @@ static s7_pointer newline_p_p(s7_scheme *sc, s7_pointer port) if (!is_output_port(port)) { if (port == sc->F) return(newline_char); - return(method_or_bust_with_type_one_arg(sc, port, sc->newline_symbol, list_1(sc, port), an_output_port_string)); + return(method_or_bust_with_type_one_arg_p(sc, port, sc->newline_symbol, an_output_port_string)); } s7_newline(sc, port); return(newline_char); @@ -36092,7 +36083,7 @@ static s7_pointer write_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer port) { if (port == sc->F) return(x); if (!is_output_port(port)) - return(method_or_bust_with_type(sc, port, sc->write_symbol, list_2(sc, x, port), an_output_port_string, 2)); + return(method_or_bust_with_type_pp(sc, port, sc->write_symbol, x, port, an_output_port_string, 2)); if (port_is_closed(port)) s7_wrong_type_arg_error(sc, "write", 2, port, "an open output port"); return(object_out(sc, x, port, P_WRITE)); @@ -36129,10 +36120,10 @@ static s7_pointer display_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer port) { if (port == sc->F) return(x); if (!is_output_port(port)) - return(method_or_bust_with_type(sc, port, sc->display_symbol, list_2(sc, x, port), an_output_port_string, 2)); + return(method_or_bust_with_type_pp(sc, port, sc->display_symbol, x, port, an_output_port_string, 2)); if (port_is_closed(port)) s7_wrong_type_arg_error(sc, "display", 2, port, "an open output port"); - check_method(sc, x, sc->display_symbol, list_2(sc, x, port)); + check_method(sc, x, sc->display_symbol, set_plist_2(sc, x, port)); return(object_out(sc, x, port, P_DISPLAY)); } @@ -36162,7 +36153,7 @@ static s7_pointer g_display_f(s7_scheme *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 ops) { - if (args == 2) + 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); return(f); } @@ -36170,7 +36161,7 @@ static s7_pointer display_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_ static s7_pointer display_p_p(s7_scheme *sc, s7_pointer x) { if (current_output_port(sc) == sc->F) return(x); - check_method(sc, x, sc->display_symbol, list_1(sc, x)); + check_method(sc, x, sc->display_symbol, set_plist_1(sc, x)); return(object_out(sc, x, current_output_port(sc), P_DISPLAY)); } @@ -36467,10 +36458,9 @@ static s7_int format_nesting(const char *str, char opener, char closer, s7_int s return(k - start - 1); } else - { - if (str[k + 1] == opener) - nesting++; - }} + if (str[k + 1] == opener) + nesting++; + } return(-1); } @@ -36489,8 +36479,8 @@ static bool format_method(s7_scheme *sc, const char *str, format_data_t *fdat, s ctrl_str[2] = '\0'; if (port == obj) /* a problem! we need the openlet port for format, but that's an infinite loop when it calls format again as obj */ - call_method(sc, obj, func, list_3(sc, port, s7_make_string_wrapper(sc, ctrl_str), s7_make_string_wrapper(sc, "#<format port>"))); - else call_method(sc, obj, func, list_3(sc, port, s7_make_string_wrapper(sc, ctrl_str), obj)); + call_method(sc, obj, func, set_plist_3(sc, port, s7_make_string_wrapper(sc, ctrl_str), s7_make_string_wrapper(sc, "#<format port>"))); + else call_method(sc, obj, func, set_plist_3(sc, port, s7_make_string_wrapper(sc, ctrl_str), obj)); fdat->args = cdr(fdat->args); fdat->ctr++; @@ -36510,10 +36500,9 @@ static s7_int format_n_arg(s7_scheme *sc, const char *str, format_data_t *fdat, if (n < 0) just_format_error(sc, "~~N value is negative?", 22, str, args, fdat); else - { - if (n > sc->max_format_length) - just_format_error(sc, "~~N value is too big", 20, str, args, fdat); - } + if (n > sc->max_format_length) + just_format_error(sc, "~~N value is too big", 20, str, args, fdat); + fdat->args = cdr(fdat->args); /* I don't think fdat->ctr should be incremented here -- it's for *vector-print-length* etc */ return(n); } @@ -36802,10 +36791,9 @@ static s7_pointer format_to_port_1(s7_scheme *sc, s7_pointer port, const char *s free_cell(sc, p); /* if car(fdar->args) is a hash-table, we could also free_cell(car(p)), but not in any other case */ }} else - { - if (!is_null(curly_arg)) - format_error(sc, "'{' directive argument should be a list or something we can turn into a list", 76, str, args, fdat); - }} + if (!is_null(curly_arg)) + format_error(sc, "'{' directive argument should be a list or something we can turn into a list", 76, str, args, fdat); + } i += (curly_len + 2); /* jump past the ending '}' too */ fdat->args = cdr(fdat->args); @@ -36970,10 +36958,9 @@ static s7_pointer format_to_port_1(s7_scheme *sc, s7_pointer port, const char *s if (width == -1) format_append_char(sc, character(obj), port); else - { - if (width > 0) - format_append_chars(sc, fdat, character(obj), width, port); - } + if (width > 0) + format_append_chars(sc, fdat, character(obj), width, port); + fdat->args = cdr(fdat->args); fdat->ctr++; }} @@ -37104,10 +37091,9 @@ static s7_pointer format_to_port_1(s7_scheme *sc, s7_pointer port, const char *s if (next_arg) (*next_arg) = fdat->args; else - { - if (is_not_null(fdat->args)) - format_error(sc, "too many arguments", 18, str, args, fdat); - } + if (is_not_null(fdat->args)) + format_error(sc, "too many arguments", 18, str, args, fdat); + if (i < str_len) { if (str[i] == '~') @@ -37288,10 +37274,10 @@ static s7_pointer g_format_as_objstr(s7_scheme *sc, s7_pointer args) ((func = find_method_with_let(sc, obj, sc->format_symbol)) == sc->undefined)) return(s7_object_to_string(sc, obj, false)); - return(call_method(sc, obj, func, list_3(sc, sc->F, cadr(args), obj))); + return(call_method(sc, obj, func, set_plist_3(sc, sc->F, cadr(args), obj))); } -static s7_pointer g_format_allg_no_column(s7_scheme *sc, s7_pointer args) +static s7_pointer g_format_no_column(s7_scheme *sc, s7_pointer args) { s7_pointer pt, str; pt = car(args); @@ -37359,7 +37345,7 @@ static s7_pointer format_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_p /* this used to worry about optimized expr and particular cases -- why? I can't find a broken case */ if (!is_columnizing(string_value(str_arg))) - return(sc->format_allg_no_column); + return(sc->format_no_column); } if (port == sc->F) return(sc->format_f); @@ -37524,7 +37510,7 @@ static s7_pointer g_directory_to_list(s7_scheme *sc, s7_pointer args) name = car(args); if (!is_string(name)) - return(method_or_bust_one_arg(sc, name, sc->directory_to_list_symbol, list_1(sc, name), T_STRING)); + return(method_or_bust_one_arg_p(sc, name, sc->directory_to_list_symbol, T_STRING)); sc->w = sc->nil; if ((dpos = opendir(string_value(name)))) @@ -37587,7 +37573,7 @@ static s7_pointer cons_unchecked(s7_scheme *sc, s7_pointer a, s7_pointer b) static s7_pointer cons_unchecked_with_type(s7_scheme *sc, s7_pointer p, s7_pointer a, s7_pointer b) { - /* apparently slightly faster as a function? */ + /* apparently slightly faster as a function? (used only in copy_tree_with_type) */ s7_pointer x; new_cell_no_check(sc, x, typeflag(p) & (TYPE_MASK | T_IMMUTABLE | T_SAFE_PROCEDURE)); set_car(x, a); @@ -38177,7 +38163,7 @@ static s7_pointer g_tree_count(s7_scheme *sc, s7_pointer args) if ((is_pair(cddr(args))) && (!s7_is_integer(caddr(args)))) return(wrong_type_argument(sc, sc->tree_count_symbol, 3, caddr(args), T_INTEGER)); - /* here we need eqv? not eq? for integers: (tree-count <0-int-zero> <0-not-int-zero>) + /* here we need eqv? not eq? for integers: (tree-count <0-int-zero> <0-not-int-zero>) * perhaps split tree_count|_at_least into eq?/eqv?/equal?/equivalent? cases? * this is used primarily for symbol counts in lint.scm */ @@ -38227,7 +38213,7 @@ s7_pointer s7_reverse(s7_scheme *sc, s7_pointer a) if (is_null(a)) return(a); if (!is_pair(cdr(a))) - return((is_null(cdr(a))) ? cons(sc, car(a), sc->nil) : cons(sc, cdr(a), car(a))); /* don't return 'a' itself */ + return((is_null(cdr(a))) ? list_1(sc, car(a)) : cons(sc, cdr(a), car(a))); /* don't return 'a' itself */ sc->w = list_1(sc, car(a)); for (x = cdr(a), p = a; is_pair(x); x = cdr(x), p = cdr(p)) @@ -38302,10 +38288,10 @@ s7_pointer pair_append(s7_scheme *sc, s7_pointer a, s7_pointer b) s7_pointer p, tp, np; if (is_null(a)) return(b); - tp = cons(sc, car(a), sc->nil); + tp = list_1(sc, car(a)); sc->y = tp; for (p = cdr(a), np = tp; is_pair(p); p = cdr(p), np = cdr(np)) - set_cdr(np, cons(sc, car(p), sc->nil)); + set_cdr(np, list_1(sc, car(p))); set_cdr(np, b); sc->y = sc->nil; @@ -38317,10 +38303,10 @@ static inline s7_pointer copy_proper_list(s7_scheme *sc, s7_pointer lst) s7_pointer p, tp, np; if (!is_pair(lst)) return(sc->nil); sc->u = lst; - tp = cons(sc, car(lst), sc->nil); + tp = list_1(sc, car(lst)); sc->y = tp; for (p = cdr(lst), np = tp; is_pair(p); p = cdr(p), np = cdr(np)) - set_cdr(np, cons(sc, car(p), sc->nil)); + set_cdr(np, list_1(sc, car(p))); sc->y = sc->nil; sc->u = sc->nil; return(tp); @@ -38333,10 +38319,10 @@ static s7_pointer copy_proper_list_with_arglist_error(s7_scheme *sc, s7_pointer if (!is_pair(lst)) s7_error(sc, sc->syntax_error_symbol, set_elist_2(sc, wrap_string(sc, "stray dot?: ~S", 14), lst)); sc->u = lst; - tp = cons(sc, car(lst), sc->nil); + tp = list_1(sc, car(lst)); sc->y = tp; for (p = cdr(lst), np = tp; is_pair(p); p = cdr(p), np = cdr(np)) - set_cdr(np, cons(sc, car(p), sc->nil)); + set_cdr(np, list_1(sc, car(p))); sc->y = sc->nil; sc->u = sc->nil; if (!is_null(p)) @@ -38417,10 +38403,7 @@ static s7_pointer g_is_pair(s7_scheme *sc, s7_pointer args) /* -------------------------------- list? -------------------------------- */ -bool s7_is_list(s7_scheme *sc, s7_pointer p) -{ - return(is_list(p)); -} +bool s7_is_list(s7_scheme *sc, s7_pointer p) {return(is_list(p));} static bool is_list_b(s7_pointer p) {return((is_pair(p)) || (type(p) == T_NIL));} @@ -38473,8 +38456,7 @@ static s7_pointer make_big_list(s7_scheme *sc, s7_int len, s7_pointer init) { s7_pointer result; s7_int i; - - check_heap_size(sc, len); + check_free_heap_size(sc, len); sc->v = sc->nil; for (i = 0; i < len; i++) sc->v = cons_unchecked(sc, init, sc->v); @@ -38544,7 +38526,7 @@ static s7_pointer list_ref_1(s7_scheme *sc, s7_pointer lst, s7_pointer ind) s7_pointer p; if (!s7_is_integer(ind)) - return(method_or_bust(sc, ind, sc->list_ref_symbol, list_2(sc, lst, ind), T_INTEGER, 2)); + return(method_or_bust_pp(sc, ind, sc->list_ref_symbol, lst, ind, T_INTEGER, 2)); index = s7_integer_checked(sc, ind); if ((index < 0) || (index > sc->max_list_length)) return(out_of_range(sc, sc->list_ref_symbol, int_two, ind, (index < 0) ? its_negative_string : its_too_large_string)); @@ -38659,7 +38641,7 @@ static s7_pointer g_list_set_1(s7_scheme *sc, s7_pointer lst, s7_pointer args, i /* (let ((L '((1 2 3) (4 5 6)))) (list-set! L 1 2 32) L) */ if (!is_mutable_pair(lst)) - return(mutable_method_or_bust(sc, lst, sc->list_set_symbol, cons(sc, lst, args), T_PAIR, 1)); + return(mutable_method_or_bust(sc, lst, sc->list_set_symbol, set_ulist_1(sc, lst, args), T_PAIR, 1)); ind = car(args); if ((arg_num > 2) && (is_null(cdr(args)))) @@ -38668,17 +38650,17 @@ static s7_pointer g_list_set_1(s7_scheme *sc, s7_pointer lst, s7_pointer args, i return(ind); } if (!s7_is_integer(ind)) - return(method_or_bust(sc, ind, sc->list_set_symbol, cons(sc, lst, args), T_INTEGER, 2)); + return(method_or_bust(sc, ind, sc->list_set_symbol, set_ulist_1(sc, lst, args), T_INTEGER, 2)); index = s7_integer_checked(sc, ind); if ((index < 0) || (index > sc->max_list_length)) - return(out_of_range(sc, sc->list_set_symbol, make_integer(sc, arg_num), ind, (index < 0) ? its_negative_string : its_too_large_string)); + return(out_of_range(sc, sc->list_set_symbol, wrap_integer1(sc, arg_num), ind, (index < 0) ? its_negative_string : its_too_large_string)); for (i = 0, p = lst; (i < index) && is_pair(p); i++, p = cdr(p)) {} if (!is_pair(p)) { if (is_null(p)) - return(out_of_range(sc, sc->list_set_symbol, make_integer(sc, arg_num), ind, its_too_large_string)); + return(out_of_range(sc, sc->list_set_symbol, wrap_integer1(sc, arg_num), ind, its_too_large_string)); return(wrong_type_argument_with_type(sc, sc->list_set_symbol, 1, lst, a_proper_list_string)); } if (is_null(cddr(args))) @@ -38692,10 +38674,7 @@ static s7_pointer g_list_set_1(s7_scheme *sc, s7_pointer lst, s7_pointer args, i return(cadr(args)); } -static s7_pointer g_list_set(s7_scheme *sc, s7_pointer args) -{ - return(g_list_set_1(sc, car(args), cdr(args), 2)); -} +static s7_pointer g_list_set(s7_scheme *sc, s7_pointer args) {return(g_list_set_1(sc, car(args), cdr(args), 2));} static s7_pointer list_ref_p_pi_unchecked(s7_scheme *sc, s7_pointer p1, s7_int i1) { @@ -38809,11 +38788,11 @@ static s7_pointer list_tail_p_pp(s7_scheme *sc, s7_pointer lst, s7_pointer p) { s7_int i, index; if (!s7_is_integer(p)) - return(method_or_bust(sc, p, sc->list_tail_symbol, list_2(sc, lst, p), T_INTEGER, 2)); + return(method_or_bust_pp(sc, p, sc->list_tail_symbol, lst, p, T_INTEGER, 2)); index = s7_integer_checked(sc, p); if (!is_list(lst)) - return(method_or_bust_with_type(sc, lst, sc->list_tail_symbol, list_2(sc, lst, make_integer(sc, index)), a_list_string, 1)); + return(method_or_bust_with_type_pi(sc, lst, sc->list_tail_symbol, lst, index, a_list_string)); if ((index < 0) || (index > sc->max_list_length)) return(out_of_range(sc, sc->list_tail_symbol, int_two, wrap_integer1(sc, index), (index < 0) ? its_negative_string : its_too_large_string)); @@ -38839,8 +38818,7 @@ static s7_pointer g_cons(s7_scheme *sc, s7_pointer args) #define Q_cons s7_make_signature(sc, 3, sc->is_pair_symbol, sc->T, sc->T) /* set_cdr(args, cadr(args)); - * this is not safe -- it changes a variable's value directly: - * (let ((lst (list 1 2))) (list (apply cons lst) lst)) -> '((1 . 2) (1 . 2)) + * this is not safe -- it changes a variable's value directly: (let ((lst (list 1 2))) (list (apply cons lst) lst)) -> '((1 . 2) (1 . 2)) */ s7_pointer x; new_cell(sc, x, T_PAIR | T_SAFE_PROCEDURE); @@ -39440,7 +39418,7 @@ static s7_pointer assq_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) { return((is_pair(y)) ? s7_assq(sc, x, y) : ((is_null(y)) ? sc->F : - method_or_bust_with_type(sc, y, sc->assq_symbol, list_2(sc, x, y), an_association_list_string, 2))); + method_or_bust_with_type_pp(sc, y, sc->assq_symbol, x, y, an_association_list_string, 2))); } static s7_pointer g_assq(s7_scheme *sc, s7_pointer args) @@ -39461,7 +39439,7 @@ static s7_pointer assv_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) if (!is_pair(y)) { if (is_null(y)) return(sc->F); - return(method_or_bust_with_type(sc, y, sc->assv_symbol, list_2(sc, x, y), an_association_list_string, 2)); + return(method_or_bust_with_type_pp(sc, y, sc->assv_symbol, x, y, an_association_list_string, 2)); } if (is_simple(x)) @@ -39589,10 +39567,10 @@ If 'func' is a function of 2 arguments, it is used for the comparison instead of /* member_if is similar. Do not call eval here with op_eval_done to return! An error will longjmp past the * assoc point, leaving the op_eval_done on the stack, causing s7 to quit. */ - y = cons(sc, args, sc->nil); + y = list_1(sc, args); set_opt1_fast(y, x); set_opt2_slow(y, x); - push_stack(sc, OP_ASSOC_IF, cons(sc, y, sc->nil), eq_func); + push_stack(sc, OP_ASSOC_IF, list_1(sc, y), eq_func); if (needs_copied_args(eq_func)) push_stack(sc, OP_APPLY, list_2(sc, car(args), caar(x)), eq_func); else @@ -39725,7 +39703,7 @@ static s7_pointer memq_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) { return((is_pair(y)) ? s7_memq(sc, x, y) : ((is_null(y)) ? sc->F : - method_or_bust_with_type(sc, y, sc->memq_symbol, list_2(sc, x, y), a_list_string, 2))); + method_or_bust_with_type_pp(sc, y, sc->memq_symbol, x, y, a_list_string, 2))); } static s7_pointer g_memq(s7_scheme *sc, s7_pointer args) @@ -39740,7 +39718,7 @@ static s7_pointer g_memq(s7_scheme *sc, s7_pointer args) return(s7_memq(sc, x, y)); if (is_null(y)) return(sc->F); - return(method_or_bust_with_type(sc, y, sc->memq_symbol, list_2(sc, x, y), a_list_string, 2)); + return(method_or_bust_with_type_pp(sc, y, sc->memq_symbol, x, y, a_list_string, 2)); } /* I think (memq 'c '(a b . c)) should return #f because otherwise (memq () ...) would return the () at the end. */ @@ -39883,7 +39861,7 @@ static s7_pointer memv_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) if (!is_pair(y)) { if (is_null(y)) return(sc->F); - return(method_or_bust_with_type(sc, y, sc->memv_symbol, list_2(sc, x, y), a_list_string, 2)); + return(method_or_bust_with_type_pp(sc, y, sc->memv_symbol, x, y, a_list_string, 2)); } if (is_simple(x)) return(s7_memq(sc, x, y)); @@ -40073,10 +40051,10 @@ member uses equal? If 'func' is a function of 2 arguments, it is used for the c set_no_bool_opt(body); }} - y = cons(sc, args, sc->nil); /* this could probably be handled with a counter cell (cdr here is unused) */ + y = list_1(sc, args); /* this could probably be handled with a counter cell (cdr here is unused) */ set_opt1_fast(y, x); set_opt2_slow(y, x); - push_stack(sc, OP_MEMBER_IF, cons(sc, y, sc->nil), eq_func); + push_stack(sc, OP_MEMBER_IF, list_1(sc, y), eq_func); if (needs_copied_args(eq_func)) push_stack(sc, OP_APPLY, list_2(sc, car(args), car(x)), eq_func); else @@ -40263,7 +40241,7 @@ static s7_pointer safe_list_2(s7_scheme *sc) set_list_in_use(sc->safe_lists[2]); return(sc->safe_lists[2]); } - return(cons_unchecked(sc, sc->nil, cons(sc, sc->nil, sc->nil))); + return(cons_unchecked(sc, sc->nil, list_1(sc, sc->nil))); } static s7_pointer make_safe_list(s7_scheme *sc, s7_int num_args) @@ -40306,10 +40284,15 @@ static s7_pointer g_list_append(s7_scheme *sc, s7_pointer args) push_stack_no_let_no_code(sc, OP_GC_PROTECT, args); for (y = args; is_pair(y); y = cdr(y)) /* arglist so not dotted */ { - s7_pointer p; + s7_pointer p, func; p = car(y); - check_method_unstacking(sc, p, sc->append_symbol, (is_null(tp)) ? y : cons(sc, tp, y)); + if ((has_active_methods(sc, p)) && + ((func = find_method_with_let(sc, p, sc->append_symbol)) != sc->undefined)) + { + unstack(sc); + return(call_method(sc, p, func, (is_null(tp)) ? y : set_ulist_1(sc, tp, y))); + } if (is_null(cdr(y))) { @@ -40331,10 +40314,9 @@ static s7_pointer g_list_append(s7_scheme *sc, s7_pointer args) if (len > 0) set_cdr(np, s7_copy_1(sc, sc->append_symbol, set_plist_2(sc, p, protected_make_list(sc, len, sc->F)))); else - { - if (len < 0) - set_cdr(np, p); - }} + if (len < 0) + set_cdr(np, p); + } sc->y = sc->nil; unstack(sc); return(tp); @@ -40359,14 +40341,14 @@ static s7_pointer g_list_append(s7_scheme *sc, s7_pointer args) if (is_null(tp)) { - tp = cons(sc, car(p), sc->nil); + tp = list_1(sc, car(p)); np = tp; sc->y = tp; /* GC protect? */ pp = cdr(p); } else pp = p; for (; is_pair(pp); pp = cdr(pp), np = cdr(np)) - set_cdr(np, cons(sc, car(pp), sc->nil)); + set_cdr(np, list_1(sc, car(pp))); } else { @@ -40385,10 +40367,9 @@ static s7_pointer g_list_append(s7_scheme *sc, s7_pointer args) for (; is_pair(cdr(np)); np = cdr(np)); } else - { - if (len < 0) - return(wrong_type_argument_with_type(sc, sc->append_symbol, position_of(y, args), p, a_sequence_string)); - }}}} + if (len < 0) + return(wrong_type_argument_with_type(sc, sc->append_symbol, position_of(y, args), p, a_sequence_string)); + }}} unstack(sc); return(tp); } @@ -40662,6 +40643,14 @@ s7_pointer s7_make_vector(s7_scheme *sc, s7_int len) return(v); } +s7_pointer s7_make_and_fill_vector(s7_scheme *sc, s7_int len, s7_pointer fill) +{ + s7_pointer vect; + vect = make_simple_vector(sc, len); + s7_vector_fill(sc, vect, fill); + return(vect); +} + static vdims_t *make_wrap_only(s7_scheme *sc) /* this makes sc->wrap_only */ { vdims_t *v; @@ -40911,7 +40900,7 @@ static s7_pointer g_vector_fill_1(s7_scheme *sc, s7_pointer caller, s7_pointer a if (!is_null(cddr(args))) { s7_pointer p; - p = start_and_end(sc, caller, args, 3, &start, &end); + p = start_and_end(sc, caller, args, 3, cddr(args), &start, &end); if (p != sc->unused) return(p); if (start == end) return(fill); } @@ -41101,7 +41090,7 @@ static s7_pointer g_vector_append(s7_scheme *sc, s7_pointer args) for (k = 0, y = args, v = sc->temp9; k < i; k++, y = cdr(y), v = cdr(v)) set_car(v, car(y)); v = g_vector_append(sc, sc->temp9); - y = call_method(sc, x, func, cons(sc, v, p)); + y = call_method(sc, x, func, set_ulist_1(sc, v, p)); sc->temp9 = sc->nil; return(y); }} @@ -41193,7 +41182,7 @@ s7_pointer s7_vector_to_list(s7_scheme *sc, s7_pointer vect) len = vector_length(vect); if (len == 0) return(sc->nil); - check_heap_size(sc, len); + check_free_heap_size(sc, len); sc->v = sc->nil; for (i = len - 1; i >= 0; i--) sc->v = cons_unchecked(sc, vector_getter(vect)(sc, vect, i), sc->v); @@ -41203,7 +41192,6 @@ s7_pointer s7_vector_to_list(s7_scheme *sc, s7_pointer vect) } #if (!WITH_PURE_S7) -/* -------------------------------- vector->list -------------------------------- */ static s7_pointer g_vector_to_list(s7_scheme *sc, s7_pointer args) { s7_int i, start = 0, end; @@ -41218,19 +41206,17 @@ static s7_pointer g_vector_to_list(s7_scheme *sc, s7_pointer args) end = vector_length(vec); if (!is_null(cdr(args))) { - p = start_and_end(sc, sc->vector_to_list_symbol, args, 2, &start, &end); + p = start_and_end(sc, sc->vector_to_list_symbol, args, 2, cdr(args), &start, &end); if (p != sc->unused) return(p); if (start == end) return(sc->nil); } if ((end - start) > sc->max_list_length) return(out_of_range(sc, sc->vector_to_list_symbol, int_one, car(args), its_too_large_string)); - if ((start == 0) && (end == vector_length(vec))) - return(s7_vector_to_list(sc, vec)); - + check_free_heap_size(sc, end - start); sc->w = sc->nil; for (i = end - 1; i >= start; i--) - sc->w = cons(sc, vector_getter(vec)(sc, vec, i), sc->w); + sc->w = cons_unchecked(sc, vector_getter(vec)(sc, vec, i), sc->w); p = sc->w; sc->w = sc->nil; return(p); @@ -41238,24 +41224,13 @@ static s7_pointer g_vector_to_list(s7_scheme *sc, s7_pointer args) static s7_pointer vector_to_list_p_p(s7_scheme *sc, s7_pointer p) { - s7_pointer val; - sc->temp7 = list_1(sc, p); - val = g_vector_to_list(sc, sc->temp7); - sc->temp7 = sc->nil; - return(val); + if (!is_any_vector(p)) + return(method_or_bust_one_arg_p(sc, p, sc->vector_to_list_symbol, T_VECTOR)); + return(s7_vector_to_list(sc, p)); } #endif -s7_pointer s7_make_and_fill_vector(s7_scheme *sc, s7_int len, s7_pointer fill) -{ - s7_pointer vect; - vect = make_simple_vector(sc, len); - s7_vector_fill(sc, vect, fill); - return(vect); -} - - /* -------------------------------- string->byte-vector -------------------------------- */ static s7_pointer g_string_to_byte_vector(s7_scheme *sc, s7_pointer args) { @@ -41264,7 +41239,7 @@ static s7_pointer g_string_to_byte_vector(s7_scheme *sc, s7_pointer args) s7_pointer str; str = car(args); if (!is_string(str)) - return(method_or_bust(sc, str, sc->string_to_byte_vector_symbol, list_1(sc, str), T_STRING, 1)); + return(method_or_bust_p(sc, str, sc->string_to_byte_vector_symbol, T_STRING)); return(s7_copy_1(sc, sc->string_to_byte_vector_symbol, set_plist_2(sc, str, make_simple_byte_vector(sc, string_length(str))))); } @@ -41277,7 +41252,7 @@ static s7_pointer g_byte_vector_to_string(s7_scheme *sc, s7_pointer args) s7_pointer v; v = car(args); if (!is_byte_vector(v)) - return(method_or_bust(sc, v, sc->byte_vector_to_string_symbol, list_1(sc, v), T_BYTE_VECTOR, 1)); + return(method_or_bust_p(sc, v, sc->byte_vector_to_string_symbol, T_BYTE_VECTOR)); return(s7_copy_1(sc, sc->byte_vector_to_string_symbol, set_plist_2(sc, v, make_empty_string(sc, byte_vector_length(v), 0)))); } @@ -41352,7 +41327,7 @@ static s7_pointer g_float_vector(s7_scheme *sc, s7_pointer args) else { sc->w = sc->nil; - return(method_or_bust(sc, p, sc->float_vector_symbol, copy_proper_list(sc, args), T_REAL, i + 1)); + return(method_or_bust(sc, p, sc->float_vector_symbol, args, T_REAL, i + 1)); }}} sc->w = sc->nil; } @@ -41398,7 +41373,7 @@ static s7_pointer g_int_vector(s7_scheme *sc, s7_pointer args) p = car(x); if (s7_is_integer(p)) int_vector(vec, i) = s7_integer_checked(sc, p); - else return(method_or_bust(sc, p, sc->int_vector_symbol, copy_proper_list(sc, args), T_INTEGER, i + 1)); + else return(method_or_bust(sc, p, sc->int_vector_symbol, args, T_INTEGER, i + 1)); }} return(vec); } @@ -41450,7 +41425,7 @@ static s7_pointer g_byte_vector(s7_scheme *sc, s7_pointer args) b = big_integer_to_s7_int(sc, big_integer(byte)); else #endif - return(method_or_bust(sc, byte, sc->byte_vector_symbol, copy_proper_list(sc, args), T_INTEGER, i + 1)); + return(method_or_bust(sc, byte, sc->byte_vector_symbol, args, T_INTEGER, i + 1)); } if ((b < 0) || (b > 255)) return(simple_wrong_type_argument_with_type(sc, sc->byte_vector_symbol, byte, an_unsigned_byte_string)); @@ -41474,7 +41449,7 @@ static s7_pointer g_list_to_vector(s7_scheme *sc, s7_pointer args) return(s7_make_vector(sc, 0)); if (!s7_is_proper_list(sc, p)) - return(method_or_bust_with_type_one_arg(sc, p, sc->list_to_vector_symbol, list_1(sc, p), a_proper_list_string)); + return(method_or_bust_with_type_one_arg_p(sc, p, sc->list_to_vector_symbol, a_proper_list_string)); p = g_vector(sc, p); sc->temp3 = sc->nil; @@ -41498,14 +41473,14 @@ static s7_pointer g_vector_length(s7_scheme *sc, s7_pointer args) static s7_int vector_length_i_7p(s7_scheme *sc, s7_pointer p) { if (!is_any_vector(p)) - return(integer(method_or_bust_one_arg(sc, p, sc->vector_length_symbol, list_1(sc, p), T_VECTOR))); + return(integer(method_or_bust_one_arg_p(sc, p, sc->vector_length_symbol, T_VECTOR))); return(vector_length(p)); } static s7_pointer vector_length_p_p(s7_scheme *sc, s7_pointer vec) { if (!is_any_vector(vec)) - return(method_or_bust_one_arg(sc, vec, sc->vector_length_symbol, list_1(sc, vec), T_VECTOR)); + return(method_or_bust_one_arg_p(sc, vec, sc->vector_length_symbol, T_VECTOR)); return(make_integer(sc, vector_length(vec))); } #endif @@ -41775,7 +41750,7 @@ static s7_pointer vector_ref_1(s7_scheme *sc, s7_pointer vect, s7_pointer indice s7_pointer p; p = car(x); if (!s7_is_integer(p)) - return(method_or_bust(sc, p, sc->vector_ref_symbol, cons(sc, vect, indices), T_INTEGER, i + 2)); + return(method_or_bust(sc, p, sc->vector_ref_symbol, set_ulist_1(sc, vect, indices), T_INTEGER, i + 2)); n = s7_integer_checked(sc, p); if ((n < 0) || (n >= vector_dimension(vect, i))) @@ -41803,7 +41778,7 @@ static s7_pointer vector_ref_1(s7_scheme *sc, s7_pointer vect, s7_pointer indice p = car(indices); if (!s7_is_integer(p)) - return(method_or_bust(sc, p, sc->vector_ref_symbol, cons(sc, vect, indices), T_INTEGER, 2)); + return(method_or_bust(sc, p, sc->vector_ref_symbol, set_ulist_1(sc, vect, indices), T_INTEGER, 2)); index = s7_integer_checked(sc, p); if ((index < 0) || @@ -41884,8 +41859,7 @@ static s7_pointer vector_ref_p_pii_direct(s7_scheme *sc, s7_pointer v, s7_int i1 static s7_pointer vector_ref_unchecked(s7_scheme *sc, s7_pointer v, s7_int i) { #if S7_DEBUGGING - if (!is_normal_vector(v)) - fprintf(stderr, "%s[%d]: vector is not T_VECTOR\n", __func__, __LINE__); + if (!is_normal_vector(v)) fprintf(stderr, "%s[%d]: vector is not T_VECTOR\n", __func__, __LINE__); #endif return(vector_element(v, i)); } @@ -42208,7 +42182,7 @@ static s7_int multivector_length(s7_scheme *sc, s7_pointer x, s7_pointer caller) wrong_type_argument(sc, caller, position_of(y, x), car(y), T_INTEGER); #if HAVE_OVERFLOW_CHECKS if (multiply_overflow(len, s7_integer_checked(sc, car(y)), &len)) /* or better perhaps len > sc->max_vector_length */ - out_of_range(sc, caller, make_integer(sc, position_of(y, x)), car(y), its_too_large_string); + out_of_range(sc, caller, wrap_integer1(sc, position_of(y, x)), car(y), its_too_large_string); #else len *= s7_integer_checked(sc, car(y)); #endif @@ -42263,10 +42237,9 @@ static s7_pointer g_make_vector_1(s7_scheme *sc, s7_pointer args, s7_pointer cal if (caller == sc->make_float_vector_symbol) result_type = T_FLOAT_VECTOR; else - { - if (caller == sc->make_byte_vector_symbol) - result_type = T_BYTE_VECTOR; - }} + if (caller == sc->make_byte_vector_symbol) + result_type = T_BYTE_VECTOR; + } if (is_pair(cddr(args))) { typf = caddr(args); @@ -42548,7 +42521,7 @@ static s7_pointer make_byte_vector_p_ii(s7_scheme *sc, s7_int len, s7_int init) { s7_pointer p; if ((len < 0) || (len > sc->max_vector_length)) - return(out_of_range(sc, sc->make_byte_vector_symbol, int_one, make_integer(sc, len), (len < 0) ? its_negative_string : its_too_large_string)); + return(out_of_range(sc, sc->make_byte_vector_symbol, int_one, wrap_integer1(sc, len), (len < 0) ? its_negative_string : its_too_large_string)); if ((init < 0) || (init > 255)) return(simple_wrong_type_argument_with_type(sc, sc->make_byte_vector_symbol, make_integer(sc, init), an_unsigned_byte_string)); p = make_simple_byte_vector(sc, len); @@ -42751,7 +42724,7 @@ static Vectorized s7_pointer s7_vector_copy_1(s7_scheme *sc, s7_pointer old_vect else { if (vector_rank(old_vect) > 1) - new_vect = g_make_vector(sc, set_plist_1(sc, g_vector_dimensions(sc, list_1(sc, old_vect)))); + new_vect = g_make_vector(sc, set_plist_1(sc, g_vector_dimensions(sc, set_plist_1(sc, old_vect)))); else new_vect = make_simple_vector(sc, len); } /* here and in vector-fill! we have a problem with bignums -- should new bignums be allocated? (copy_proper_list also) */ @@ -42936,11 +42909,11 @@ static inline s7_pointer float_vector_ref_p_pp(s7_scheme *sc, s7_pointer v, s7_p { s7_int ind; if (!is_float_vector(v)) - return(method_or_bust(sc, v, sc->float_vector_ref_symbol, list_2(sc, v, index), T_FLOAT_VECTOR, 1)); + return(method_or_bust_pp(sc, v, sc->float_vector_ref_symbol, v, index, T_FLOAT_VECTOR, 1)); if (vector_rank(v) != 1) return(univect_ref(sc, set_plist_2(sc, v, index), sc->float_vector_ref_symbol, T_FLOAT_VECTOR)); if (!s7_is_integer(index)) - return(method_or_bust(sc, index, sc->float_vector_ref_symbol, list_2(sc, v, index), T_INTEGER, 2)); + return(method_or_bust_pp(sc, index, sc->float_vector_ref_symbol, v, index, T_INTEGER, 2)); ind = s7_integer_checked(sc, index); if ((ind < 0) || (ind >= vector_length(v))) return(simple_out_of_range(sc, sc->float_vector_ref_symbol, index, (ind < 0) ? its_negative_string : its_too_large_string)); @@ -43170,11 +43143,11 @@ static inline s7_pointer int_vector_ref_p_pp(s7_scheme *sc, s7_pointer v, s7_poi { s7_int ind; if (!is_int_vector(v)) - return(method_or_bust(sc, v, sc->int_vector_ref_symbol, list_2(sc, v, index), T_INT_VECTOR, 1)); + return(method_or_bust_pp(sc, v, sc->int_vector_ref_symbol, v, index, T_INT_VECTOR, 1)); if (vector_rank(v) != 1) return(univect_ref(sc, set_plist_2(sc, v, index), sc->int_vector_ref_symbol, T_INT_VECTOR)); if (!s7_is_integer(index)) - return(method_or_bust(sc, index, sc->int_vector_ref_symbol, list_2(sc, v, index), T_INTEGER, 2)); + return(method_or_bust_pp(sc, index, sc->int_vector_ref_symbol, v, index, T_INTEGER, 2)); ind = s7_integer_checked(sc, index); if ((ind < 0) || (ind >= vector_length(v))) return(simple_out_of_range(sc, sc->int_vector_ref_symbol, index, (ind < 0) ? its_negative_string : its_too_large_string)); @@ -43261,15 +43234,15 @@ static s7_pointer int_vector_set_p_ppp(s7_scheme *sc, s7_pointer v, s7_pointer i else { if (!is_int_vector(v)) - return(method_or_bust(sc, v, sc->int_vector_set_symbol, list_3(sc, v, index, val), T_INT_VECTOR, 1)); + return(method_or_bust_ppp(sc, v, sc->int_vector_set_symbol, v, index, val, T_INT_VECTOR, 1)); if (vector_rank(v) != 1) return(univect_set(sc, list_3(sc, v, index, val), sc->int_vector_set_symbol, T_INT_VECTOR)); if (is_immutable_vector(v)) return(immutable_object_error(sc, set_elist_3(sc, immutable_error_string, sc->int_vector_set_symbol, v))); if (!s7_is_integer(index)) - return(method_or_bust(sc, index, sc->int_vector_set_symbol, list_3(sc, v, index, val), T_INTEGER, 2)); + return(method_or_bust_ppp(sc, index, sc->int_vector_set_symbol, v, index, val, T_INTEGER, 2)); if (!s7_is_integer(val)) - return(method_or_bust(sc, val, sc->int_vector_set_symbol, list_3(sc, v, index, val), T_INTEGER, 3)); + return(method_or_bust_ppp(sc, val, sc->int_vector_set_symbol, v, index, val, T_INTEGER, 3)); #if WITH_GMP { s7_int i; @@ -43485,7 +43458,7 @@ static bool c_function_is_ok(s7_scheme *sc, s7_pointer x) * I tried __builtin_expect throughout eval below. The result was not faster. */ s7_pointer p; - p = lookup_global(sc, car(x)); + p = lookup_global(sc, car(x)); /* uses global_slot if is_global(car(x)), else lookup_checked */ /* this is nearly always global and p == opt1_cfunc(x) * p can be null if we evaluate some code, optimizing it, then eval it again in a context * where the incoming p was undefined(!) -- explicit use of eval and so on. @@ -44049,15 +44022,11 @@ static s7_pointer g_sort(s7_scheme *sc, s7_pointer args) elements = s7_vector_elements(vec); if (is_byte_vector(data)) - { - for (i = 0; i < len; i++) - elements[i] = small_int(chrs[i]); - } + for (i = 0; i < len; i++) + elements[i] = small_int(chrs[i]); else - { - for (i = 0; i < len; i++) - elements[i] = chars[chrs[i]]; - } + for (i = 0; i < len; i++) + elements[i] = chars[chrs[i]]; if (sort_func) { @@ -44065,15 +44034,11 @@ static s7_pointer g_sort(s7_scheme *sc, s7_pointer args) local_qsort_r((void *)elements, len, sizeof(s7_pointer), sort_func, (void *)sc); if (is_byte_vector(data)) - { - for (i = 0; i < len; i++) - chrs[i] = (char)integer(elements[i]); - } + for (i = 0; i < len; i++) + chrs[i] = (char)integer(elements[i]); else - { - for (i = 0; i < len; i++) - chrs[i] = character(elements[i]); - } + for (i = 0; i < len; i++) + chrs[i] = character(elements[i]); sc->v = sc->nil; unstack(sc); /* not pop_stack! */ return(data); @@ -44488,7 +44453,7 @@ static s7_pointer g_hash_table_entries(s7_scheme *sc, s7_pointer args) static s7_int hash_table_entries_i_7p(s7_scheme *sc, s7_pointer p) { if (!is_hash_table(p)) - return(integer(method_or_bust_one_arg(sc, p, sc->hash_table_entries_symbol, list_1(sc, p), T_HASH_TABLE))); + return(integer(method_or_bust_one_arg_p(sc, p, sc->hash_table_entries_symbol, T_HASH_TABLE))); return(hash_table_entries(p)); } @@ -44703,10 +44668,9 @@ static hash_entry_t *hash_number_equivalent(s7_scheme *sc, s7_pointer table, s7_ if (bin_dist <= sc->hash_table_float_epsilon) /* maybe closest is below iprobe, key+eps>iprobe but key maps to iprobe-1 */ i1 = find_number_in_bin(sc, hash_table_element(table, (loc > 0) ? loc - 1 : hash_table_mask(table)), key); else - { - if (bin_dist >= (1.0 - sc->hash_table_float_epsilon)) - i1 = find_number_in_bin(sc, hash_table_element(table, (loc < hash_table_mask(table)) ? loc + 1 : 0), key); - } + if (bin_dist >= (1.0 - sc->hash_table_float_epsilon)) + i1 = find_number_in_bin(sc, hash_table_element(table, (loc < hash_table_mask(table)) ? loc + 1 : 0), key); + return((i1) ? i1 : sc->unentry); #endif } @@ -44738,12 +44702,10 @@ static hash_entry_t *hash_int(s7_scheme *sc, s7_pointer table, s7_pointer key) return(x); } else - { - if (is_t_big_integer(hash_entry_key(x))) - { - if (mpz_get_si(big_integer(hash_entry_key(x))) == kv) - return(x); - }}} + if ((is_t_big_integer(hash_entry_key(x))) && + (mpz_get_si(big_integer(hash_entry_key(x))) == kv)) + return(x); + } #else if (integer(hash_entry_key(x)) == kv) return(x); @@ -45544,11 +45506,10 @@ in the table; it is a cons, defaulting to (cons #t #t) which means any types are }} else { - if (is_any_closure(keyp)) - { - if (!is_symbol(find_closure(sc, keyp, closure_let(keyp)))) - return(wrong_type_argument_with_type(sc, caller, 3, keyp, wrap_string(sc, "a named function", 16))); - }} + if ((is_any_closure(keyp)) && + (!is_symbol(find_closure(sc, keyp, closure_let(keyp))))) + return(wrong_type_argument_with_type(sc, caller, 3, keyp, wrap_string(sc, "a named function", 16))); + } if (is_c_function(valp)) { if (!c_function_name(valp)) @@ -45562,18 +45523,16 @@ in the table; it is a cons, defaulting to (cons #t #t) which means any types are } else { - if (is_any_closure(valp)) - { - if (!is_symbol(find_closure(sc, valp, closure_let(valp)))) - return(wrong_type_argument_with_type(sc, caller, 3, valp, wrap_string(sc, "a named function", 16))); - }} + if ((is_any_closure(valp)) && + (!is_symbol(find_closure(sc, valp, closure_let(valp))))) + return(wrong_type_argument_with_type(sc, caller, 3, valp, wrap_string(sc, "a named function", 16))); + } set_typed_hash_table(ht); }} else - { - if (typers != sc->F) - return(wrong_type_argument_with_type(sc, caller, 3, typers, wrap_string(sc, "(key-type . value-type)", 23))); - }} + if (typers != sc->F) + return(wrong_type_argument_with_type(sc, caller, 3, typers, wrap_string(sc, "(key-type . value-type)", 23))); + } /* check eq_func */ proc = cadr(args); @@ -45894,7 +45853,15 @@ static bool op_implicit_hash_table_ref_a(s7_scheme *sc) static s7_pointer hash_table_ref_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool ops) { - return((args == 2) ? sc->hash_table_ref_2 : f); + if (args == 2) + { + s7_pointer key; + key = caddr(expr); + if ((is_pair(key)) && (car(key) == sc->substring_symbol) && (is_global(sc->substring_symbol))) + set_c_function(key, sc->substring_uncopied); + return(sc->hash_table_ref_2); + } + return(f); } @@ -46136,7 +46103,7 @@ static s7_pointer g_hash_table_set(s7_scheme *sc, s7_pointer args) static s7_pointer hash_table_set_p_ppp(s7_scheme *sc, s7_pointer p1, s7_pointer p2, s7_pointer p3) { if (!is_mutable_hash_table(p1)) /* is_hash_table(p1) is here */ - return(mutable_method_or_bust(sc, p1, sc->hash_table_set_symbol, list_3(sc, p1, p2, p3), T_HASH_TABLE, 1)); + return(mutable_method_or_bust_ppp(sc, p1, sc->hash_table_set_symbol, p1, p2, p3, T_HASH_TABLE, 1)); return(s7_hash_table_set(sc, p1, p2, p3)); } @@ -46478,15 +46445,12 @@ static s7_pointer make_function(s7_scheme *sc, const char *name, s7_function f, if (rst) ftype = T_C_ANY_ARGS_FUNCTION; else - { - if (opt != 0) - ftype = T_C_OPT_ARGS_FUNCTION; - }} - else - { - if (rst) - ftype = T_C_RST_ARGS_FUNCTION; + if (opt != 0) + ftype = T_C_OPT_ARGS_FUNCTION; } + else + if (rst) + ftype = T_C_RST_ARGS_FUNCTION; set_type(x, ftype); @@ -46604,8 +46568,7 @@ static s7_pointer procedure_type_to_symbol(s7_scheme *sc, int32_t type) case T_BACRO: return(sc->bacro_symbol); case T_BACRO_STAR: return(sc->bacro_star_symbol); #if S7_DEBUGGING - default: - fprintf(stderr, "%s[%d] wants %d symbol\n", __func__, __LINE__, type); + default: fprintf(stderr, "%s[%d] wants %d symbol\n", __func__, __LINE__, type); #endif } return(sc->lambda_symbol); @@ -46630,7 +46593,7 @@ static s7_pointer g_procedure_source(s7_scheme *sc, s7_pointer args) if ((is_c_function(p)) || (is_c_macro(p))) return(sc->nil); - check_method_uncopied(sc, p, sc->procedure_source_symbol, list_1(sc, p)); + check_method(sc, p, sc->procedure_source_symbol, set_plist_1(sc, p)); if (has_closure_let(p)) { s7_pointer body; @@ -47154,7 +47117,7 @@ static s7_pointer g_signature(s7_scheme *sc, s7_pointer args) /* this used to get the symbol's value and call g_signature on that */ { s7_pointer slot; - slot = symbol_to_slot(sc, p); + slot = lookup_slot_from(p, sc->curlet); if ((is_slot(slot)) && (slot_has_setter(slot))) { s7_pointer setter; @@ -47283,7 +47246,7 @@ each a function of no arguments, guaranteeing that finish is called even if body static bool is_lambda(s7_scheme *sc, s7_pointer sym) { - return((sym == sc->lambda_symbol) && (symbol_id(sym) == 0)); + return((sym == sc->lambda_symbol) && (symbol_id(sym) == 0)); /* do we need (!sc->in_with_let) ? */ /* symbol_id=0 means it has never been rebound (T_GLOBAL might not be set for initial stuff) */ } @@ -47368,7 +47331,7 @@ static s7_pointer make_unsafe_function_with_class(s7_scheme *sc, s7_pointer cls, int32_t required_args, int32_t optional_args, bool rest_arg) { s7_pointer uf; - uf = s7_make_safe_function(sc, name, f, required_args, optional_args, rest_arg, NULL); + uf = s7_make_function(sc, name, f, required_args, optional_args, rest_arg, NULL); /* was s7_make_safe_function! 14-Dec-20 */ s7_function_set_class(sc, uf, cls); c_function_signature(uf) = c_function_signature(cls); return(uf); @@ -47379,8 +47342,7 @@ static s7_pointer set_function_chooser(s7_scheme *sc, s7_pointer sym, s7_pointer s7_pointer f; f = slot_value(global_slot(sym)); #if S7_DEBUGGING - if (c_function_chooser(f) != fallback_chooser) - fprintf(stderr, "%s[%d]: reset %s chooser\n", __func__, __LINE__, display(sym)); + if (c_function_chooser(f) != fallback_chooser) fprintf(stderr, "%s[%d]: reset %s chooser\n", __func__, __LINE__, display(sym)); #endif c_function_chooser(f) = chooser; return(f); @@ -47527,7 +47489,7 @@ static void init_choosers(s7_scheme *sc) /* string-ref et al */ set_function_chooser(sc, sc->string_ref_symbol, string_substring_chooser); - set_function_chooser(sc, sc->string_to_symbol_symbol, string_substring_chooser); + set_function_chooser(sc, sc->string_to_symbol_symbol, string_substring_chooser); /* not string_to_number here */ set_function_chooser(sc, sc->string_to_keyword_symbol, string_substring_chooser); set_function_chooser(sc, sc->string_downcase_symbol, string_substring_chooser); set_function_chooser(sc, sc->string_upcase_symbol, string_substring_chooser); @@ -47604,7 +47566,7 @@ static void init_choosers(s7_scheme *sc) /* format */ f = set_function_chooser(sc, sc->format_symbol, format_chooser); sc->format_f = make_function_with_class(sc, f, "format", g_format_f, 1, 0, true); - sc->format_allg_no_column = make_function_with_class(sc, f, "format", g_format_allg_no_column, 1, 0, true); + sc->format_no_column = make_function_with_class(sc, f, "format", g_format_no_column, 1, 0, true); sc->format_just_control_string = make_function_with_class(sc, f, "format", g_format_just_control_string, 2, 0, false); sc->format_as_objstr = make_function_with_class(sc, f, "format", g_format_as_objstr, 3, 0, true); @@ -47932,12 +47894,9 @@ static s7_pointer c_object_type_to_let(s7_scheme *sc, s7_pointer cobj) /* should we make new wrappers every time this is called? or save the let somewhere and reuse it? */ } -static void apply_c_object(s7_scheme *sc) /* -------- applicable (new-type) object -------- */ +static void apply_c_object(s7_scheme *sc) /* -------- applicable c_object -------- */ { - /* sc->value = (*(c_object_ref(sc, sc->code)))(sc, cons(sc, sc->code, sc->args)); */ - set_car(sc->u1_1, sc->code); - set_cdr(sc->u1_1, sc->args); - sc->value = (*(c_object_ref(sc, sc->code)))(sc, sc->u1_1); + sc->value = (*(c_object_ref(sc, sc->code)))(sc, set_ulist_1(sc, sc->code, sc->args)); set_car(sc->u1_1, sc->F); } @@ -48025,13 +47984,12 @@ static void op_set_dilambda(s7_scheme *sc) /* ([set!] (dilambda-setter g) s) */ static void op_set_dilambda_sa_a(s7_scheme *sc) { - s7_pointer code, obj, func, val, setter; + s7_pointer code, obj, func, setter; code = cdr(sc->code); func = lookup(sc, caar(code)); obj = lookup(sc, cadar(code)); - val = fx_call(sc, cdr(code)); setter = closure_setter(func); - sc->curlet = update_let_with_two_slots(sc, closure_let(setter), obj, val); + sc->curlet = update_let_with_two_slots(sc, closure_let(setter), obj, fx_call(sc, cdr(code))); sc->value = fx_call(sc, closure_body(setter)); } @@ -48119,13 +48077,12 @@ static void closure_star_arity_1(s7_scheme *sc, s7_pointer x, s7_pointer args) { s7_pointer p; int32_t i; - for (i = 0, p = args; is_pair(p); p = cdr(p)) /* is_pair(p) so (f1 a . b) will end with b not null */ + for (i = 0, p = args; is_pair(p); i++, p = cdr(p)) /* is_pair(p) so (f1 a . b) will end with b not null */ { s7_pointer arg; arg = car(p); if (arg == sc->key_rest_symbol) break; - i++; } closure_set_arity(x, ((is_null(p)) ? i : -1)); /* see below */ }}} @@ -48200,7 +48157,7 @@ s7_pointer s7_arity(s7_scheme *sc, s7_pointer x) return(s7_cons(sc, int_one, int_one)); case T_C_OBJECT: - check_method_uncopied(sc, x, sc->arity_symbol, list_1(sc, x)); + check_method(sc, x, sc->arity_symbol, set_plist_1(sc, x)); return((is_safe_procedure(x)) ? cons(sc, int_zero, max_arity) : sc->F); case T_VECTOR: @@ -48308,7 +48265,7 @@ bool s7_is_aritable(s7_scheme *sc, s7_pointer x, s7_int args) s7_pointer func; if ((has_active_methods(sc, x)) && ((func = find_method_with_let(sc, x, sc->is_aritable_symbol)) != sc->undefined)) - return(call_method(sc, x, func, list_2(sc, x, make_integer(sc, args))) != sc->F); + return(call_method(sc, x, func, set_plist_2(sc, x, make_integer(sc, args))) != sc->F); return(is_safe_procedure(x)); } @@ -48572,7 +48529,7 @@ static s7_pointer g_setter(s7_scheme *sc, s7_pointer args) s7_pointer old_e; old_e = sc->curlet; sc->curlet = e; - slot = symbol_to_slot(sc, sym); + slot = lookup_slot_from(sym, sc->curlet); sc->curlet = old_e; } if (!is_slot(slot)) @@ -48650,12 +48607,12 @@ static s7_pointer g_set_setter(s7_scheme *sc, s7_pointer args) return(s7_wrong_type_arg_error(sc, "set! setter", 2, e, "a let")); old_e = sc->curlet; sc->curlet = e; - slot = symbol_to_slot(sc, sym); + slot = lookup_slot_from(sym, sc->curlet); sc->curlet = old_e; }} else { - slot = symbol_to_slot(sc, sym); /* (set! (setter 'x) (lambda (s v) ...)) */ + slot = lookup_slot_from(sym, sc->curlet); /* (set! (setter 'x) (lambda (s v) ...)) */ func = cadr(args); } if (!is_slot(slot)) @@ -48672,11 +48629,10 @@ static s7_pointer g_set_setter(s7_scheme *sc, s7_pointer args) if (s7_is_aritable(sc, func, 3)) set_has_let_arg(func); else - { - if (!((s7_is_aritable(sc, func, 2)) || - ((is_c_function(func)) && (c_function_has_bool_setter(func))))) - return(s7_error(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "setter function, ~A, should take 2 or 3 arguments", 49), func))); - }} + if (!((s7_is_aritable(sc, func, 2)) || + ((is_c_function(func)) && (c_function_has_bool_setter(func))))) + return(s7_error(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "setter function, ~A, should take 2 or 3 arguments", 49), func))); + } if (slot == global_slot(sym)) s7_set_setter(sc, sym, func); /* special GC protection for global vars */ @@ -48926,10 +48882,7 @@ static bool big_floats_are_equivalent(s7_scheme *sc, mpfr_t x, mpfr_t y) } #endif -static bool eq_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) -{ - return(x == y); -} +static bool eq_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) {return(x == y);} static bool symbol_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) { @@ -49113,7 +49066,7 @@ static bool c_objects_are_equal(s7_scheme *sc, s7_pointer a, s7_pointer b, share s7_pointer equal_func; \ equal_func = find_method_with_let(Sc, X, Sc->is_equivalent_symbol); \ if (equal_func != Sc->undefined) \ - return(s7_boolean(Sc, call_method(Sc, X, equal_func, list_2(Sc, X, Y)))); \ + return(s7_boolean(Sc, call_method(Sc, X, equal_func, set_plist_2(Sc, X, Y)))); \ }} \ while (0) @@ -49323,7 +49276,7 @@ static bool closure_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info s7_pointer equal_func; equal_func = find_method(sc, closure_let(x), sc->is_equal_symbol); if (equal_func != sc->undefined) - return(s7_boolean(sc, call_method(sc, x, equal_func, list_2(sc, x, y)))); + return(s7_boolean(sc, call_method(sc, x, equal_func, set_plist_2(sc, x, y)))); } return(false); } @@ -49579,11 +49532,9 @@ static bool vector_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_ return(false); } else - { - for (i = 0; i < len; i++) - if (!floats_are_equivalent(sc, arr1[i], arr2[i])) - return(false); - } + for (i = 0; i < len; i++) + if (!floats_are_equivalent(sc, arr1[i], arr2[i])) + return(false); return(true); } if (is_int_vector(x)) @@ -49642,10 +49593,9 @@ static bool iterator_equal_1(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_i return(false); } else - { - if (!pair_equal(sc, x_seq, y_seq, ci)) - return(false); - } + if (!pair_equal(sc, x_seq, y_seq, ci)) + return(false); + for (xs = x_seq, ys = y_seq; is_pair(xs) && is_pair(ys); xs = cdr(xs), ys = cdr(ys)) if (xs == iterator_current(x)) return(ys == iterator_current(y)); @@ -49676,10 +49626,9 @@ static bool iterator_equal_1(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_i return(false); } else - { - if (!let_equal(sc, x_seq, y_seq, ci)) - return(false); - } + if (!let_equal(sc, x_seq, y_seq, ci)) + return(false); + for (xs = let_slots(x_seq), ys = let_slots(y_seq); tis_slot(xs) && tis_slot(ys); xs = next_slot(xs), ys = next_slot(ys)) if (xs == iterator_current_slot(x)) return(ys == iterator_current_slot(y)); @@ -50266,14 +50215,14 @@ static s7_pointer iter_length(s7_scheme *sc, s7_pointer lst) {return(s7_length(s static s7_pointer c_obj_length(s7_scheme *sc, s7_pointer lst) { if (!is_global(sc->length_symbol)) - check_method_uncopied(sc, lst, sc->length_symbol, list_1(sc, lst)); + check_method(sc, lst, sc->length_symbol, set_plist_1(sc, lst)); return(c_object_length(sc, lst)); } static s7_pointer lt_length(s7_scheme *sc, s7_pointer lst) { if (!is_global(sc->length_symbol)) - check_method_uncopied(sc, lst, sc->length_symbol, list_1(sc, lst)); + check_method(sc, lst, sc->length_symbol, set_plist_1(sc, lst)); return(make_integer(sc, let_length(sc, lst))); } @@ -50706,10 +50655,8 @@ static s7_pointer s7_copy_1(s7_scheme *sc, s7_pointer caller, s7_pointer args) { s7_pointer slot; if (dest == sc->rootlet) /* (copy (inlet 'a 1) (rootlet)) */ - { - for (slot = let_slots(source); tis_slot(slot); slot = next_slot(slot)) - s7_make_slot(sc, dest, slot_symbol(slot), slot_value(slot)); - } + for (slot = let_slots(source); tis_slot(slot); slot = next_slot(slot)) + s7_make_slot(sc, dest, slot_symbol(slot), slot_value(slot)); else { if ((has_let_fallback(source)) && @@ -50721,10 +50668,9 @@ static s7_pointer s7_copy_1(s7_scheme *sc, s7_pointer caller, s7_pointer args) make_slot_1(sc, dest, slot_symbol(slot), slot_value(slot)); } else - { - for (slot = let_slots(source); tis_slot(slot); slot = next_slot(slot)) - make_slot_1(sc, dest, slot_symbol(slot), slot_value(slot)); - }} + for (slot = let_slots(source); tis_slot(slot); slot = next_slot(slot)) + make_slot_1(sc, dest, slot_symbol(slot), slot_value(slot)); + } return(dest); } end = let_length(sc, source); @@ -50743,7 +50689,7 @@ static s7_pointer s7_copy_1(s7_scheme *sc, s7_pointer caller, s7_pointer args) if (have_indices) { s7_pointer p; - p = start_and_end(sc, caller, args, 3, &start, &end); + p = start_and_end(sc, caller, args, 3, cddr(args), &start, &end); if (p != sc->unused) return(p); } if ((start == 0) && (source == dest)) @@ -50863,10 +50809,9 @@ static s7_pointer s7_copy_1(s7_scheme *sc, s7_pointer caller, s7_pointer args) dst[j] = character(car(p)); }} else - { - for (i = start, j = 0; i < end; i++, j++, p = cdr(p)) - set(sc, dest, j, car(p)); - }} + for (i = start, j = 0; i < end; i++, j++, p = cdr(p)) + set(sc, dest, j, car(p)); + } return(dest); } @@ -50922,22 +50867,18 @@ static s7_pointer s7_copy_1(s7_scheme *sc, s7_pointer caller, s7_pointer args) make_slot_1(sc, dest, slot_symbol(slot), slot_value(slot)); } else - { - for (i = start; i < end; i++, slot = next_slot(slot)) - make_slot_1(sc, dest, slot_symbol(slot), slot_value(slot)); - }} + for (i = start; i < end; i++, slot = next_slot(slot)) + make_slot_1(sc, dest, slot_symbol(slot), slot_value(slot)); + } else { if (is_hash_table(dest)) - { - for (i = start; i < end; i++, slot = next_slot(slot)) - s7_hash_table_set(sc, dest, slot_symbol(slot), slot_value(slot)); - } + for (i = start; i < end; i++, slot = next_slot(slot)) + s7_hash_table_set(sc, dest, slot_symbol(slot), slot_value(slot)); else - { - for (i = start, j = 0; i < end; i++, j++, slot = next_slot(slot)) - set(sc, dest, j, cons(sc, slot_symbol(slot), slot_value(slot))); - }}}} + for (i = start, j = 0; i < end; i++, j++, slot = next_slot(slot)) + set(sc, dest, j, cons(sc, slot_symbol(slot), slot_value(slot))); + }}} return(dest); case T_HASH_TABLE: @@ -50985,13 +50926,12 @@ static s7_pointer s7_copy_1(s7_scheme *sc, s7_pointer caller, s7_pointer args) x = hash_entry_next(x); }} else - { - for (i = start, j = 0; i < end; i++, j++) - { - while (!x) x = elements[++loc]; - set(sc, dest, j, cons(sc, hash_entry_key(x), hash_entry_value(x))); - x = hash_entry_next(x); - }}} + for (i = start, j = 0; i < end; i++, j++) + { + while (!x) x = elements[++loc]; + set(sc, dest, j, cons(sc, hash_entry_key(x), hash_entry_value(x))); + x = hash_entry_next(x); + }} return(dest); } @@ -51191,26 +51131,20 @@ static s7_pointer s7_copy_1(s7_scheme *sc, s7_pointer caller, s7_pointer args) set_car(p, make_integer(sc, els[i])); } else - { - for (i = start, p = dest; (i < end) && (is_pair(p)); i++, p = cdr(p)) - set_car(p, get(sc, source, i)); - }}} - else - { - /* if source == dest here, we're moving data backwards, so this is safe in either case */ - for (i = start, j = 0; i < end; i++, j++) - set(sc, dest, j, get(sc, source, i)); - } + for (i = start, p = dest; (i < end) && (is_pair(p)); i++, p = cdr(p)) + set_car(p, get(sc, source, i)); + }} + else /* if source == dest here, we're moving data backwards, so this is safe in either case */ + for (i = start, j = 0; i < end; i++, j++) + set(sc, dest, j, get(sc, source, i)); + /* some choices probably should raise an error, but don't: * (copy (make-hash-table) "1") ; nothing to copy (empty hash table), so no error */ return(dest); } -s7_pointer s7_copy(s7_scheme *sc, s7_pointer args) -{ - return(s7_copy_1(sc, sc->copy_symbol, args)); -} +s7_pointer s7_copy(s7_scheme *sc, s7_pointer args) {return(s7_copy_1(sc, sc->copy_symbol, args));} #define g_copy s7_copy @@ -51411,12 +51345,11 @@ static s7_pointer g_reverse_in_place(s7_scheme *sc, s7_pointer args) s1 = int_vector_ints(p); s2 = (s7_int *)(s1 + len - 1); if ((len & 0xf) == 0) /* not 0x7 -- odd multiple of 8 will leave center ints unreversed */ - { - while (s1 < s2) - { - s7_int c; - LOOP_8(c = *s1; *s1++ = *s2; *s2-- = c); - }} + while (s1 < s2) + { + s7_int c; + LOOP_8(c = *s1; *s1++ = *s2; *s2-- = c); + } else while (s1 < s2) {s7_int c; c = *s1; *s1++ = *s2; *s2-- = c;} } break; @@ -51432,12 +51365,11 @@ static s7_pointer g_reverse_in_place(s7_scheme *sc, s7_pointer args) s1 = float_vector_floats(p); s2 = (s7_double *)(s1 + len - 1); if ((len & 0xf) == 0) - { - while (s1 < s2) - { - s7_double c; - LOOP_8(c = *s1; *s1++ = *s2; *s2-- = c); - }} + while (s1 < s2) + { + s7_double c; + LOOP_8(c = *s1; *s1++ = *s2; *s2-- = c); + } else while (s1 < s2) {s7_double c; c = *s1; *s1++ = *s2; *s2-- = c;} } break; @@ -51453,12 +51385,11 @@ static s7_pointer g_reverse_in_place(s7_scheme *sc, s7_pointer args) s1 = vector_elements(p); s2 = (s7_pointer *)(s1 + len - 1); if ((len & 0xf) == 0) - { - while (s1 < s2) - { - s7_pointer c; - LOOP_8(c = *s1; *s1++ = *s2; *s2-- = c); - }} + while (s1 < s2) + { + s7_pointer c; + LOOP_8(c = *s1; *s1++ = *s2; *s2-- = c); + } else while (s1 < s2) {s7_pointer c; c = *s1; *s1++ = *s2; *s2-- = c;} } break; @@ -51473,7 +51404,7 @@ static s7_pointer g_reverse_in_place(s7_scheme *sc, s7_pointer args) if ((is_simple_sequence(p)) && (!has_active_methods(sc, p))) return(simple_wrong_type_argument_with_type(sc, sc->reverseb_symbol, p, wrap_string(sc, "a vector, string, or list", 25))); - return(method_or_bust_with_type_one_arg(sc, p, sc->reverseb_symbol, list_1(sc, p), a_sequence_string)); + return(method_or_bust_with_type_one_arg_p(sc, p, sc->reverseb_symbol, a_sequence_string)); } return(p); } @@ -51505,7 +51436,7 @@ static s7_pointer pair_fill(s7_scheme *sc, s7_pointer args) if (end < 0) end = -end; else {if (end == 0) end = 123123123;} if (!is_null(cddr(args))) { - p = start_and_end(sc, sc->fill_symbol, args, 3, &start, &end); + p = start_and_end(sc, sc->fill_symbol, args, 3, cddr(args), &start, &end); if (p != sc->unused) return(p); if (start == end) return(val); } @@ -51750,8 +51681,8 @@ static s7_pointer let_append(s7_scheme *sc, s7_pointer args) { s7_pointer new_let, p, e; e = car(args); + check_method(sc, e, sc->append_symbol, args); push_stack_no_let_no_code(sc, OP_GC_PROTECT, args); - check_method_unstacking(sc, e, sc->append_symbol, args); new_let = make_let_slowly(sc, sc->nil); for (p = args; is_pair(p); p = cdr(p)) s7_copy_1(sc, sc->append_symbol, set_plist_2(sc, car(p), new_let)); @@ -51795,29 +51726,8 @@ static s7_pointer g_append(s7_scheme *sc, s7_pointer args) return(wrong_type_argument_with_type(sc, sc->append_symbol, 1, a1, a_sequence_string)); /* (append 1 0) */ } -s7_pointer s7_append(s7_scheme *sc, s7_pointer a, s7_pointer b) -{ - return(g_append(sc, set_plist_2(sc, a, b))); -} - -static s7_pointer append_p_pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2) -{ - /* plist in use above */ - s7_pointer val; - sc->temp7 = list_2(sc, p1, p2); - val = g_append(sc, sc->temp7); - sc->temp7 = sc->nil; - return(val); -} - -static s7_pointer append_p_ppp(s7_scheme *sc, s7_pointer p1, s7_pointer p2, s7_pointer p3) -{ - s7_pointer val; - sc->temp7 = list_3(sc, p1, p2, p3); - val = g_append(sc, sc->temp7); - sc->temp7 = sc->nil; - return(val); -} +s7_pointer s7_append(s7_scheme *sc, s7_pointer a, s7_pointer b) {return(g_append(sc, set_plist_2(sc, a, b)));} +static s7_pointer append_p_ppp(s7_scheme *sc, s7_pointer p1, s7_pointer p2, s7_pointer p3) {return(g_append(sc, set_plist_3(sc, p1, p2, p3)));} /* -------------------------------- object->let -------------------------------- */ @@ -51827,9 +51737,10 @@ static s7_pointer byte_vector_to_list(s7_scheme *sc, const uint8_t *str, s7_int s7_int i; s7_pointer p; if (len == 0) return(sc->nil); + check_free_heap_size(sc, len); sc->w = sc->nil; for (i = len - 1; i >= 0; i--) - sc->w = cons(sc, small_int((uint32_t)(str[i])), sc->w); + sc->w = cons_unchecked(sc, small_int((uint32_t)(str[i])), sc->w); p = sc->w; sc->w = sc->nil; return(p); @@ -51866,15 +51777,14 @@ static s7_pointer object_to_list(s7_scheme *sc, s7_pointer obj) } x = sc->w; sc->w = sc->nil; - sc->temp8 = sc->nil; - /* free_cell(sc, iterator); */ /* 16-Nov-18 but then 18-Dec-18 got free cell that was iterator */ + sc->temp8 = sc->nil; /* free_cell(sc, iterator); */ /* 16-Nov-18 but then 18-Dec-18 got free cell that was iterator */ return(x); } return(sc->nil); case T_LET: #if (!WITH_PURE_S7) - check_method_uncopied(sc, obj, sc->let_to_list_symbol, list_1(sc, obj)); + check_method(sc, obj, sc->let_to_list_symbol, set_plist_1(sc, obj)); #endif return(s7_let_to_list(sc, obj)); @@ -51913,7 +51823,7 @@ static s7_pointer object_to_list(s7_scheme *sc, s7_pointer obj) } else { - result = cons(sc, val, sc->nil); + result = list_1(sc, val); p = result; } sc->temp8 = result; @@ -51928,7 +51838,7 @@ static s7_pointer object_to_list(s7_scheme *sc, s7_pointer obj) } else { - set_cdr(p, cons(sc, val, sc->nil)); + set_cdr(p, list_1(sc, val)); p = cdr(p); }}}}} @@ -51953,15 +51863,14 @@ static s7_pointer object_to_list(s7_scheme *sc, s7_pointer obj) result = make_list(sc, len, sc->nil); sc->temp8 = result; - z = list_2(sc, obj, sc->F); - zc = cdr(z); + z = list_2(sc, obj, zc = make_mutable_integer(sc, 0)); gc_z = s7_gc_protect_1(sc, z); set_car(sc->z2_1, sc->x); set_car(sc->z2_2, sc->z); for (i = 0, x = result; i < len; i++, x = cdr(x)) { - set_car(zc, make_integer(sc, i)); + integer(zc) = i; set_car(x, (*(c_object_ref(sc, obj)))(sc, z)); } sc->x = car(sc->z2_1); @@ -52113,10 +52022,9 @@ static s7_pointer hash_table_to_let(s7_scheme *sc, s7_pointer obj) if (hash_table_checker(obj) == hash_ci_char) s7_varlet(sc, let, sc->function_symbol, sc->char_ci_eq_symbol); else - { - if (hash_table_checker(obj) == hash_ci_string) - s7_varlet(sc, let, sc->function_symbol, sc->string_ci_eq_symbol); - }} + if (hash_table_checker(obj) == hash_ci_string) + s7_varlet(sc, let, sc->function_symbol, sc->string_ci_eq_symbol); + } #endif }}}}}} if (is_typed_hash_table(obj)) @@ -52155,10 +52063,9 @@ static s7_pointer iterator_to_let(s7_scheme *sc, s7_pointer obj) (is_hash_table(seq))) s7_varlet(sc, let, make_symbol(sc, "position"), make_integer(sc, iterator_position(obj))); else - { - if (is_pair(seq)) - s7_varlet(sc, let, make_symbol(sc, "position"), iterator_current(obj)); - } + if (is_pair(seq)) + s7_varlet(sc, let, make_symbol(sc, "position"), iterator_current(obj)); + s7_gc_unprotect_at(sc, gc_loc); return(let); } @@ -52231,7 +52138,7 @@ static s7_pointer let_to_let(s7_scheme *sc, s7_pointer obj) s7_pointer func; func = find_method(sc, obj, sc->object_to_let_symbol); if (func != sc->undefined) - call_method(sc, obj, func, list_2(sc, obj, let)); + call_method(sc, obj, func, set_plist_2(sc, obj, let)); } s7_gc_unprotect_at(sc, gc_loc); return(let); @@ -52285,7 +52192,7 @@ static s7_pointer c_object_to_let(s7_scheme *sc, s7_pointer obj) s7_pointer func; func = find_method(sc, clet, sc->object_to_let_symbol); if (func != sc->undefined) - call_method(sc, clet, func, list_2(sc, obj, let)); + call_method(sc, clet, func, set_plist_2(sc, obj, let)); } s7_gc_unprotect_at(sc, gc_loc); return(let); @@ -53640,20 +53547,18 @@ It has the additional local variables: error-type, error-data, error-code, error if (is_string(val)) set_car(p, make_string_with_length(sc, string_value(val), string_length(val))); else - { - if (is_t_integer(val)) - set_car(p, make_integer(sc, integer(val))); - }} + if (is_t_integer(val)) + set_car(p, make_integer(sc, integer(val))); + } p = cdr(p); if ((!is_pair(p)) || (p == sp)) break; val = car(p); if (is_t_real(val)) set_car(p, make_real(sc, real(val))); else - { - if (is_string(val)) - set_car(p, make_string_with_length(sc, string_value(val), string_length(val))); - }}} + if (is_string(val)) + set_car(p, make_string_with_length(sc, string_value(val), string_length(val))); + }} sc->gc_off = false; s7_gc_unprotect_at(sc, gc_loc); return(e); @@ -53724,10 +53629,8 @@ static bool catch_all_function(s7_scheme *sc, s7_int i, s7_pointer type, s7_poin if (is_pair(sc->value)) sc->value = (car(sc->value) == sc->quote_symbol) ? cadr(sc->value) : type; else - { - if (is_symbol(sc->value)) - sc->value = type; - } + if (is_symbol(sc->value)) + sc->value = type; return(true); } @@ -54335,14 +54238,13 @@ s7_pointer s7_error(s7_scheme *sc, s7_pointer type, s7_pointer info) sc->s7_call_name = NULL; if ((sc->s7_call_file) && (sc->s7_call_line >= 0)) - { - format_to_port(sc, sc->error_port, "\n; ~A ~A[~D]", - set_plist_3(sc, - s7_make_string_wrapper(sc, call_name), - s7_make_string_wrapper(sc, sc->s7_call_file), - make_integer(sc, sc->s7_call_line)), - false, 13); - }}} + format_to_port(sc, sc->error_port, "\n; ~A ~A[~D]", + set_plist_3(sc, + s7_make_string_wrapper(sc, call_name), + s7_make_string_wrapper(sc, sc->s7_call_file), + make_integer(sc, sc->s7_call_line)), + false, 13); + }} s7_newline(sc, sc->error_port); } @@ -54601,10 +54503,9 @@ static s7_pointer tree_descend(s7_scheme *sc, s7_pointer p, uint32_t line) if (line == 0) /* first line number we encounter will be the current reader location (i.e. the end of the form) */ line = x; else - { - if (x < line) - return(p); - }}} + if (x < line) + return(p); + }} tp = tree_descend(sc, car(p), line); return((tp) ? tp : tree_descend(sc, cdr(p), line)); } @@ -54764,13 +54665,10 @@ static bool call_begin_hook(s7_scheme *sc) * garbage. We had to thwart the optimization by adding if ((flag) && (!flag)) fprintf(...); * So, in the new form (26-Jun-13), the value is passed directly into an s7 variable * that I hope can't be optimized out of existence. - */ - - /* cm/src/Scheme.cpp, used in Snd (listener looking for C-g I think) + * + * cm/src/Scheme.cpp, used in Snd (listener looking for C-g I think) * originally this facility was aimed at interrupting infinite loops, and the expected usage was: - * set begin_hook - * eval-string(...) - * unset begin_hook + * set begin_hook, eval-string(...), unset begin_hook */ opcode_t op; s7_pointer cur_code; @@ -54811,7 +54709,7 @@ static bool call_begin_hook(s7_scheme *sc) return(true); } pop_stack_no_op(sc); - sc->cur_op = op; /* for better error handling. otherwise we get "barrier" as the offending function name in eval_error */ + sc->cur_op = op; /* for better error handling. otherwise we get "barrier" as the offending function name in eval_error */ return(false); } @@ -54926,23 +54824,17 @@ static s7_pointer implicit_index(s7_scheme *sc, s7_pointer obj, s7_pointer indic return(vector_ref_1(sc, obj, indices)); case T_FLOAT_VECTOR: - set_car(sc->u1_1, obj); - set_cdr(sc->u1_1, indices); - res = univect_ref(sc, sc->u1_1, sc->float_vector_ref_symbol, T_FLOAT_VECTOR); + res = univect_ref(sc, set_ulist_1(sc, obj, indices), sc->float_vector_ref_symbol, T_FLOAT_VECTOR); set_car(sc->u1_1, sc->F); return(res); case T_INT_VECTOR: - set_car(sc->u1_1, obj); - set_cdr(sc->u1_1, indices); - res = univect_ref(sc, sc->u1_1, sc->int_vector_ref_symbol, T_INT_VECTOR); + res = univect_ref(sc, set_ulist_1(sc, obj, indices), sc->int_vector_ref_symbol, T_INT_VECTOR); set_car(sc->u1_1, sc->F); return(res); case T_BYTE_VECTOR: - set_car(sc->u1_1, obj); - set_cdr(sc->u1_1, indices); - res = univect_ref(sc, sc->u1_1, sc->byte_vector_ref_symbol, T_BYTE_VECTOR); + res = univect_ref(sc, set_ulist_1(sc, obj, indices), sc->byte_vector_ref_symbol, T_BYTE_VECTOR); set_car(sc->u1_1, sc->F); return(res); @@ -54964,10 +54856,7 @@ static s7_pointer implicit_index(s7_scheme *sc, s7_pointer obj, s7_pointer indic return((is_pair(cdr(indices))) ? implicit_index(sc, obj, cdr(indices)) : obj); case T_C_OBJECT: - /* return((*(c_object_ref(sc, obj)))(sc, cons(sc, obj, indices))); */ - set_car(sc->u1_1, obj); - set_cdr(sc->u1_1, indices); - res = (*(c_object_ref(sc, obj)))(sc, sc->u1_1); + res = (*(c_object_ref(sc, obj)))(sc, set_ulist_1(sc, obj, indices)); set_car(sc->u1_1, sc->F); return(res); @@ -55240,14 +55129,13 @@ pass (rootlet):\n\ if ((sc->safety > NO_SAFETY) && (is_pair(sc->code))) { - check_heap_size(sc, 8192); + check_free_heap_size(sc, 8192); sc->code = copy_body(sc, sc->code); } else - { - if (is_optimized(sc->code)) - clear_all_optimizations(sc, sc->code); - } + if (is_optimized(sc->code)) + clear_all_optimizations(sc, sc->code); + set_current_code(sc, sc->code); if (current_stack_top(sc) < 12) push_stack_op(sc, OP_BARRIER); @@ -55453,7 +55341,7 @@ static s7_pointer g_abort(s7_scheme *sc, s7_pointer args) {abort();} #if S7_DEBUGGING static void check_t_1(s7_scheme *sc, s7_pointer e, const char* func, s7_pointer expr, s7_pointer var) { - if (let_slots(e) != symbol_to_slot(sc, var)) + if (let_slots(e) != lookup_slot_from(var, sc->curlet)) { fprintf(stderr, "%s %s is out of date (%s in %s -> %s)\n", func, @@ -55467,7 +55355,7 @@ static void check_t_1(s7_scheme *sc, s7_pointer e, const char* func, s7_pointer static void check_u_1(s7_scheme *sc, s7_pointer e, const char* func, s7_pointer expr, s7_pointer var) { - if (next_slot(let_slots(e)) != symbol_to_slot(sc, var)) + if (next_slot(let_slots(e)) != lookup_slot_from(var, sc->curlet)) { fprintf(stderr, "%s %s is out of date (%s in %s -> %s)\n", func, @@ -55481,7 +55369,7 @@ static void check_u_1(s7_scheme *sc, s7_pointer e, const char* func, s7_pointer static void check_v_1(s7_scheme *sc, s7_pointer e, const char* func, s7_pointer expr, s7_pointer var) { - if (next_slot(next_slot(let_slots(e))) != symbol_to_slot(sc, var)) + if (next_slot(next_slot(let_slots(e))) != lookup_slot_from(var, sc->curlet)) { fprintf(stderr, "%s %s is out of date (%s in %s -> %s)\n", func, @@ -55578,7 +55466,7 @@ static s7_pointer fx_num_eq_xi_1(s7_scheme *sc, s7_pointer args, s7_pointer val, case T_BIG_RATIO: case T_BIG_COMPLEX: return(sc->F); #endif - default: return(method_or_bust_with_type(sc, val, sc->num_eq_symbol, list_2(sc, val, cadr(args)), a_number_string, 1)); + default: return(method_or_bust_with_type_pp(sc, val, sc->num_eq_symbol, val, cadr(args), a_number_string, 1)); } return(sc->T); } @@ -55602,7 +55490,7 @@ static s7_pointer fx_num_eq_si(s7_scheme *sc, s7_pointer arg) args = cdr(arg); val = lookup(sc, car(args)); y = integer(cadr(args)); - return((is_t_integer(val)) ? make_boolean(sc, integer(val) == y) : + return((is_t_integer(val)) ? make_boolean(sc, integer(val) == y) : ((is_t_real(val)) ? make_boolean(sc, real(val) == y) : fx_num_eq_xi_1(sc, args, val, y))); } @@ -55887,7 +55775,7 @@ static s7_pointer fx_subtract_fs(s7_scheme *sc, s7_pointer arg) return(subtract_p_pp(sc, wrap_real1(sc, n), x)); #endif default: - return(method_or_bust_with_type(sc, x, sc->subtract_symbol, list_2(sc, cadr(arg), x), a_number_string, 2)); + return(method_or_bust_with_type_pp(sc, x, sc->subtract_symbol, cadr(arg), x, a_number_string, 2)); } return(x); } @@ -55946,7 +55834,7 @@ static s7_pointer fx_is_pair_car_s(s7_scheme *sc, s7_pointer arg) s7_pointer func; func = find_method_with_let(sc, p, sc->car_symbol); if (func != sc->undefined) - return(make_boolean(sc, is_pair(call_method(sc, p, func, list_1(sc, p))))); + return(make_boolean(sc, is_pair(call_method(sc, p, func, set_plist_1(sc, p))))); } return(wrong_type_argument(sc, sc->car_symbol, 1, p, T_PAIR)); } @@ -56104,6 +55992,8 @@ static s7_pointer fx_c_u(s7_scheme *sc, s7_pointer arg) return(c_call(arg)(sc, sc->t1_1)); } +static s7_pointer fx_c_s_direct(s7_scheme *sc, s7_pointer arg) {return(((s7_p_p_t)opt2_direct(cdr(arg)))(sc, lookup(sc, cadr(arg))));} +static s7_pointer fx_c_t_direct(s7_scheme *sc, s7_pointer arg) {return(((s7_p_p_t)opt2_direct(cdr(arg)))(sc, t_lookup(sc, cadr(arg), arg)));} static s7_pointer fx_c_u_direct(s7_scheme *sc, s7_pointer arg) {return(((s7_p_p_t)opt2_direct(cdr(arg)))(sc, u_lookup(sc, cadr(arg), arg)));} static s7_pointer fx_is_positive_u(s7_scheme *sc, s7_pointer arg) @@ -56121,8 +56011,6 @@ static s7_pointer fx_is_zero_u(s7_scheme *sc, s7_pointer arg) return((is_t_integer(p1)) ? make_boolean(sc, integer(p1) == 0) : is_zero_p_p(sc, p1)); } -static s7_pointer fx_c_s_direct(s7_scheme *sc, s7_pointer arg) {return(((s7_p_p_t)opt2_direct(cdr(arg)))(sc, lookup(sc, cadr(arg))));} - static s7_pointer fx_real_part_s(s7_scheme *sc, s7_pointer arg) { s7_pointer z; @@ -56137,15 +56025,13 @@ static s7_pointer fx_imag_part_s(s7_scheme *sc, s7_pointer arg) return((is_t_complex(z)) ? make_real(sc, imag_part(z)) : imag_part_p_p(sc, z)); } -static s7_pointer fx_c_t_direct(s7_scheme *sc, s7_pointer arg) {return(((s7_p_p_t)opt2_direct(cdr(arg)))(sc, t_lookup(sc, cadr(arg), arg)));} - static s7_pointer fx_iterate_p_p(s7_scheme *sc, s7_pointer arg) { s7_pointer iter; iter = lookup(sc, cadr(arg)); if (is_iterator(iter)) return((iterator_next(iter))(sc, iter)); - return(method_or_bust_one_arg(sc, iter, sc->iterate_symbol, set_plist_1(sc, iter), T_ITERATOR)); + return(method_or_bust_one_arg_p(sc, iter, sc->iterate_symbol, T_ITERATOR)); } static s7_pointer fx_length_s(s7_scheme *sc, s7_pointer arg) {return(s7_length(sc, lookup(sc, cadr(arg))));} @@ -56389,15 +56275,8 @@ static s7_pointer fx_char_eq_sc(s7_scheme *sc, s7_pointer arg) return(simple_wrong_type_argument(sc, sc->char_eq_symbol, cadr(arg), T_CHARACTER)); } -static s7_pointer fx_c_tc_direct(s7_scheme *sc, s7_pointer arg) -{ - return(((s7_p_pp_t)opt3_direct(cdr(arg)))(sc, t_lookup(sc, cadr(arg), arg), opt2_con(cdr(arg)))); -} - -static s7_pointer fx_vector_ref_direct(s7_scheme *sc, s7_pointer arg) -{ - return(vector_ref_p_pi(sc, t_lookup(sc, cadr(arg), arg), integer(opt2_con(cdr(arg))))); -} +static s7_pointer fx_c_tc_direct(s7_scheme *sc, s7_pointer arg) {return(((s7_p_pp_t)opt3_direct(cdr(arg)))(sc, t_lookup(sc, cadr(arg), arg), opt2_con(cdr(arg))));} +static s7_pointer fx_vector_ref_direct(s7_scheme *sc, s7_pointer arg) {return(vector_ref_p_pi(sc, t_lookup(sc, cadr(arg), arg), integer(opt2_con(cdr(arg)))));} static s7_pointer fx_c_uc(s7_scheme *sc, s7_pointer arg) /* few hits */ { @@ -56557,7 +56436,7 @@ static inline s7_pointer fx_sqr_1(s7_scheme *sc, s7_pointer x) #endif case T_REAL: return(make_real(sc, real(x) * real(x))); case T_COMPLEX: return(s7_make_complex(sc, real_part(x) * real_part(x) - imag_part(x) * imag_part(x), 2.0 * real_part(x) * imag_part(x))); - default: return(method_or_bust_with_type(sc, x, sc->multiply_symbol, list_2(sc, x, x), a_number_string, 1)); + default: return(method_or_bust_with_type_pp(sc, x, sc->multiply_symbol, x, x, a_number_string, 1)); } return(x); #endif @@ -56592,6 +56471,7 @@ static s7_pointer fx_geq_ts(s7_scheme *sc, s7_pointer arg) {return(geq_p_pp(sc, static s7_pointer fx_geq_us(s7_scheme *sc, s7_pointer arg) {return(geq_p_pp(sc, u_lookup(sc, cadr(arg), arg), lookup(sc, opt2_sym(cdr(arg)))));} static s7_pointer fx_geq_tT(s7_scheme *sc, s7_pointer arg) {return(geq_p_pp(sc, t_lookup(sc, cadr(arg), arg), T_lookup(sc, caddr(arg), arg)));} static s7_pointer fx_geq_tu(s7_scheme *sc, s7_pointer arg) {return(geq_p_pp(sc, t_lookup(sc, cadr(arg), arg), u_lookup(sc, caddr(arg), arg)));} + static s7_pointer fx_gt_ss(s7_scheme *sc, s7_pointer arg) {return(gt_p_pp(sc, lookup(sc, cadr(arg)), lookup(sc, opt2_sym(cdr(arg)))));} static s7_pointer fx_gt_ts(s7_scheme *sc, s7_pointer arg) {return(gt_p_pp(sc, t_lookup(sc, cadr(arg), arg), lookup(sc, opt2_sym(cdr(arg)))));} static s7_pointer fx_gt_tu(s7_scheme *sc, s7_pointer arg) {return(gt_p_pp(sc, t_lookup(sc, cadr(arg), arg), u_lookup(sc, caddr(arg), arg)));} @@ -56796,7 +56676,7 @@ static s7_pointer fx_not_is_eq_sq(s7_scheme *sc, s7_pointer arg) { s7_pointer x, y; x = lookup(sc, opt2_sym(cdr(arg))); - y = opt3_any(cdr(arg)); + y = opt3_con(cdr(arg)); return(make_boolean(sc, (x != y) && ((!is_unspecified(x)) || (!is_unspecified(y))))); } @@ -56829,7 +56709,6 @@ static inline s7_pointer fx_hash_table_increment_1(s7_scheme *sc, s7_pointer tab { if (!is_t_integer(hash_entry_value(val))) simple_wrong_type_argument(sc, sc->add_symbol, cadddr(arg), T_INTEGER); - hash_entry_set_value(val, make_integer(sc, integer(hash_entry_value(val)) + 1)); return(hash_entry_value(val)); } @@ -56963,7 +56842,7 @@ static s7_pointer fx_c_css(s7_scheme *sc, s7_pointer arg) static s7_pointer fx_c_csc(s7_scheme *sc, s7_pointer arg) { set_car(sc->t3_2, lookup(sc, opt1_sym(cdr(arg)))); /* caddr(arg) */ - set_car(sc->t3_1, opt3_any(cdr(arg))); + set_car(sc->t3_1, opt3_con(cdr(arg))); /* cadr(arg) or maybe cadadr if quoted? */ set_car(sc->t3_3, opt2_con(cdr(arg))); /* cadddr(arg) */ return(c_call(arg)(sc, sc->t3_1)); } @@ -56971,7 +56850,7 @@ static s7_pointer fx_c_csc(s7_scheme *sc, s7_pointer arg) static s7_pointer fx_c_ccs(s7_scheme *sc, s7_pointer arg) { set_car(sc->t3_3, lookup(sc, opt1_sym(cdr(arg)))); /* cadddr(arg) */ - set_car(sc->t3_1, cadr(arg)); + set_car(sc->t3_1, cadr(arg)); /* maybe opt3_con? */ set_car(sc->t3_2, opt2_con(cdr(arg))); /* caddr(arg) */ return(c_call(arg)(sc, sc->t3_1)); } @@ -57006,15 +56885,6 @@ static s7_pointer fx_c_c_opdq(s7_scheme *sc, s7_pointer arg) return(c_call(arg)(sc, sc->t2_1)); } -static s7_pointer fx_c_opdq_s(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer largs; - largs = cadr(arg); - set_car(sc->t2_1, d_call(sc, largs)); - set_car(sc->t2_2, lookup(sc, opt2_sym(cdr(arg)))); /* caddr(arg) */ - return(c_call(arg)(sc, sc->t2_1)); -} - static inline void gc_protect_via_stack(s7_scheme *sc, s7_pointer val) { sc->stack_end[2] = val; @@ -57035,14 +56905,14 @@ static s7_pointer fx_c_opsq(s7_scheme *sc, s7_pointer arg) static s7_pointer fx_c_optq(s7_scheme *sc, s7_pointer arg) { - set_car(sc->t1_1, t_lookup(sc, cadadr(arg), arg)); + set_car(sc->t1_1, t_lookup(sc, opt1_sym(cdr(arg)), arg)); /* cadadr */ set_car(sc->t1_1, c_call(cadr(arg))(sc, sc->t1_1)); return(c_call(arg)(sc, sc->t1_1)); } static s7_pointer fx_c_optq_direct(s7_scheme *sc, s7_pointer arg) { - return(((s7_p_p_t)opt2_direct(cdr(arg)))(sc, ((s7_p_p_t)opt3_direct(cdr(arg)))(sc, t_lookup(sc, cadadr(arg), arg)))); + return(((s7_p_p_t)opt2_direct(cdr(arg)))(sc, ((s7_p_p_t)opt3_direct(cdr(arg)))(sc, t_lookup(sc, opt1_sym(cdr(arg)), arg)))); } static s7_pointer fx_c_car_s(s7_scheme *sc, s7_pointer arg) @@ -57112,13 +56982,12 @@ static s7_pointer fx_is_type_car_t(s7_scheme *sc, s7_pointer arg) val = t_lookup(sc, opt2_sym(cdr(arg)), arg); if (is_pair(val)) return(make_boolean(sc, (uint8_t)(opt3_byte(cdr(arg))) == type(car(val)))); - - if (has_active_methods(sc, val)) /* this verbosity saves 1/3 total compute time (overhead!) */ + if (has_active_methods(sc, val)) /* this verbosity saves 1/3 total compute time (overhead!) -- old comment, maybe use method_or_bust*? */ { s7_pointer func; func = find_method_with_let(sc, val, sc->car_symbol); if (func != sc->undefined) - return(make_boolean(sc, type(call_method(sc, val, func, list_1(sc, val))) == (uint8_t)opt3_byte(cdr(arg)))); + return(make_boolean(sc, type(call_method(sc, val, func, set_plist_1(sc, val))) == (uint8_t)opt3_byte(cdr(arg)))); } return(wrong_type_argument(sc, sc->car_symbol, 1, val, T_PAIR)); } @@ -57129,13 +56998,12 @@ static s7_pointer fx_c_weak1_type_s(s7_scheme *sc, s7_pointer arg) val = lookup(sc, opt2_sym(cdr(arg))); if (is_c_pointer(val)) /* (let? (c-pointer-weak1 val)) etc */ return(make_boolean(sc, (uint8_t)(opt3_byte(cdr(arg))) == type(c_pointer_weak1(val)))); - if (has_active_methods(sc, val)) { s7_pointer func; func = find_method_with_let(sc, val, sc->c_pointer_weak1_symbol); if (func != sc->undefined) - return(make_boolean(sc, type(call_method(sc, val, func, list_1(sc, val))) == (uint8_t)opt3_byte(cdr(arg)))); + return(make_boolean(sc, type(call_method(sc, val, func, set_plist_1(sc, val))) == (uint8_t)opt3_byte(cdr(arg)))); } return(wrong_type_argument(sc, sc->c_pointer_weak1_symbol, 1, val, T_C_POINTER)); } @@ -57237,6 +57105,15 @@ static s7_pointer fx_c_opscq(s7_scheme *sc, s7_pointer arg) return(c_call(arg)(sc, sc->t1_1)); } +static s7_pointer fx_not_opscq(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer largs; + largs = cadr(arg); + set_car(sc->t2_1, lookup(sc, cadr(largs))); + set_car(sc->t2_2, opt2_con(cdr(largs))); + return((c_call(largs)(sc, sc->t2_1) == sc->F) ? sc->T : sc->F); +} + static s7_pointer fx_c_optcq(s7_scheme *sc, s7_pointer arg) { s7_pointer largs; @@ -57511,7 +57388,7 @@ static s7_pointer fx_c_optq_s(s7_scheme *sc, s7_pointer arg) static s7_pointer fx_c_optq_s_direct(s7_scheme *sc, s7_pointer arg) { return(((s7_p_pp_t)opt2_direct(cdr(arg)))(sc, - ((s7_p_p_t)opt3_direct(cdr(arg)))(sc, t_lookup(sc, cadadr(arg), arg)), + ((s7_p_p_t)opt3_direct(cdr(arg)))(sc, t_lookup(sc, opt1_sym(cdr(arg)), arg)), /* cadadr */ lookup(sc, caddr(arg)))); } @@ -57557,7 +57434,7 @@ static s7_pointer fx_c_optq_cu(s7_scheme *sc, s7_pointer arg) static s7_pointer fx_c_opsq_c(s7_scheme *sc, s7_pointer arg) { - set_car(sc->t1_1, lookup(sc, opt1_con(cdr(arg)))); + set_car(sc->t1_1, lookup(sc, opt1_sym(cdr(arg)))); set_car(sc->t2_1, c_call(cadr(arg))(sc, sc->t1_1)); set_car(sc->t2_2, opt2_con(cdr(arg))); return(c_call(arg)(sc, sc->t2_1)); @@ -57565,7 +57442,7 @@ static s7_pointer fx_c_opsq_c(s7_scheme *sc, s7_pointer arg) static s7_pointer fx_c_optq_c(s7_scheme *sc, s7_pointer arg) { - set_car(sc->t1_1, t_lookup(sc, cadadr(arg), arg)); + set_car(sc->t1_1, t_lookup(sc, opt1_sym(cdr(arg)), arg)); set_car(sc->t2_1, c_call(cadr(arg))(sc, sc->t1_1)); set_car(sc->t2_2, opt2_con(cdr(arg))); return(c_call(arg)(sc, sc->t2_1)); @@ -57573,31 +57450,28 @@ static s7_pointer fx_c_optq_c(s7_scheme *sc, s7_pointer arg) static s7_pointer fx_c_optq_c_direct(s7_scheme *sc, s7_pointer arg) { - return(((s7_p_pp_t)opt3_direct(arg))(sc, ((s7_p_p_t)opt3_direct(cdr(arg)))(sc, t_lookup(sc, cadadr(arg), arg)), opt2_con(cdr(arg)))); + return(((s7_p_pp_t)opt3_direct(arg))(sc, ((s7_p_p_t)opt3_direct(cdr(arg)))(sc, t_lookup(sc, opt1_sym(cdr(arg)), arg)), opt2_con(cdr(arg)))); } static s7_pointer fx_c_optq_i_direct(s7_scheme *sc, s7_pointer arg) { - return(((s7_p_ii_t)opt3_direct(arg))(sc, ((s7_i_7p_t)opt3_direct(cdr(arg)))(sc, t_lookup(sc, cadadr(arg), arg)), integer(opt2_con(cdr(arg))))); + return(((s7_p_ii_t)opt3_direct(arg))(sc, ((s7_i_7p_t)opt3_direct(cdr(arg)))(sc, t_lookup(sc, opt1_sym(cdr(arg)), arg)), integer(opt2_con(cdr(arg))))); } static s7_pointer fx_memq_car_s(s7_scheme *sc, s7_pointer arg) { s7_pointer x, obj; - obj = lookup(sc, opt1_con(cdr(arg))); + obj = lookup(sc, opt1_sym(cdr(arg))); obj = (is_pair(obj)) ? car(obj) : g_car(sc, set_plist_1(sc, obj)); x = opt2_con(cdr(arg)); - while (true) - { - LOOP_4(if (obj == car(x)) return(x); x = cdr(x); if (!is_pair(x)) return(sc->F)); - } + while (true) {LOOP_4(if (obj == car(x)) return(x); x = cdr(x); if (!is_pair(x)) return(sc->F));} return(sc->F); } static s7_pointer fx_memq_car_s_2(s7_scheme *sc, s7_pointer arg) { s7_pointer x, obj; - obj = lookup(sc, opt1_con(cdr(arg))); + obj = lookup(sc, opt1_sym(cdr(arg))); obj = (is_pair(obj)) ? car(obj) : g_car(sc, set_plist_1(sc, obj)); x = opt2_con(cdr(arg)); if (obj == car(x)) return(x); @@ -57620,24 +57494,29 @@ static s7_pointer fx_c_s_opssq_direct(s7_scheme *sc, s7_pointer arg) s7_pointer largs; largs = opt3_pair(arg); /* cdaddr(arg) */ arg = cdr(arg); - return(((s7_p_pp_t)opt2_direct(arg))(sc, lookup(sc, car(arg)), - ((s7_p_pp_t)opt3_direct(arg))(sc, lookup(sc, car(largs)), lookup(sc, opt2_sym(largs))))); + return(((s7_p_pp_t)opt2_direct(arg))(sc, lookup(sc, car(arg)), ((s7_p_pp_t)opt3_direct(arg))(sc, lookup(sc, car(largs)), lookup(sc, opt2_sym(largs))))); +} + +static s7_pointer fx_c_s_opstq_direct(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer largs; + largs = opt3_pair(arg); /* cdaddr(arg) */ + arg = cdr(arg); + return(((s7_p_pp_t)opt2_direct(arg))(sc, lookup(sc, car(arg)), ((s7_p_pp_t)opt3_direct(arg))(sc, lookup(sc, car(largs)), t_lookup(sc, opt2_sym(largs), arg)))); } static s7_pointer fx_vref_g_vref_gs(s7_scheme *sc, s7_pointer arg) { s7_pointer largs; largs = opt3_pair(arg); /* cdaddr(arg); */ - return(vector_ref_p_pp(sc, lookup_global(sc, cadr(arg)), - vector_ref_p_pp(sc, lookup_global(sc, car(largs)), lookup(sc, opt2_sym(largs))))); + return(vector_ref_p_pp(sc, lookup_global(sc, cadr(arg)), vector_ref_p_pp(sc, lookup_global(sc, car(largs)), lookup(sc, opt2_sym(largs))))); } static s7_pointer fx_vref_g_vref_gt(s7_scheme *sc, s7_pointer arg) { s7_pointer largs; largs = opt3_pair(arg); /* cdaddr(arg); */ - return(vector_ref_p_pp(sc, lookup_global(sc, cadr(arg)), - vector_ref_p_pp(sc, lookup_global(sc, car(largs)), t_lookup(sc, opt2_sym(largs), cadr(largs))))); + return(vector_ref_p_pp(sc, lookup_global(sc, cadr(arg)), vector_ref_p_pp(sc, lookup_global(sc, car(largs)), t_lookup(sc, opt2_sym(largs), arg)))); } static s7_pointer fx_c_c_opssq(s7_scheme *sc, s7_pointer arg) @@ -57686,8 +57565,7 @@ static s7_pointer fx_c_s_opscq(s7_scheme *sc, s7_pointer arg) static s7_pointer fx_c_s_opscq_direct(s7_scheme *sc, s7_pointer arg) { - return(((s7_p_pp_t)opt2_direct(cdr(arg)))(sc, lookup(sc, cadr(arg)), - ((s7_p_pp_t)opt3_direct(cdr(arg)))(sc, lookup(sc, opt3_sym(arg)), opt1_con(cdr(arg))))); + return(((s7_p_pp_t)opt2_direct(cdr(arg)))(sc, lookup(sc, cadr(arg)), ((s7_p_pp_t)opt3_direct(cdr(arg)))(sc, lookup(sc, opt3_sym(arg)), opt1_con(cdr(arg))))); } static s7_pointer fx_c_s_opsiq_direct(s7_scheme *sc, s7_pointer arg) @@ -57756,14 +57634,13 @@ static s7_pointer fx_c_s_opsq(s7_scheme *sc, s7_pointer arg) static s7_pointer fx_c_s_opsq_direct(s7_scheme *sc, s7_pointer arg) { arg = cdr(arg); - return(((s7_p_pp_t)opt2_direct(arg))(sc, lookup(sc, car(arg)), ((s7_p_p_t)opt3_direct(arg))(sc, lookup(sc, cadadr(arg))))); + return(((s7_p_pp_t)opt2_direct(arg))(sc, lookup(sc, car(arg)), ((s7_p_p_t)opt3_direct(arg))(sc, lookup(sc, opt1_sym(arg))))); /* cadadr */ } static s7_pointer fx_c_t_opuq_direct(s7_scheme *sc, s7_pointer arg) { arg = cdr(arg); - return(((s7_p_pp_t)opt2_direct(arg))(sc, t_lookup(sc, car(arg), arg), - ((s7_p_p_t)opt3_direct(arg))(sc, u_lookup(sc, cadadr(arg), arg)))); + return(((s7_p_pp_t)opt2_direct(arg))(sc, t_lookup(sc, car(arg), arg), ((s7_p_p_t)opt3_direct(arg))(sc, u_lookup(sc, opt1_sym(arg), arg)))); } static s7_pointer fx_c_s_car_s(s7_scheme *sc, s7_pointer arg) @@ -57837,18 +57714,6 @@ static s7_pointer fx_c_op_opsq_sq(s7_scheme *sc, s7_pointer arg) return(c_call(arg)(sc, sc->t1_1)); } -static s7_pointer fx_c_op_opsq_cq(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer outer, args; - outer = cadr(arg); - args = cadr(outer); - set_car(sc->t1_1, lookup(sc, cadr(args))); - set_car(sc->t2_1, c_call(args)(sc, sc->t1_1)); - set_car(sc->t2_2, opt2_con(cdr(outer))); /* caddr(outer)); */ /* opt2_any(...) */ - set_car(sc->t1_1, c_call(outer)(sc, sc->t2_1)); - return(c_call(arg)(sc, sc->t1_1)); -} - static s7_pointer fx_c_c_opsq(s7_scheme *sc, s7_pointer arg) { s7_pointer largs; @@ -57882,18 +57747,18 @@ static s7_pointer fx_c_opsq_opsq_direct(s7_scheme *sc, s7_pointer arg) static s7_pointer fx_car_car(s7_scheme *sc, s7_pointer arg) { - return(((s7_p_pp_t)opt3_direct(arg))(sc, car_p_p(sc, lookup(sc, cadadr(arg))), car_p_p(sc, lookup(sc, opt1_sym(cdr(arg)))))); /* cadaddr(arg) */ + return(((s7_p_pp_t)opt3_direct(arg))(sc, car_p_p(sc, lookup(sc, opt1_sym(cdr(arg)))), car_p_p(sc, lookup(sc, opt2_sym(cdr(arg)))))); /* cadaddr(arg) */ } static s7_pointer fx_car_car_tu(s7_scheme *sc, s7_pointer arg) { - return(((s7_p_pp_t)opt3_direct(arg))(sc, car_p_p(sc, t_lookup(sc, cadadr(arg), arg)), car_p_p(sc, u_lookup(sc, opt1_sym(cdr(arg)), arg)))); + return(((s7_p_pp_t)opt3_direct(arg))(sc, car_p_p(sc, t_lookup(sc, opt1_sym(cdr(arg)), arg)), car_p_p(sc, u_lookup(sc, opt2_sym(cdr(arg)), arg)))); } static s7_pointer fx_c_optq_optq_direct(s7_scheme *sc, s7_pointer arg) { s7_pointer x; - x = t_lookup(sc, cadadr(arg), arg); + x = t_lookup(sc, opt1_sym(cdr(arg)), arg); /* cadadr and cadaddr */ return(((s7_p_pp_t)opt3_direct(arg))(sc, ((s7_p_p_t)opt2_direct(cdr(arg)))(sc, x), ((s7_p_p_t)opt3_direct(cdr(arg)))(sc, x))); } @@ -58021,18 +57886,6 @@ static s7_pointer fx_sub_vref2(s7_scheme *sc, s7_pointer arg) return(subtract_p_pp(sc, vector_ref_p_pp(sc, v1, p1), vector_ref_p_pp(sc, v1, p2))); } -static s7_pointer fx_c_op_opssqq_c(s7_scheme *sc, s7_pointer code) -{ - s7_pointer arg; - arg = cadadr(code); - set_car(sc->t2_1, lookup(sc, cadr(arg))); - set_car(sc->t2_2, lookup(sc, opt2_sym(cdr(arg)))); - set_car(sc->t1_1, c_call(arg)(sc, sc->t2_1)); - set_car(sc->t2_1, c_call(cadr(code))(sc, sc->t1_1)); - set_car(sc->t2_2, caddr(code)); - return(c_call(code)(sc, sc->t2_1)); -} - static s7_pointer fx_c_op_opsqq(s7_scheme *sc, s7_pointer code) { s7_pointer arg; @@ -58043,34 +57896,6 @@ static s7_pointer fx_c_op_opsqq(s7_scheme *sc, s7_pointer code) return(c_call(code)(sc, sc->t1_1)); } -static s7_pointer fx_c_s_op_s_opsqq(s7_scheme *sc, s7_pointer code) -{ - s7_pointer args, val, val1; - args = caddr(code); - val1 = caddr(args); - val = lookup(sc, cadr(args)); - set_car(sc->t1_1, lookup(sc, cadr(val1))); - set_car(sc->t2_2, c_call(val1)(sc, sc->t1_1)); - set_car(sc->t2_1, val); - set_car(sc->t2_2, c_call(args)(sc, sc->t2_1)); - set_car(sc->t2_1, lookup(sc, cadr(code))); - return(c_call(code)(sc, sc->t2_1)); -} - -static s7_pointer fx_c_s_op_opsq_cq(s7_scheme *sc, s7_pointer code) -{ - s7_pointer args, val, val1; - args = caddr(code); - val1 = cadr(args); - val = lookup(sc, cadr(val1)); - set_car(sc->t1_1, val); - set_car(sc->t2_1, c_call(val1)(sc, sc->t1_1)); - set_car(sc->t2_2, opt2_con(cdr(args))); /* caddr(args) E_C_PC in combine_ops */ - set_car(sc->t2_2, c_call(args)(sc, sc->t2_1)); - set_car(sc->t2_1, lookup(sc, cadr(code))); - return(c_call(code)(sc, sc->t2_1)); -} - static s7_pointer fx_string_ref_t_last(s7_scheme *sc, s7_pointer arg) {return(string_ref_p_plast(sc, t_lookup(sc, cadr(arg), arg), int_zero));} static s7_pointer fx_c_s_op_s_opssqq(s7_scheme *sc, s7_pointer code) @@ -58100,27 +57925,6 @@ static s7_pointer fx_c_s_op_s_opssqq_direct(s7_scheme *sc, s7_pointer code) ((s7_p_pp_t)opt3_direct(cdr(code)))(sc, lookup(sc, cadr(val1)), lookup(sc, caddr(val1)))))); } -static s7_pointer fx_c_op_opsqq_c(s7_scheme *sc, s7_pointer code) -{ - s7_pointer arg; - arg = cadadr(code); - set_car(sc->t1_1, lookup(sc, cadr(arg))); - set_car(sc->t1_1, c_call(arg)(sc, sc->t1_1)); - set_car(sc->t2_1, c_call(cadr(code))(sc, sc->t1_1)); - set_car(sc->t2_2, caddr(code)); - return(c_call(code)(sc, sc->t2_1)); -} - -static s7_pointer fx_string_ref_0_symbol_a(s7_scheme *sc, s7_pointer code) -{ - s7_pointer sym; - set_car(sc->t1_1, lookup(sc, cadr(opt3_pair(code)))); - sym = c_call(opt3_pair(code))(sc, sc->t1_1); - if (is_symbol(sym)) - return(s7_make_character(sc, symbol_name(sym)[0])); - return(simple_wrong_type_argument(sc, sc->symbol_to_string_symbol, car(sc->t1_1), T_SYMBOL)); -} - static s7_pointer fx_c_a(s7_scheme *sc, s7_pointer arg) { set_car(sc->t1_1, fx_call(sc, cdr(arg))); @@ -58135,7 +57939,7 @@ static s7_pointer fx_not_opsaq(s7_scheme *sc, s7_pointer arg) s7_pointer p; p = cadr(arg); set_car(sc->t2_2, fx_call(sc, cddr(p))); - set_car(sc->t2_1, lookup(sc, opt3_any(p))); + set_car(sc->t2_1, lookup(sc, opt3_sym(p))); return((c_call(p)(sc, sc->t2_1) == sc->F) ? sc->T : sc->F); } @@ -58241,7 +58045,7 @@ static s7_pointer fx_c_aa(s7_scheme *sc, s7_pointer arg) static s7_pointer fx_c_ca(s7_scheme *sc, s7_pointer arg) { set_car(sc->t2_2, fx_call(sc, cddr(arg))); - set_car(sc->t2_1, opt3_any(arg)); + set_car(sc->t2_1, opt3_con(arg)); return(c_call(arg)(sc, sc->t2_1)); } @@ -58249,40 +58053,40 @@ static s7_pointer fx_c_ac(s7_scheme *sc, s7_pointer arg) { check_stack_size(sc); /* see test-all */ set_car(sc->t2_1, fx_call(sc, cdr(arg))); - set_car(sc->t2_2, opt3_any(arg)); + set_car(sc->t2_2, opt3_con(arg)); return(c_call(arg)(sc, sc->t2_1)); } static s7_pointer fx_c_sa(s7_scheme *sc, s7_pointer arg) { set_car(sc->t2_2, fx_call(sc, cddr(arg))); - set_car(sc->t2_1, lookup(sc, opt3_any(arg))); + set_car(sc->t2_1, lookup(sc, opt3_sym(arg))); return(c_call(arg)(sc, sc->t2_1)); } static s7_pointer fx_c_as(s7_scheme *sc, s7_pointer arg) { set_car(sc->t2_1, fx_call(sc, cdr(arg))); - set_car(sc->t2_2, lookup(sc, opt3_any(arg))); + set_car(sc->t2_2, lookup(sc, opt3_sym(arg))); return(c_call(arg)(sc, sc->t2_1)); } static s7_pointer fx_c_ta(s7_scheme *sc, s7_pointer arg) { set_car(sc->t2_2, fx_call(sc, cddr(arg))); - set_car(sc->t2_1, t_lookup(sc, opt3_any(arg), arg)); + set_car(sc->t2_1, t_lookup(sc, opt3_sym(arg), arg)); return(c_call(arg)(sc, sc->t2_1)); } static s7_pointer fx_c_at(s7_scheme *sc, s7_pointer arg) { set_car(sc->t2_1, fx_call(sc, cdr(arg))); - set_car(sc->t2_2, t_lookup(sc, opt3_any(arg), arg)); + set_car(sc->t2_2, t_lookup(sc, opt3_sym(arg), arg)); return(c_call(arg)(sc, sc->t2_1)); } -static s7_pointer fx_add_as(s7_scheme *sc, s7_pointer arg) {return(add_p_pp(sc, fx_call(sc, cdr(arg)), lookup(sc, opt3_any(arg))));} -static s7_pointer fx_add_sa(s7_scheme *sc, s7_pointer arg) {return(add_p_pp(sc, lookup(sc, opt3_any(arg)), fx_call(sc, cddr(arg))));} +static s7_pointer fx_add_as(s7_scheme *sc, s7_pointer arg) {return(add_p_pp(sc, fx_call(sc, cdr(arg)), lookup(sc, opt3_sym(arg))));} +static s7_pointer fx_add_sa(s7_scheme *sc, s7_pointer arg) {return(add_p_pp(sc, lookup(sc, opt3_sym(arg)), fx_call(sc, cddr(arg))));} static s7_pointer fx_is_zero_remainder(s7_scheme *sc, s7_pointer arg) { @@ -58503,17 +58307,6 @@ static s7_pointer fx_c_c_opscq(s7_scheme *sc, s7_pointer arg) return(c_call(arg)(sc, sc->t2_1)); } -static s7_pointer fx_c_c_opcsq(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer largs; - largs = caddr(arg); - set_car(sc->t2_2, lookup(sc, caddr(largs))); - set_car(sc->t2_1, opt1_con(cdr(largs))); /* cadr(largs) or cadadr */ - set_car(sc->t2_2, c_call(largs)(sc, sc->t2_1)); - set_car(sc->t2_1, cadr(arg)); - return(c_call(arg)(sc, sc->t2_1)); -} - static s7_pointer fx_c_s_opcsq(s7_scheme *sc, s7_pointer arg) { s7_pointer largs; @@ -58547,38 +58340,6 @@ static s7_pointer fx_c_op_opssqq_s_direct(s7_scheme *sc, s7_pointer code) lookup(sc, caddr(code)))); } -static s7_pointer fx_c_op_opssq_sq_s(s7_scheme *sc, s7_pointer code) -{ - s7_pointer arg; - arg = opt3_pair(code); /* cadadr(code); */ - set_car(sc->t2_1, lookup(sc, cadr(arg))); - set_car(sc->t2_2, lookup(sc, opt2_sym(cdr(arg)))); - set_car(sc->t2_1, c_call(arg)(sc, sc->t2_1)); - set_car(sc->t2_2, lookup(sc, opt1_sym(cdr(code)))); - set_car(sc->t2_1, c_call(cadr(code))(sc, sc->t2_1)); - set_car(sc->t2_2, lookup(sc, caddr(code))); - return(c_call(code)(sc, sc->t2_1)); -} - -static s7_pointer fx_c_s_op_opssq_opssqq(s7_scheme *sc, s7_pointer code) -{ - s7_pointer args, op1, op2; - args = caddr(code); - op1 = cadr(args); - op2 = caddr(args); - set_car(sc->t2_1, lookup(sc, cadr(op1))); - set_car(sc->t2_2, lookup(sc, opt2_sym(cdr(op1)))); - gc_protect_via_stack(sc, c_call(op1)(sc, sc->t2_1)); - set_car(sc->t2_1, lookup(sc, cadr(op2))); - set_car(sc->t2_2, lookup(sc, opt2_sym(cdr(op2)))); - set_car(sc->t2_2, c_call(op2)(sc, sc->t2_1)); - set_car(sc->t2_1, sc->stack_end[-2]); - set_car(sc->t2_2, c_call(args)(sc, sc->t2_1)); - set_car(sc->t2_1, lookup(sc, cadr(code))); - sc->stack_end -= 4; - return(c_call(code)(sc, sc->t2_1)); -} - static s7_pointer fx_c_all_s(s7_scheme *sc, s7_pointer arg) { s7_pointer args, p, lst; @@ -58948,12 +58709,12 @@ static s7_pointer fx_safe_closure_s_to_s(s7_scheme *sc, s7_pointer arg) static s7_pointer fx_safe_closure_s_to_sc(s7_scheme *sc, s7_pointer arg) { - set_car(sc->t2_2, opt3_any(cdr(arg))); + set_car(sc->t2_2, opt3_con(cdr(arg))); set_car(sc->t2_1, lookup(sc, opt2_sym(arg))); return(c_call(car(closure_body(opt1_lambda(arg))))(sc, sc->t2_1)); } -static s7_pointer fx_safe_closure_s_to_vref(s7_scheme *sc, s7_pointer arg) {return(vector_ref_p_pp(sc, lookup(sc, opt2_sym(arg)), opt3_any(cdr(arg))));} +static s7_pointer fx_safe_closure_s_to_vref(s7_scheme *sc, s7_pointer arg) {return(vector_ref_p_pp(sc, lookup(sc, opt2_sym(arg)), opt3_con(cdr(arg))));} static s7_pointer fx_safe_closure_s_to_sub1(s7_scheme *sc, s7_pointer arg) { @@ -58990,11 +58751,11 @@ static s7_pointer fx_c_ff(s7_scheme *sc, s7_pointer arg) static s7_pointer fx_safe_closure_a_to_sc(s7_scheme *sc, s7_pointer arg) { set_car(sc->t2_1, fx_call(sc, cdr(arg))); - set_car(sc->t2_2, opt3_any(cdr(arg))); + set_car(sc->t2_2, opt3_con(cdr(arg))); return(c_call(car(closure_body(opt1_lambda(arg))))(sc, sc->t2_1)); } -static s7_pointer fx_safe_closure_a_to_vref(s7_scheme *sc, s7_pointer arg) {return(vector_ref_p_pp(sc, fx_call(sc, cdr(arg)), opt3_any(cdr(arg))));} +static s7_pointer fx_safe_closure_a_to_vref(s7_scheme *sc, s7_pointer arg) {return(vector_ref_p_pp(sc, fx_call(sc, cdr(arg)), opt3_con(cdr(arg))));} static s7_pointer fx_closure_s_and_2(s7_scheme *sc, s7_pointer code) /* safe_closure_s_a where "a" is fx_and_2 */ { @@ -59093,14 +58854,13 @@ static s7_pointer op_safe_closure_3s_a(s7_scheme *sc, s7_pointer code) static s7_pointer fx_safe_closure_aa_a(s7_scheme *sc, s7_pointer code) { - s7_pointer p; + s7_pointer f, p; p = cdr(code); gc_protect_via_stack(sc, sc->curlet); /* this is needed even if one of the args is a symbol, so nothing is saved by splitting out that case */ sc->stack_end[-4] = fx_call(sc, cdr(p)); - sc->stack_end[-3] = fx_call(sc, p); - p = opt1_lambda(code); - sc->curlet = update_let_with_two_slots(sc, closure_let(p), sc->stack_end[-3], sc->stack_end[-4]); - p = fx_call(sc, closure_body(p)); + f = opt1_lambda(code); + sc->curlet = update_let_with_two_slots(sc, closure_let(f), fx_call(sc, p), sc->stack_end[-4]); + p = fx_call(sc, closure_body(f)); sc->curlet = sc->stack_end[-2]; sc->stack_end -= 4; return(p); @@ -59140,7 +58900,7 @@ static bool is_gxable(s7_pointer p) opcode_t op; if (!is_optimized(p)) return(false); op = optimize_op(p); - return((symbol_ctr(car(p)) == 1) && + return((is_symbol(car(p))) && (symbol_ctr(car(p)) == 1) && (op < FIRST_UNHOPPABLE_OP) && (op > OP_GC_PROTECT) && (fx_function[op | 1])); @@ -59167,7 +58927,14 @@ static s7_p_dd_t s7_p_dd_function(s7_pointer f); static s7_p_pi_t s7_p_pi_function(s7_pointer f); static s7_p_ii_t s7_p_ii_function(s7_pointer f); -#define is_global_and_has_func(P, Func) ((is_global(P)) && (Func(slot_value(global_slot(P))))) +#define is_unchanged_global(P) ((is_symbol(P)) && (is_global(P)) && (symbol_id(P) == 0) && (slot_value(initial_slot(P)) == slot_value(global_slot(P)))) +#define is_global_and_has_func(P, Func) ((is_symbol(P)) && (is_unchanged_global(P)) && (Func(slot_value(global_slot(P))))) /* Func = s7_p_pp_function and friends */ + +static bool fx_matches(s7_pointer symbol, s7_pointer target_symbol) +{ + return((symbol == target_symbol) && + (is_unchanged_global(symbol))); +} static s7_function fx_choose(s7_scheme *sc, s7_pointer holder, s7_pointer e, safe_sym_t *checker) { @@ -59186,7 +58953,7 @@ static s7_function fx_choose(s7_scheme *sc, s7_pointer holder, s7_pointer e, saf } return(fx_c); } - + if (is_optimized(arg)) { switch (optimize_op(arg)) @@ -59231,13 +58998,13 @@ static s7_function fx_choose(s7_scheme *sc, s7_pointer holder, s7_pointer e, saf return(fx_and_2); case HOP_SAFE_C_S: - if (car(arg) == sc->cdr_symbol) return(fx_cdr_s); - if (car(arg) == sc->car_symbol) return(fx_car_s); - if (car(arg) == sc->cadr_symbol) return(fx_cadr_s); - if (car(arg) == sc->cddr_symbol) return(fx_cddr_s); - if (is_global(car(arg))) /* guard against (op arg) where arg is a let with an op method */ + if (is_unchanged_global(car(arg))) { uint8_t typ; + if (car(arg) == sc->cdr_symbol) return(fx_cdr_s); + if (car(arg) == sc->car_symbol) return(fx_car_s); + if (car(arg) == sc->cadr_symbol) return(fx_cadr_s); + if (car(arg) == sc->cddr_symbol) return(fx_cddr_s); if (car(arg) == sc->is_null_symbol) return(fx_is_null_s); if (car(arg) == sc->is_pair_symbol) return(fx_is_pair_s); if (car(arg) == sc->is_symbol_symbol) return(fx_is_symbol_s); @@ -59255,9 +59022,7 @@ static s7_function fx_choose(s7_scheme *sc, s7_pointer holder, s7_pointer e, saf { set_opt3_byte(cdr(arg), typ); return(fx_is_type_s); - }} - if ((symbol_id(car(arg)) == 0) && (is_slot(global_slot(car(arg))))) - { + } /* car_p_p (et al) does not look for a method so in: * (define kar car) (load "mockery.scm") (let ((p (mock-pair '(1 2 3)))) (call-with-exit (lambda (x) (x (kar p))))) * "kar" fails but not "car" because symbol_id(kar) == 0! symbol_id(car) > 0 because mockery provides a method for it. @@ -59279,12 +59044,12 @@ static s7_function fx_choose(s7_scheme *sc, s7_pointer holder, s7_pointer e, saf case HOP_SAFE_C_SS: if (c_callee(arg) == g_cons) return(fx_cons_ss); - if (car(arg) == sc->num_eq_symbol) return(fx_num_eq_ss); + if (fx_matches(car(arg), sc->num_eq_symbol)) return(fx_num_eq_ss); if (c_callee(arg) == g_geq_2) return(fx_geq_ss); if (c_callee(arg) == g_greater_2) return(fx_gt_ss); if (c_callee(arg) == g_leq_2) return(fx_leq_ss); if (c_callee(arg) == g_less_2) return((is_global(caddr(arg))) ? fx_lt_sg : fx_lt_ss); - if ((car(arg) == sc->multiply_symbol) && (cadr(arg) == caddr(arg))) return(fx_sqr_s); + if ((fx_matches(car(arg), sc->multiply_symbol)) && (cadr(arg) == caddr(arg))) return(fx_sqr_s); if (c_callee(arg) == g_multiply_2) return(fx_multiply_ss); if (c_callee(arg) == g_is_eq) return(fx_is_eq_ss); if (c_callee(arg) == g_add_2) return(fx_add_ss); @@ -59359,8 +59124,7 @@ static s7_function fx_choose(s7_scheme *sc, s7_pointer holder, s7_pointer e, saf { s7_pointer s2; s2 = caddr(arg); - if ((car(s2) == sc->multiply_symbol) && (cadr(s2) == caddr(s2))) - return(fx_c_s_sqr); + if ((fx_matches(car(s2), sc->multiply_symbol)) && (cadr(s2) == caddr(s2))) return(fx_c_s_sqr); } if ((is_global_and_has_func(car(arg), s7_p_pp_function)) && (is_global_and_has_func(caaddr(arg), s7_p_pp_function))) @@ -59412,14 +59176,14 @@ static s7_function fx_choose(s7_scheme *sc, s7_pointer holder, s7_pointer e, saf s1 = cadr(arg); s2 = caddr(arg); set_opt3_pair(arg, cdaddr(arg)); - if ((car(s1) == sc->multiply_symbol) && (car(s2) == sc->multiply_symbol)) + if ((fx_matches(car(s1), sc->multiply_symbol)) && (car(s2) == sc->multiply_symbol)) { if ((cadr(s1) == caddr(s1)) && (cadr(s2) == caddr(s2))) return(fx_c_sqr_sqr); if (car(arg) == sc->subtract_symbol) return(fx_sub_mul2); if (car(arg) == sc->add_symbol) return(fx_add_mul2); } - if ((car(arg) == sc->lt_symbol) && (car(s1) == sc->subtract_symbol) && (car(s2) == sc->subtract_symbol)) return(fx_lt_sub2); - if ((car(arg) == sc->subtract_symbol) && (car(s1) == sc->vector_ref_symbol) && (car(s2) == sc->vector_ref_symbol) && (cadr(s1) == cadr(s2))) + if ((fx_matches(car(arg), sc->lt_symbol)) && (fx_matches(car(s1), sc->subtract_symbol)) && (car(s2) == sc->subtract_symbol)) return(fx_lt_sub2); + if ((fx_matches(car(arg), sc->subtract_symbol)) && (fx_matches(car(s1), sc->vector_ref_symbol)) && (car(s2) == sc->vector_ref_symbol) && (cadr(s1) == cadr(s2))) { set_opt3_sym(arg, cadr(cdaddr(arg))); return(fx_sub_vref2); @@ -59428,26 +59192,26 @@ static s7_function fx_choose(s7_scheme *sc, s7_pointer holder, s7_pointer e, saf } case HOP_SAFE_C_opSq: - if (is_global(caadr(arg))) + if (is_unchanged_global(caadr(arg))) { - if (car(arg) == sc->is_pair_symbol) /* h_safe so no need to check pair? */ + if (fx_matches(car(arg), sc->is_pair_symbol)) { if (caadr(arg) == sc->car_symbol) {set_opt2_sym(cdr(arg), cadadr(arg)); return(fx_is_pair_car_s);} if (caadr(arg) == sc->cdr_symbol) {set_opt2_sym(cdr(arg), cadadr(arg)); return(fx_is_pair_cdr_s);} if (caadr(arg) == sc->cadr_symbol) {set_opt2_sym(cdr(arg), cadadr(arg)); return(fx_is_pair_cadr_s);} if (caadr(arg) == sc->cddr_symbol) {set_opt2_sym(cdr(arg), cadadr(arg)); return(fx_is_pair_cddr_s);} } - if (car(arg) == sc->is_null_symbol) + if (fx_matches(car(arg), sc->is_null_symbol)) { if (caadr(arg) == sc->cdr_symbol) {set_opt2_sym(cdr(arg), cadadr(arg)); return(fx_is_null_cdr_s);} if (caadr(arg) == sc->cadr_symbol) {set_opt2_sym(cdr(arg), cadadr(arg)); return(fx_is_null_cadr_s);} if (caadr(arg) == sc->cddr_symbol) {set_opt2_sym(cdr(arg), cadadr(arg)); return(fx_is_null_cddr_s);} } - if ((car(arg) == sc->is_symbol_symbol) && + if ((fx_matches(car(arg), sc->is_symbol_symbol)) && (caadr(arg) == sc->cadr_symbol)) {set_opt2_sym(cdr(arg), cadadr(arg)); return(fx_is_symbol_cadr_s);} - if (car(arg) == sc->not_symbol) + if (fx_matches(car(arg), sc->not_symbol)) { if (caadr(arg) == sc->is_pair_symbol) {set_opt3_sym(arg, cadadr(arg)); return(fx_not_is_pair_s);} if (caadr(arg) == sc->is_null_symbol) {set_opt3_sym(arg, cadadr(arg)); return(fx_not_is_null_s);} @@ -59455,11 +59219,11 @@ static s7_function fx_choose(s7_scheme *sc, s7_pointer holder, s7_pointer e, saf return(fx_not_opsq); } #if WITH_GMP - if ((car(arg) == sc->floor_symbol) && (caadr(arg) == sc->sqrt_symbol)) + if ((fx_matches(car(arg), sc->floor_symbol)) && (caadr(arg) == sc->sqrt_symbol)) {set_opt2_sym(cdr(arg), cadadr(arg)); return(fx_floor_sqrt_s);} #endif } - if (is_global(car(arg))) /* (? (op arg)) where (op arg) might return a let with a ? method etc */ + if (is_unchanged_global(car(arg))) /* (? (op arg)) where (op arg) might return a let with a ? method etc */ { /* other possibility: fx_c_a */ uint8_t typ; typ = symbol_type(car(arg)); @@ -59469,15 +59233,15 @@ static s7_function fx_choose(s7_scheme *sc, s7_pointer holder, s7_pointer e, saf set_opt3_byte(cdr(arg), typ); if (c_callee(cadr(arg)) == (s7_function)g_c_pointer_weak1) return(fx_c_weak1_type_s); - return((caadr(arg) == sc->car_symbol) ? fx_is_type_car_s : fx_is_type_opsq); + return(fx_matches(caadr(arg), sc->car_symbol) ? fx_is_type_car_s : fx_is_type_opsq); }} /* this should follow the is_type* check above */ - if (caadr(arg) == sc->car_symbol) + if (fx_matches(caadr(arg), sc->car_symbol)) { set_opt2_sym(cdr(arg), cadadr(arg)); return(fx_c_car_s); } - if (caadr(arg) == sc->cdr_symbol) + if (fx_matches(caadr(arg), sc->cdr_symbol)) { set_opt2_sym(cdr(arg), cadadr(arg)); return(fx_c_cdr_s); @@ -59485,76 +59249,81 @@ static s7_function fx_choose(s7_scheme *sc, s7_pointer holder, s7_pointer e, saf return(fx_c_opsq); case HOP_SAFE_C_SC: - if (car(arg) == sc->add_symbol) - { - if (is_t_real(caddr(arg))) return(fx_add_sf); - if (is_t_integer(caddr(arg))) return((integer(caddr(arg)) == 1) ? fx_add_s1 : fx_add_si); - } - if (car(arg) == sc->subtract_symbol) + if (is_unchanged_global(car(arg))) { - if (is_t_real(caddr(arg))) return(fx_subtract_sf); - if (is_t_integer(caddr(arg))) return((integer(caddr(arg)) == 1) ? fx_subtract_s1 : fx_subtract_si); - } - if (car(arg) == sc->multiply_symbol) - { - if (is_t_real(caddr(arg))) return(fx_multiply_sf); - if (is_t_integer(caddr(arg))) return(fx_multiply_si); - } - if ((car(arg) == sc->num_eq_symbol) && (is_t_integer(caddr(arg)))) return(fx_num_eq_si); - if ((c_callee(arg) == g_memq_2) && (is_pair(caddr(arg)))) return(fx_memq_sq_2); - if ((c_callee(arg) == g_is_eq) && (!is_unspecified(caddr(arg)))) return(fx_is_eq_sc); - - if ((is_t_integer(caddr(arg))) && (is_global_and_has_func(car(arg), s7_p_pi_function))) - { - if (car(arg) == sc->lt_symbol) return(fx_lt_si); - if (car(arg) == sc->leq_symbol) return(fx_leq_si); - if (car(arg) == sc->gt_symbol) return(fx_gt_si); - if (car(arg) == sc->geq_symbol) return(fx_geq_si); - set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_pi_function(slot_value(global_slot(car(arg)))))); - return(fx_c_si_direct); - } - if ((is_global_and_has_func(car(arg), s7_p_pp_function)) && (c_callee(arg) != g_divide_by_2)) - { - if (car(arg) == sc->memq_symbol) + if (car(arg) == sc->add_symbol) { - if ((is_pair(caddr(arg))) && (is_proper_list_3(sc, cadr(caddr(arg))))) return(fx_memq_sc_3); - return(fx_memq_sc); + if (is_t_real(caddr(arg))) return(fx_add_sf); + if (is_t_integer(caddr(arg))) return((integer(caddr(arg)) == 1) ? fx_add_s1 : fx_add_si); } - if ((car(arg) == sc->char_eq_symbol) && (s7_is_character(caddr(arg)))) return(fx_char_eq_sc); - if (car(arg) == sc->lt_symbol) return(fx_lt_sc); /* integer case handled above */ - if (car(arg) == sc->leq_symbol) return(fx_leq_sc); - if (car(arg) == sc->gt_symbol) return(fx_gt_sc); - if (car(arg) == sc->geq_symbol) return(fx_geq_sc); - set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(slot_value(global_slot(car(arg)))))); - return(fx_c_sc_direct); - } + if (car(arg) == sc->subtract_symbol) + { + if (is_t_real(caddr(arg))) return(fx_subtract_sf); + if (is_t_integer(caddr(arg))) return((integer(caddr(arg)) == 1) ? fx_subtract_s1 : fx_subtract_si); + } + if (car(arg) == sc->multiply_symbol) + { + if (is_t_real(caddr(arg))) return(fx_multiply_sf); + if (is_t_integer(caddr(arg))) return(fx_multiply_si); + } + if ((car(arg) == sc->num_eq_symbol) && (is_t_integer(caddr(arg)))) return(fx_num_eq_si); + if ((c_callee(arg) == g_memq_2) && (is_pair(caddr(arg)))) return(fx_memq_sq_2); + if ((c_callee(arg) == g_is_eq) && (!is_unspecified(caddr(arg)))) return(fx_is_eq_sc); + + if ((is_t_integer(caddr(arg))) && (s7_p_pi_function(slot_value(global_slot(car(arg)))))) + { + if (car(arg) == sc->lt_symbol) return(fx_lt_si); + if (car(arg) == sc->leq_symbol) return(fx_leq_si); + if (car(arg) == sc->gt_symbol) return(fx_gt_si); + if (car(arg) == sc->geq_symbol) return(fx_geq_si); + set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_pi_function(slot_value(global_slot(car(arg)))))); + return(fx_c_si_direct); + } + if ((s7_p_pp_function(slot_value(global_slot(car(arg))))) && (c_callee(arg) != g_divide_by_2)) + { + if (car(arg) == sc->memq_symbol) + { + if ((is_pair(caddr(arg))) && (is_proper_list_3(sc, cadr(caddr(arg))))) return(fx_memq_sc_3); + return(fx_memq_sc); + } + if ((car(arg) == sc->char_eq_symbol) && (s7_is_character(caddr(arg)))) return(fx_char_eq_sc); + if (car(arg) == sc->lt_symbol) return(fx_lt_sc); /* integer case handled above */ + if (car(arg) == sc->leq_symbol) return(fx_leq_sc); + if (car(arg) == sc->gt_symbol) return(fx_gt_sc); + if (car(arg) == sc->geq_symbol) return(fx_geq_sc); + set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(slot_value(global_slot(car(arg)))))); + return(fx_c_sc_direct); + }} return(fx_c_sc); case HOP_SAFE_C_CS: - if ((car(arg) == sc->add_symbol) && (is_t_real(cadr(arg)))) return(fx_add_fs); - if ((car(arg) == sc->subtract_symbol) && (is_t_real(cadr(arg)))) return(fx_subtract_fs); - if (car(arg) == sc->multiply_symbol) + if (is_unchanged_global(car(arg))) { - if (is_t_real(cadr(arg))) return(fx_multiply_fs); - if (is_t_integer(cadr(arg))) return(fx_multiply_is); - } + if ((car(arg) == sc->add_symbol) && (is_t_real(cadr(arg)))) return(fx_add_fs); + if ((car(arg) == sc->subtract_symbol) && (is_t_real(cadr(arg)))) return(fx_subtract_fs); + if (car(arg) == sc->multiply_symbol) + { + if (is_t_real(cadr(arg))) return(fx_multiply_fs); + if (is_t_integer(cadr(arg))) return(fx_multiply_is); + }} return(fx_c_cs); case HOP_SAFE_C_S_opSq: - if (car(caddr(arg)) == sc->car_symbol) + if (fx_matches(car(caddr(arg)), sc->car_symbol)) { - if (car(arg) == sc->hash_table_ref_symbol) + if (fx_matches(car(arg), sc->hash_table_ref_symbol)) { set_opt2_sym(cdr(arg), cadaddr(arg)); return(fx_hash_table_ref_car); } set_opt2_sym(cdr(arg), cadaddr(arg)); - return((car(arg) == sc->add_symbol) ? fx_add_s_car_s : fx_c_s_car_s); + return(fx_matches(car(arg), sc->add_symbol) ? fx_add_s_car_s : fx_c_s_car_s); } if ((is_global_and_has_func(car(arg), s7_p_pp_function)) && (is_global_and_has_func(caaddr(arg), s7_p_p_function))) { + set_opt1_sym(cdr(arg), cadaddr(arg)); set_opt2_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(slot_value(global_slot(car(arg)))))); set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_p_function(slot_value(global_slot(caaddr(arg)))))); return(fx_c_s_opsq_direct); @@ -59562,41 +59331,44 @@ static s7_function fx_choose(s7_scheme *sc, s7_pointer holder, s7_pointer e, saf return(fx_c_s_opsq); case HOP_SAFE_C_opSq_C: - if ((car(arg) == sc->memq_symbol) && - (car(cadr(arg)) == sc->car_symbol) && - (is_proper_quote(sc, caddr(arg))) && - (is_pair(cadaddr(arg)))) - return((s7_list_length(sc, opt2_con(cdr(arg))) == 2) ? fx_memq_car_s_2 : fx_memq_car_s); - - if (car(arg) == sc->is_eq_symbol) + if (is_unchanged_global(car(arg))) { - if (((caadr(arg) == sc->car_symbol) || (caadr(arg) == sc->caar_symbol)) && - (is_proper_quote(sc, caddr(arg)))) + if ((car(arg) == sc->memq_symbol) && + (fx_matches(caadr(arg), sc->car_symbol)) && + (is_proper_quote(sc, caddr(arg))) && + (is_pair(cadaddr(arg)))) + return((s7_list_length(sc, opt2_con(cdr(arg))) == 2) ? fx_memq_car_s_2 : fx_memq_car_s); + + if (car(arg) == sc->is_eq_symbol) + { + if (((fx_matches(caadr(arg), sc->car_symbol)) || (fx_matches(caadr(arg), sc->caar_symbol))) && + (is_proper_quote(sc, caddr(arg)))) + { + set_opt3_sym(cdr(arg), cadadr(arg)); + set_opt2_con(cdr(arg), cadaddr(arg)); + return((caadr(arg) == sc->car_symbol) ? fx_is_eq_car_q : fx_is_eq_caar_q); + }} + if (((car(arg) == sc->lt_symbol) || (car(arg) == sc->num_eq_symbol)) && + (is_t_integer(caddr(arg))) && + (fx_matches(caadr(arg), sc->length_symbol))) { set_opt3_sym(cdr(arg), cadadr(arg)); - set_opt2_con(cdr(arg), cadaddr(arg)); - return((caadr(arg) == sc->car_symbol) ? fx_is_eq_car_q : fx_is_eq_caar_q); + set_opt2_con(cdr(arg), caddr(arg)); + return((car(arg) == sc->lt_symbol) ? fx_less_length_i : fx_num_eq_length_i); }} - if (((car(arg) == sc->lt_symbol) || (car(arg) == sc->num_eq_symbol)) && - (is_t_integer(caddr(arg))) && - (caadr(arg) == sc->length_symbol)) - { - set_opt3_sym(cdr(arg), cadadr(arg)); - set_opt2_con(cdr(arg), caddr(arg)); - return((car(arg) == sc->lt_symbol) ? fx_less_length_i : fx_num_eq_length_i); - } + set_opt1_sym(cdr(arg), cadadr(arg)); return(fx_c_opsq_c); case HOP_SAFE_C_opSCq: - if (car(arg) == sc->not_symbol) + if (fx_matches(car(arg), sc->not_symbol)) { if (c_callee(cadr(arg)) == g_is_eq) { set_opt2_sym(cdr(arg), cadr(cadr(arg))); - set_opt3_any(cdr(arg), (is_pair(caddadr(arg))) ? cadaddr(cadr(arg)) : caddadr(arg)); + set_opt3_con(cdr(arg), (is_pair(caddadr(arg))) ? cadaddr(cadr(arg)) : caddadr(arg)); return(fx_not_is_eq_sq); } - return(fx_c_opscq); + return(fx_not_opscq); } return(fx_c_opscq); @@ -59632,7 +59404,7 @@ static s7_function fx_choose(s7_scheme *sc, s7_pointer holder, s7_pointer e, saf return(fx_c_s_opscq); case HOP_SAFE_C_opSSq: - if (car(arg) == sc->not_symbol) + if (fx_matches(car(arg), sc->not_symbol)) { if (c_callee(cadr(arg)) == g_is_eq) { @@ -59657,7 +59429,7 @@ static s7_function fx_choose(s7_scheme *sc, s7_pointer holder, s7_pointer e, saf { s7_pointer s2; s2 = caddr(arg); - if ((car(s2) == sc->multiply_symbol) && (cadr(s2) == caddr(s2))) + if ((fx_matches(car(s2), sc->multiply_symbol)) && (cadr(s2) == caddr(s2))) return(fx_c_c_sqr); } if ((is_small_real(cadr(arg))) && @@ -59696,20 +59468,7 @@ static s7_function fx_choose(s7_scheme *sc, s7_pointer holder, s7_pointer e, saf return(fx_c_opsq_opsq); case HOP_SAFE_C_op_S_opSqq: - return((car(arg) == sc->not_symbol) ? fx_not_op_s_opsqq : fx_c_op_s_opsqq); - - case HOP_SAFE_C_op_opSq_Cq: - if ((car(arg) == sc->not_symbol) && /* (not (eq? (car s) 's)) */ - (c_callee(cadr(arg)) == g_is_eq) && - (c_callee(cadadr(arg)) == g_car) && - (is_symbol(cadr(cadadr(arg)))) && - (is_proper_quote(sc, caddadr(arg)))) - { - set_opt2_sym(cdr(arg), cadr(cadr(cadr(arg)))); - set_opt3_any(cdr(arg), cadaddr(cadr(arg))); - return(fx_not_is_eq_car_q); - } - return(fx_c_op_opsq_cq); + return((fx_matches(car(arg), sc->not_symbol)) ? fx_not_op_s_opsqq : fx_c_op_s_opsqq); case HOP_SAFE_C_S_op_S_opSSqq: if ((is_global_and_has_func(car(arg), s7_p_pp_function)) && @@ -59735,16 +59494,18 @@ static s7_function fx_choose(s7_scheme *sc, s7_pointer holder, s7_pointer e, saf } return(fx_c_op_opssqq_s); - case HOP_SAFE_C_op_opSqq_C: - if ((c_callee(arg) == g_string_ref) && (is_t_integer(caddr(arg))) && (integer(caddr(arg)) == 0) && (c_callee(cadr(arg)) == g_symbol_to_string_uncopied)) + case HOP_SAFE_C_A: + if (fx_matches(car(arg), sc->not_symbol)) { - set_opt3_pair(arg, cadadr(arg)); - return(fx_string_ref_0_symbol_a); + if (c_callee(cdr(arg)) == fx_c_sa) return(fx_not_opsaq); + if (c_callee(cdr(arg)) == fx_is_eq_car_q) + { + set_opt2_sym(cdr(arg), cadadr(cadr(arg))); + set_opt3_any(cdr(arg), cadaddr(cadr(arg))); + return(fx_not_is_eq_car_q); + } + return(fx_not_a); } - return(fx_c_op_opsqq_c); - - case HOP_SAFE_C_A: - if (car(arg) == sc->not_symbol) return((c_callee(cdr(arg)) == fx_c_sa) ? fx_not_opsaq : fx_not_a); if (is_global_and_has_func(car(arg), s7_p_p_function)) { set_opt3_direct(arg, (s7_pointer)(s7_p_p_function(slot_value(global_slot(car(arg)))))); @@ -59780,8 +59541,7 @@ static s7_function fx_choose(s7_scheme *sc, s7_pointer holder, s7_pointer e, saf { if (optimize_op(body) == OP_AND_2) { - if ((caadr(body) == sc->is_pair_symbol) && - (symbol_id(sc->is_pair_symbol) == 0) && + if ((fx_matches(caadr(body), sc->is_pair_symbol)) && (cadadr(body) == car(closure_args(opt1_lambda(arg))))) return(fx_closure_s_and_pair); /* lint arg: (len>1? init), args: (x) body: (and (pair? x) (pair? (cdr x))) */ return(fx_closure_s_and_2); @@ -59870,7 +59630,7 @@ static bool fx_tree_out(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_poin { if (cadr(p) == var1) { - if (c_callee(tree) == fx_c_s) return(with_c_call(tree, fx_c_T)); + if (c_callee(tree) == fx_c_s) return(with_c_call(tree, fx_c_T)); /* fx_c_T_direct got no hits */ if (c_callee(tree) == fx_subtract_s1) return(with_c_call(tree, fx_subtract_T1)); if (c_callee(tree) == fx_add_s1) return(with_c_call(tree, fx_add_T1)); if (c_callee(tree) == fx_c_sca) return(with_c_call(tree, fx_c_Tca)); @@ -59991,12 +59751,14 @@ static bool fx_tree_in(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_point if ((c_callee(tree) == fx_char_eq_sc) || (c_callee(p) == g_char_equal_2)) return(with_c_call(tree, fx_char_eq_tc)); if (c_callee(tree) == fx_c_sc) return(with_c_call(tree, fx_c_tc)); if (c_callee(tree) == fx_add_sf) return(with_c_call(tree, fx_add_tf)); + if (c_callee(p) == g_less_xf) return(with_c_call(tree, fx_lt_tf)); if ((c_callee(p) == g_less_xi) || (c_callee(p) == g_less_x0)) return(with_c_call(tree, fx_lt_ti)); if (c_callee(p) == g_geq_xf) return(with_c_call(tree, fx_geq_tf)); if (c_callee(p) == g_geq_xi) return(with_c_call(tree, fx_geq_ti)); if (c_callee(p) == g_leq_xi) return(with_c_call(tree, fx_leq_ti)); if (c_callee(p) == g_greater_xi) return(with_c_call(tree, fx_gt_ti)); + if (c_callee(tree) == fx_c_sc_direct) /* p_pp cases */ { if ((opt3_direct(cdr(p)) == (s7_pointer)vector_ref_p_pp) && (is_t_integer(caddr(p)))) @@ -60108,7 +59870,22 @@ static bool fx_tree_in(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_point break; case HOP_SAFE_C_SA: - if (cadr(p) == var1) return(with_c_call(tree, fx_c_ta)); + if (cadr(p) == var1) + { + if ((c_callee(cddr(p)) == fx_c_opsq_c) && + (cadadr(caddr(p)) == var1) && + (is_t_integer(caddaddr(p))) && + (integer(caddaddr(p)) == 1) && + (car(p) == sc->string_ref_symbol) && + (caaddr(p) == sc->subtract_symbol) && +#if (!WITH_PURE_S7) + ((caadr(caddr(p)) == sc->string_length_symbol) || (caadr(caddr(p)) == sc->length_symbol))) +#else + (caadr(caddr(p)) == sc->length_symbol)) +#endif + return(with_c_call(tree, fx_string_ref_t_last)); + return(with_c_call(tree, fx_c_ta)); + } break; case HOP_SAFE_C_SCS: @@ -60122,8 +59899,7 @@ static bool fx_tree_in(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_point case HOP_SAFE_C_SSS: if (cadr(p) == var1) { - if ((is_pair(cddr(p))) && (caddr(p) == var2) && - ((c_callee(tree) == fx_c_sss) || (c_callee(tree) == fx_c_sss_direct))) + if ((caddr(p) == var2) && ((c_callee(tree) == fx_c_sss) || (c_callee(tree) == fx_c_sss_direct))) {set_safe_optimize_op(p, OP_SAFE_C_TUS); return(with_c_call(tree, fx_c_tus));} } if (caddr(p) == var1) return(with_c_call(tree, fx_c_sts)); @@ -60149,6 +59925,7 @@ static bool fx_tree_in(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_point return(with_c_call(tree, (car(p) == sc->is_symbol_symbol) ? fx_is_symbol_car_t : fx_is_type_car_t)); if (c_callee(tree) == fx_c_opsq) { + set_opt1_sym(cdr(p), cadadr(p)); if ((is_global_and_has_func(car(p), s7_p_p_function)) && (is_global_and_has_func(caadr(p), s7_p_p_function))) { @@ -60177,6 +59954,7 @@ static bool fx_tree_in(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_point if ((is_global_and_has_func(car(p), s7_p_pp_function)) && (is_global_and_has_func(caadr(p), s7_p_p_function))) { + set_opt1_sym(p, cadadr(p)); set_opt2_direct(cdr(p), (s7_pointer)(s7_p_pp_function(slot_value(global_slot(car(p)))))); set_opt3_direct(cdr(p), (s7_pointer)(s7_p_p_function(slot_value(global_slot(caadr(p)))))); return(with_c_call(tree, fx_c_optq_s_direct)); @@ -60224,10 +60002,17 @@ static bool fx_tree_in(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_point case HOP_SAFE_C_opSq_opSq: if (c_callee(tree) == fx_c_opsq_opsq_direct) { - if ((cadadr(p) == var1) && (cadadr(p) == cadaddr(p))) return(with_c_call(tree, fx_c_optq_optq_direct)); /* opuq got few hits */ + if ((cadadr(p) == var1) && (cadadr(p) == cadaddr(p))) + { + set_opt1_sym(cdr(p), cadadr(p)); + return(with_c_call(tree, fx_c_optq_optq_direct)); /* opuq got few hits */ + } if ((caadr(p) == caaddr(p)) && (caadr(p) == sc->car_symbol)) - return(with_c_call(tree, ((cadadr(p) == var1) && (cadaddr(p) == var2)) ? fx_car_car_tu : fx_car_car)); /* cdr/cadr got few hits */ - } + { + set_opt1_sym(cdr(p), cadadr(p)); + set_opt2_sym(cdr(p), cadaddr(p)); + return(with_c_call(tree, ((cadadr(p) == var1) && (cadaddr(p) == var2)) ? fx_car_car_tu : fx_car_car)); /* cdr/cadr got few hits */ + }} break; case HOP_SAFE_C_opSq_C: @@ -60283,19 +60068,17 @@ static bool fx_tree_in(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_point return(with_c_call(tree, fx_is_zero_remainder_1)); return(with_c_call(tree, fx_c_opstq_direct)); }} - if (cadadr(p) == var2) + if ((cadadr(p) == var2) && (c_callee(tree) == fx_not_opssq) && (caddadr(p) == var1)) { - if ((c_callee(tree) == fx_not_opssq) && (caddadr(p) == var1)) + if (c_callee(cadr(p)) == g_less_2) { - if (c_callee(cadr(p)) == g_less_2) - { - set_opt3_sym(p, var2); - set_opt1_sym(cdr(p), var1); - set_c_call_direct(tree, fx_not_lt_ut); - } - else set_c_call_direct(tree, fx_not_oputq); - return(true); - }} + set_opt3_sym(p, var2); + set_opt1_sym(cdr(p), var1); + set_c_call_direct(tree, fx_not_lt_ut); + } + else set_c_call_direct(tree, fx_not_oputq); + return(true); + } break; case HOP_SAFE_C_opSCq: @@ -60304,33 +60087,13 @@ static bool fx_tree_in(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_point break; case HOP_SAFE_C_opSSq_C: - if ((c_callee(tree) == fx_c_opssq_c) && (caddadr(p) == var1)) return(with_c_call(tree, fx_c_opstq_c)); + if ((c_callee(tree) == fx_c_opssq_c) && (caddadr(p) == var1)) + return(with_c_call(tree, fx_c_opstq_c)); break; case HOP_SAFE_C_S_opSCq: - if (cadr(p) == var1) - { - if (c_callee(tree) == fx_c_s_opscq_direct) - return(with_c_call(tree, (cadaddr(p) == var2) ? fx_c_t_opucq_direct : fx_c_t_opscq_direct)); - } - break; - - case HOP_SAFE_C_S_op_opSq_Cq: - if (cadr(p) == var1) - { - if ((c_callee(tree) == fx_c_s_op_opsq_cq) && - (cadadr(caddr(p)) == var1) && - (is_t_integer(caddaddr(p))) && - (integer(caddaddr(p)) == 1) && - (car(p) == sc->string_ref_symbol) && - (caaddr(p) == sc->subtract_symbol) && -#if (!WITH_PURE_S7) - ((caadr(caddr(p)) == sc->string_length_symbol) || (caadr(caddr(p)) == sc->length_symbol))) -#else - (caadr(caddr(p)) == sc->length_symbol)) -#endif - return(with_c_call(tree, fx_string_ref_t_last)); - } + if ((cadr(p) == var1) && (c_callee(tree) == fx_c_s_opscq_direct)) + return(with_c_call(tree, (cadaddr(p) == var2) ? fx_c_t_opucq_direct : fx_c_t_opscq_direct)); break; case HOP_SAFE_C_opSq_CS: @@ -60366,10 +60129,15 @@ static bool fx_tree_in(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_point break; case HOP_SAFE_C_S_opSSq: - if ((caddr(caddr(p)) == var1) && (c_callee(p) == g_vector_ref_2) && (is_global(cadr(p)) && (is_global(cadr(caddr(p)))))) + if (caddr(caddr(p)) == var1) { - set_opt3_pair(p, cdaddr(p)); - return(with_c_call(tree, fx_vref_g_vref_gt)); + if ((c_callee(p) == g_vector_ref_2) && (is_global(cadr(p)) && (is_global(cadr(caddr(p)))))) + { + set_opt3_pair(p, cdaddr(p)); + return(with_c_call(tree, fx_vref_g_vref_gt)); + } + if (c_callee(tree) == fx_c_s_opssq_direct) + return(with_c_call(tree, fx_c_s_opstq_direct)); } break; @@ -60410,13 +60178,22 @@ static void fx_tree(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_pointer { #if 0 if (is_pair(tree)) - fprintf(stderr, "%s[%d]: fx_tree %s %s %d %s %s\n", func, line, display_80(tree), (is_optimized(tree)) ? op_names[optimize_op(tree)] : "unopt", has_fx(tree), display(var1), (var2) ? display(var2) : ""); + fprintf(stderr, "fx_tree %s %s %d %s %s\n", display_80(tree), (is_optimized(tree)) ? op_names[optimize_op(tree)] : "unopt", has_fx(tree), display(var1), (var2) ? display(var2) : ""); #endif - if ((!is_pair(tree)) || - ((is_symbol(car(tree))) && - (is_definer_or_binder(car(tree))))) - return; + if (!is_pair(tree)) return; + if ((is_symbol(car(tree))) && + (is_definer_or_binder(car(tree)))) + { + if ((car(tree) == sc->let_symbol) && (is_pair(cdr(tree))) && (is_pair(cadr(tree))) && (is_null(cdadr(tree)))) + { + fx_tree(sc, cddr(tree), caaadr(tree), NULL); + /* same below, and fx_tree_outer here using vars above? */ + /* also do+1 step, letrec(*) 1 var, etc */ + /* according to callgrind this costs about as much as it saves except in lint (where it is a small win) */ + } + return; + } if ((!has_fx(tree)) || (!fx_tree_in(sc, tree, var1, var2))) @@ -60427,10 +60204,12 @@ static void fx_tree(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_pointer static void fx_tree_outer(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_pointer var2) { /* if (is_pair(tree)) fprintf(stderr, "%s[%d]: %s %d %s %s\n", __func__, __LINE__, display_80(tree), has_fx(tree), display(var1), (var2) ? display(var2) : ""); */ + if ((!is_pair(tree)) || ((is_symbol(car(tree))) && (is_definer_or_binder(car(tree))))) return; + if ((!has_fx(tree)) || (!fx_tree_out(sc, tree, var1, var2))) fx_tree_outer(sc, car(tree), var1, var2); @@ -60459,10 +60238,8 @@ static void add_opt_func(s7_scheme *sc, s7_pointer f, opt_func_t typ, void *func "o_d_ip", "o_d_pd", "o_d_7pid", "o_d", "o_d_d", "o_d_dd", "o_d_7dd", "o_d_ddd", "o_d_dddd", "o_i_i", "o_i_7i", "o_i_ii", "o_i_7ii", "o_i_iii", "o_i_7pi", "o_i_7pii", "o_i_7_piii", "o_d_p", "o_b_p", "o_b_7p", "o_b_pp", "o_b_7pp", "o_b_pp_unchecked", "o_b_pi", "o_b_ii", "o_b_7ii", "o_b_dd", - "o_p", "o_p_p", "o_p_ii", "o_p_d", "o_p_dd", "o_i_7d", "o_i_7p", "o_d_7d", - "o_p_pp", "o_p_pp_unchecked", "o_p_ppp", "o_p_ppp_unchecked", "o_p_pi", "o_p_pi_unchecked", + "o_p", "o_p_p", "o_p_ii", "o_p_d", "o_p_dd", "o_i_7d", "o_i_7p", "o_d_7d", "o_p_pp", "o_p_ppp", "o_p_pi", "o_p_pi_unchecked", "o_p_ppi", "o_p_i", "o_p_pii", "o_p_pip", "o_p_pip_unchecked", "o_p_piip", "o_b_i", "o_b_d"}; - if (!is_c_function(f)) { fprintf(stderr, "%s[%d]: %s is not a c_function\n", __func__, __LINE__, s7_object_to_c_string(sc, f)); @@ -60655,12 +60432,6 @@ static s7_p_pi_t s7_p_pi_unchecked_function(s7_pointer f) {return((s7_p_pi_t)opt static void s7_set_p_pip_unchecked_function(s7_scheme *sc, s7_pointer f, s7_p_pip_t df) {add_opt_func(sc, f, o_p_pip_unchecked, (void *)df);} static s7_p_pip_t s7_p_pip_unchecked_function(s7_pointer f) {return((s7_p_pip_t)opt_func(f, o_p_pip_unchecked));} -static void s7_set_p_pp_unchecked_function(s7_scheme *sc, s7_pointer f, s7_p_pp_t df) {add_opt_func(sc, f, o_p_pp_unchecked, (void *)df);} -static s7_p_pp_t s7_p_pp_unchecked_function(s7_pointer f) {return((s7_p_pp_t)opt_func(f, o_p_pp_unchecked));} - -static void s7_set_p_ppp_unchecked_function(s7_scheme *sc, s7_pointer f, s7_p_ppp_t df) {add_opt_func(sc, f, o_p_ppp_unchecked, (void *)df);} -static s7_p_ppp_t s7_p_ppp_unchecked_function(s7_pointer f) {return((s7_p_ppp_t)opt_func(f, o_p_ppp_unchecked));} - static void s7_set_b_pp_unchecked_function(s7_scheme *sc, s7_pointer f, s7_b_pp_t df) {add_opt_func(sc, f, o_b_pp_unchecked, (void *)df);} static s7_b_pp_t s7_b_pp_unchecked_function(s7_pointer f) {return((s7_b_pp_t)opt_func(f, o_b_pp_unchecked));} @@ -60715,7 +60486,7 @@ static s7_pointer opt_integer_symbol(s7_scheme *sc, s7_pointer sym) if (is_symbol(sym)) { s7_pointer p; - p = symbol_to_slot(sc, sym); + p = lookup_slot_from(sym, sc->curlet); if ((is_slot(p)) && (is_t_integer(slot_value(p)))) return(p); @@ -60728,7 +60499,7 @@ static s7_pointer opt_real_symbol(s7_scheme *sc, s7_pointer sym) if (is_symbol(sym)) { s7_pointer p; - p = symbol_to_slot(sc, sym); + p = lookup_slot_from(sym, sc->curlet); if ((is_slot(p)) && (is_small_real(slot_value(p)))) return(p); @@ -60741,7 +60512,7 @@ static s7_pointer opt_float_symbol(s7_scheme *sc, s7_pointer sym) if (is_symbol(sym)) { s7_pointer p; - p = symbol_to_slot(sc, sym); + p = lookup_slot_from(sym, sc->curlet); if ((is_slot(p)) && (is_t_real(slot_value(p)))) return(p); @@ -60752,7 +60523,7 @@ static s7_pointer opt_float_symbol(s7_scheme *sc, s7_pointer sym) static s7_pointer opt_simple_symbol(s7_scheme *sc, s7_pointer sym) { s7_pointer p; - p = symbol_to_slot(sc, sym); + p = lookup_slot_from(sym, sc->curlet); if ((is_slot(p)) && (!has_methods(slot_value(p)))) return(p); @@ -60763,7 +60534,7 @@ static s7_pointer opt_types_match(s7_scheme *sc, s7_pointer check, s7_pointer sy { s7_pointer slot, checker; checker = s7_symbol_value(sc, check); - slot = symbol_to_slot(sc, sym); + slot = lookup_slot_from(sym, sc->curlet); if (is_slot(slot)) { s7_pointer obj; @@ -61403,7 +61174,7 @@ static bool opt_i_7piii_args(s7_scheme *sc, opt_info *opc, s7_pointer indexp1, s static bool opt_int_vector_set(s7_scheme *sc, int otype, opt_info *opc, s7_pointer v, s7_pointer indexp1, s7_pointer indexp2, s7_pointer valp) { s7_pointer settee; - settee = symbol_to_slot(sc, v); + settee = lookup_slot_from(v, sc->curlet); if ((is_slot(settee)) && (!is_immutable(slot_value(settee)))) { @@ -61549,7 +61320,7 @@ static bool i_7piii_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_point if ((car(car_x) == sc->int_vector_set_symbol) || (car(car_x) == sc->byte_vector_set_symbol)) return(opt_int_vector_set(sc, (car(car_x) == sc->int_vector_set_symbol) ? 1 : 0, opc, cadr(car_x), cddr(car_x), cdddr(car_x), cddddr(car_x))); - settee = symbol_to_slot(sc, cadr(car_x)); + settee = lookup_slot_from(cadr(car_x), sc->curlet); if (is_slot(settee)) { s7_pointer vect; @@ -61688,7 +61459,7 @@ static s7_int opt_set_i_i_f(opt_info *o) return(x); } -static s7_int opt_set_i_i_fm(opt_info *o) /* when is this called? */ +static s7_int opt_set_i_i_fm(opt_info *o) /* called in increment: (set! sum (+ sum (...))) where are all ints */ { s7_int x; x = o->v[3].fi(o->v[2].o1); @@ -61736,7 +61507,7 @@ static bool i_syntax_ok(s7_scheme *sc, s7_pointer car_x, int32_t len) if ((is_immutable(cadr(car_x))) || (symbol_has_setter(cadr(car_x)))) return_false(sc, car_x); - settee = symbol_to_slot(sc, cadr(car_x)); + settee = lookup_slot_from(cadr(car_x), sc->curlet); if ((is_slot(settee)) && (!is_immutable(settee))) { @@ -61771,7 +61542,7 @@ static bool i_implicit_ok(s7_scheme *sc, s7_pointer car_x, int32_t len) { s7_pointer s_slot, head; head = car(car_x); - s_slot = symbol_to_slot(sc, head); + s_slot = lookup_slot_from(head, sc->curlet); if ((is_slot(s_slot)) && ((is_int_vector(slot_value(s_slot))) || (is_byte_vector(slot_value(s_slot))))) { @@ -62047,7 +61818,7 @@ static bool d_7pi_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer if (is_symbol(cadr(car_x))) /* (float-vector-ref v i) */ { s7_pointer arg2, p, obj; - opc->v[1].p = symbol_to_slot(sc, cadr(car_x)); + opc->v[1].p = lookup_slot_from(cadr(car_x), sc->curlet); if (!is_slot(opc->v[1].p)) return_false(sc, car_x); @@ -62132,7 +61903,7 @@ static bool d_ip_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer { opc->v[3].d_ip_f = pfunc; opc->v[1].p = p; - opc->v[2].p = symbol_to_slot(sc, caddr(car_x)); + opc->v[2].p = lookup_slot_from(caddr(car_x), sc->curlet); if (is_slot(opc->v[2].p)) { /* (with-sound (:reverb jc-reverb) (fm-violin 0 .1 440 .4 :reverb-amount .5)) */ @@ -62159,7 +61930,7 @@ static bool d_pd_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer start = sc->pc; arg2 = caddr(car_x); opc->v[3].d_pd_f = func; - opc->v[1].p = symbol_to_slot(sc, cadr(car_x)); + opc->v[1].p = lookup_slot_from(cadr(car_x), sc->curlet); if (!is_slot(opc->v[1].p)) return_false(sc, car_x); p = opt_float_symbol(sc, arg2); @@ -62285,7 +62056,7 @@ static bool d_vd_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer opc->v[0].fd = opt_d_vd_c; return(true); } - opc->v[2].p = symbol_to_slot(sc, arg2); + opc->v[2].p = lookup_slot_from(arg2, sc->curlet); if (is_slot(opc->v[2].p)) { if (is_t_real(slot_value(opc->v[2].p))) @@ -62871,7 +62642,7 @@ static bool d_dd_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer } if (func == subtract_d_dd) { - opc->v[0].fd = opt_d_dd_fc_subtract; + opc->v[0].fd = opt_d_dd_fc_subtract; /* if o1->v[0].fd = opt_d_7d_c and its o->v[3].d_7d_f = random_d_7d it's (- (random f1) f2) */ if ((opc == sc->opts[sc->pc - 2]) && (sc->opts[start]->v[0].fd == opt_d_7d_c) && @@ -63270,7 +63041,7 @@ static s7_double opt_d_7piid_sfff(opt_info *o) static bool opt_float_vector_set(s7_scheme *sc, opt_info *opc, s7_pointer v, s7_pointer indexp1, s7_pointer indexp2, s7_pointer valp) { s7_pointer settee; - settee = symbol_to_slot(sc, v); + settee = lookup_slot_from(v, sc->curlet); if ((is_slot(settee)) && (!is_immutable(slot_value(settee)))) { @@ -63423,7 +63194,7 @@ static bool d_7pii_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointe s7_pointer slot; int32_t start; start = sc->pc; - opc->v[1].p = symbol_to_slot(sc, cadr(car_x)); + opc->v[1].p = lookup_slot_from(cadr(car_x), sc->curlet); if (!is_slot(opc->v[1].p)) return_false(sc, car_x); @@ -63484,7 +63255,7 @@ static bool d_7pid_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointe if (head == sc->float_vector_set_symbol) return(opt_float_vector_set(sc, opc, cadr(car_x), cddr(car_x), NULL, cdddr(car_x))); - opc->v[1].p = symbol_to_slot(sc, cadr(car_x)); + opc->v[1].p = lookup_slot_from(cadr(car_x), sc->curlet); opc->v[10].o1 = sc->opts[start]; if (is_slot(opc->v[1].p)) { @@ -63738,14 +63509,12 @@ static bool d_add_any_ok(s7_scheme *sc, opt_info *opc, s7_pointer car_x, int32_t { s7_pointer p; int32_t cur_len; - for (cur_len = 0, p = cdr(car_x); (is_pair(p)) && (cur_len < 12); p = cdr(p), cur_len++) { opc->v[2 + cur_len].o1 = sc->opts[sc->pc]; if (!float_optimize(sc, p)) break; } - if (is_null(p)) { opc->v[1].i = cur_len; @@ -63787,7 +63556,7 @@ static bool d_syntax_ok(s7_scheme *sc, s7_pointer car_x, int32_t len) if ((is_immutable(cadr(car_x))) || (symbol_has_setter(cadr(car_x)))) return_false(sc, car_x); - settee = symbol_to_slot(sc, cadr(car_x)); + settee = lookup_slot_from(cadr(car_x), sc->curlet); if ((is_slot(settee)) && (!is_immutable(settee))) { @@ -63822,7 +63591,7 @@ static bool d_implicit_ok(s7_scheme *sc, s7_pointer car_x, int32_t len) { s7_pointer s_slot, slot; opt_info *opc; - s_slot = symbol_to_slot(sc, car(car_x)); + s_slot = lookup_slot_from(car(car_x), sc->curlet); if (!is_slot(s_slot)) return_false(sc, car_x); @@ -63975,7 +63744,7 @@ static bool b_idp_ok(s7_scheme *sc, s7_pointer s_func, s7_pointer car_x, s7_poin opc->v[2].b_i_f = bif; if (is_symbol(cadr(car_x))) { - opc->v[1].p = symbol_to_slot(sc, cadr(car_x)); + opc->v[1].p = lookup_slot_from(cadr(car_x), sc->curlet); opc->v[0].fb = opt_b_i_s; return(true); } @@ -64009,7 +63778,7 @@ static bool b_idp_ok(s7_scheme *sc, s7_pointer s_func, s7_pointer car_x, s7_poin opc->v[2].b_d_f = bdf; if (is_symbol(cadr(car_x))) { - opc->v[1].p = symbol_to_slot(sc, cadr(car_x)); + opc->v[1].p = lookup_slot_from(cadr(car_x), sc->curlet); opc->v[0].fb = opt_b_d_s; return(true); } @@ -64060,7 +63829,7 @@ static s7_pointer opt_arg_type(s7_scheme *sc, s7_pointer argp) { if ((is_global(car(arg))) || ((is_slot(global_slot(car(arg)))) && - (symbol_to_slot(sc, car(arg)) == global_slot(car(arg))))) + (lookup_slot_from(car(arg), sc->curlet) == global_slot(car(arg))))) { s7_pointer a_func; a_func = slot_value(global_slot(car(arg))); @@ -64095,7 +63864,7 @@ static s7_pointer opt_arg_type(s7_scheme *sc, s7_pointer argp) } return(car(sig)); /* we want the function's return type in this context */ }}} - slot = symbol_to_slot(sc, car(arg)); + slot = lookup_slot_from(car(arg), sc->curlet); if ((is_slot(slot)) && (is_sequence(slot_value(slot)))) { @@ -64280,7 +64049,7 @@ static bool b_pp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer opc->v[10].o1 = sc->opts[sc->pc]; if (cell_optimize(sc, cdr(car_x))) { - opc->v[1].p = symbol_to_slot(sc, arg2); + opc->v[1].p = lookup_slot_from(arg2, sc->curlet); if ((!is_slot(opc->v[1].p)) || (has_methods(slot_value(opc->v[1].p)))) return_false(sc, car_x); @@ -64303,7 +64072,7 @@ static bool b_pp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer opc->v[8].o1 = o1; opc->v[9].fp = o1->v[0].fp; opc->v[11].fp = opc->v[10].o1->v[0].fp; - check_b_types(sc, opc, s_func, car_x, opt_b_pp_ff); + check_b_types(sc, opc, s_func, car_x, opt_b_pp_ff); return(true); }} return_false(sc, car_x); @@ -64318,7 +64087,7 @@ static bool b_pi_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer bpif = s7_b_pi_function(s_func); if (bpif) { - opc->v[1].p = symbol_to_slot(sc, arg2); /* slot checked in opt_arg_type */ + opc->v[1].p = lookup_slot_from(arg2, sc->curlet); /* slot checked in opt_arg_type */ opc->v[10].o1 = sc->opts[sc->pc]; if (cell_optimize(sc, cdr(car_x))) { @@ -64365,10 +64134,10 @@ static bool b_dd_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer opc->v[3].b_dd_f = bif; if (is_symbol(arg1)) { - opc->v[1].p = symbol_to_slot(sc, arg1); + opc->v[1].p = lookup_slot_from(arg1, sc->curlet); if (is_symbol(arg2)) { - opc->v[2].p = symbol_to_slot(sc, arg2); + opc->v[2].p = lookup_slot_from(arg2, sc->curlet); opc->v[0].fb = (bif == lt_b_dd) ? opt_b_dd_ss_lt : ((bif == gt_b_dd) ? opt_b_dd_ss_gt : opt_b_dd_ss); return(true); } @@ -64392,7 +64161,7 @@ static bool b_dd_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer opc->v[11].fd = opc->v[10].o1->v[0].fd; if (is_symbol(arg2)) { - opc->v[1].p = symbol_to_slot(sc, arg2); + opc->v[1].p = lookup_slot_from(arg2, sc->curlet); opc->v[0].fb = (bif == gt_b_dd) ? opt_b_dd_fs_gt : opt_b_dd_fs; return(true); } @@ -64457,10 +64226,10 @@ static bool b_ii_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer if (bif) opc->v[3].b_ii_f = bif; else opc->v[3].b_7ii_f = b7if; if (is_symbol(arg1)) { - opc->v[1].p = symbol_to_slot(sc, arg1); + opc->v[1].p = lookup_slot_from(arg1, sc->curlet); if (is_symbol(arg2)) { - opc->v[2].p = symbol_to_slot(sc, arg2); + opc->v[2].p = lookup_slot_from(arg2, sc->curlet); opc->v[0].fb = (bif == lt_b_ii) ? opt_b_ii_ss_lt : ((bif == leq_b_ii) ? opt_b_ii_ss_leq : @@ -64499,7 +64268,7 @@ static bool b_ii_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer if (int_optimize(sc, cdr(car_x))) { opc->v[11].fi = opc->v[10].o1->v[0].fi; - opc->v[2].p = symbol_to_slot(sc, arg2); + opc->v[2].p = lookup_slot_from(arg2, sc->curlet); opc->v[0].fb = opt_b_ii_fs; return(true); } @@ -64762,8 +64531,14 @@ static bool p_p_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer c if (!p_p_f_combinable(sc, opc)) { opc->v[0].fp = opt_p_p_f; - if ((opc->v[2].p_p_f == char_upcase_p_p) && (caadr(car_x) == sc->string_ref_symbol)) - opc->v[2].p_p_f = char_upcase_p_p_unchecked; + if (caadr(car_x) == sc->string_ref_symbol) + { + if (opc->v[2].p_p_f == char_upcase_p_p) + opc->v[2].p_p_f = char_upcase_p_p_unchecked; + else + if (opc->v[2].p_p_f == is_char_whitespace_p_p) + opc->v[2].p_p_f = is_char_whitespace_p_p_unchecked; + } opc->v[3].o1 = o1; opc->v[4].fp = o1->v[0].fp; return(true); @@ -65112,13 +64887,7 @@ static bool p_pp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer func = s7_p_pp_function(s_func); if (func) { - s7_pointer slot, sig, checker = NULL; - - sig = c_function_signature(s_func); - if ((is_pair(sig)) && - (is_pair(cdr(sig))) && - (is_symbol(cadr(sig)))) - checker = cadr(sig); + s7_pointer slot; opc->v[3].p_pp_f = func; if (is_symbol(cadr(car_x))) @@ -65137,13 +64906,9 @@ static bool p_pp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer } opc->v[1].p = slot; - if ((s7_p_pp_unchecked_function(s_func)) && - (checker)) - { - checker = s7_symbol_value(sc, checker); - if (s7_apply_function(sc, checker, set_plist_1(sc, slot_value(slot))) == sc->T) - opc->v[3].p_pp_f = s7_p_pp_unchecked_function(s_func); - } + if ((func == hash_table_ref_p_pp) && (is_hash_table(slot_value(slot)))) + opc->v[3].p_pp_f = s7_hash_table_ref; + if (is_symbol(caddr(car_x))) { opc->v[2].p = opt_simple_symbol(sc, caddr(car_x)); @@ -65293,7 +65058,7 @@ static bool p_call_pp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_poi opc->v[3].call = cf_call(sc, car_x, s_func, 2); if (is_symbol(cadr(car_x))) { - opc->v[1].p = symbol_to_slot(sc, cadr(car_x)); + opc->v[1].p = lookup_slot_from(cadr(car_x), sc->curlet); if ((is_slot(opc->v[1].p)) && (!has_methods(slot_value(opc->v[1].p)))) { @@ -65435,7 +65200,7 @@ static bool p_pip_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer checker = cadr(sig); /* here we know cadr is a symbol */ - slot1 = symbol_to_slot(sc, cadr(car_x)); + slot1 = lookup_slot_from(cadr(car_x), sc->curlet); if ((!is_slot(slot1)) || (has_methods(slot_value(slot1))) || (is_immutable(slot_value(slot1)))) @@ -65624,7 +65389,7 @@ static bool p_piip_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointe (is_symbol(cadr(car_x)))) { s7_pointer slot1, obj; - slot1 = symbol_to_slot(sc, cadr(car_x)); + slot1 = lookup_slot_from(cadr(car_x), sc->curlet); if (!is_slot(slot1)) return_false(sc, car_x); obj = slot_value(slot1); @@ -65662,7 +65427,7 @@ static bool p_pii_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer (is_symbol(cadr(car_x)))) { s7_pointer slot1, obj; - slot1 = symbol_to_slot(sc, cadr(car_x)); + slot1 = lookup_slot_from(cadr(car_x), sc->curlet); if (!is_slot(slot1)) return_false(sc, car_x); obj = slot_value(slot1); @@ -65768,13 +65533,6 @@ static bool p_ppp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer { s7_pointer arg1, arg2, arg3; int32_t start; - s7_pointer sig, checker = NULL; - - sig = c_function_signature(s_func); - if ((is_pair(sig)) && - (is_pair(cdr(sig))) && - (is_symbol(cadr(sig)))) - checker = cadr(sig); start = sc->pc; opc->v[3].p_ppp_f = func; @@ -65786,7 +65544,7 @@ static bool p_ppp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer s7_pointer slot, obj; opt_info *o1; - slot = symbol_to_slot(sc, arg1); + slot = lookup_slot_from(arg1, sc->curlet); if ((!is_slot(slot)) || (has_methods(slot_value(slot)))) return_false(sc, car_x); @@ -65809,12 +65567,10 @@ static bool p_ppp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer } opc->v[1].p = slot; - if ((checker) && (s7_p_ppp_unchecked_function(s_func))) - { - checker = s7_symbol_value(sc, checker); - if (s7_apply_function(sc, checker, set_plist_1(sc, obj)) == sc->T) - opc->v[3].p_ppp_f = s7_p_ppp_unchecked_function(s_func); - } + + if ((func == hash_table_set_p_ppp) && (is_hash_table(obj))) + opc->v[3].p_ppp_f = s7_hash_table_set; + if (is_symbol(arg2)) { slot = opt_simple_symbol(sc, arg2); @@ -65927,11 +65683,23 @@ static s7_pointer opt_p_call_sss(opt_info *o) return(o->v[4].call(opt_sc(o), set_plist_3(opt_sc(o), slot_value(o->v[1].p), slot_value(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(opt_sc(o), set_plist_3(opt_sc(o), o->v[1].p, slot_value(o->v[2].p), slot_value(o->v[3].p)))); +} + static s7_pointer opt_p_call_ssf(opt_info *o) { return(o->v[4].call(opt_sc(o), set_plist_3(opt_sc(o), slot_value(o->v[1].p), slot_value(o->v[2].p), o->v[6].fp(o->v[5].o1)))); } +static s7_pointer opt_p_substring_uncopied_ssf(opt_info *o) +{ + return(substring_uncopied_p_pii(opt_sc(o), slot_value(o->v[1].p), + s7_integer_checked(opt_sc(o), slot_value(o->v[2].p)), + s7_integer_checked(opt_sc(o), o->v[6].fp(o->v[5].o1)))); +} + static s7_pointer opt_p_call_ppp(opt_info *o) { s7_pointer res; @@ -65949,7 +65717,6 @@ static bool p_call_ppp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_po { int32_t start; start = sc->pc; - /* css (tbig (<= 2 m j)) ccs scs cfc ssf sfc fsc -- ssf then maybe scs */ if ((is_safe_procedure(s_func)) && (c_function_required_args(s_func) <= 3) && (c_function_all_args(s_func) >= 3)) @@ -65958,40 +65725,45 @@ static bool p_call_ppp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_po opt_info *o1; o1 = sc->opts[sc->pc]; arg = cadr(car_x); - if (is_symbol(arg)) + + if (!is_pair(arg)) { - slot = opt_simple_symbol(sc, arg); - if (slot) + if (is_symbol(arg)) { - opc->v[1].p = slot; - arg = caddr(car_x); - if (is_symbol(arg)) + slot = opt_simple_symbol(sc, arg); + if (slot) + opc->v[1].p = slot; + else return_false(sc, car_x); /* no need for pc_fallback here, I think */ + } + else opc->v[1].p = arg; + arg = caddr(car_x); + if (is_symbol(arg)) + { + slot = opt_simple_symbol(sc, arg); + if (slot) { - slot = opt_simple_symbol(sc, arg); - if (slot) + opc->v[2].p = slot; + arg = cadddr(car_x); + if (is_symbol(arg)) { - opc->v[2].p = slot; - arg = cadddr(car_x); - if (is_symbol(arg)) + slot = opt_simple_symbol(sc, arg); + if (slot) { - slot = opt_simple_symbol(sc, arg); - if (slot) - { - opc->v[3].p = slot; - opc->v[4].call = cf_call(sc, car_x, s_func, 3); - opc->v[0].fp = opt_p_call_sss; - return(true); - }} - else + opc->v[3].p = slot; + opc->v[4].call = cf_call(sc, car_x, s_func, 3); + opc->v[0].fp = (is_slot(opc->v[1].p)) ? opt_p_call_sss : opt_p_call_css; + return(true); + }} + else + { + if ((is_slot(opc->v[1].p)) && (cell_optimize(sc, cdddr(car_x)))) { - if (cell_optimize(sc, cdddr(car_x))) - { - opc->v[4].call = cf_call(sc, car_x, s_func, 3); - opc->v[0].fp = opt_p_call_ssf; - opc->v[5].o1 = o1; - opc->v[6].fp = o1->v[0].fp; - return(true); - }}}}}} + opc->v[4].call = cf_call(sc, car_x, s_func, 3); + opc->v[0].fp = (opc->v[4].call == g_substring_uncopied) ? opt_p_substring_uncopied_ssf : opt_p_call_ssf; + opc->v[5].o1 = o1; + opc->v[6].fp = o1->v[0].fp; + return(true); + }}}}} if (cell_optimize(sc, cdr(car_x))) { opt_info *o2; @@ -66096,7 +65868,7 @@ static bool p_fx_any_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_poin static bool p_implicit(s7_scheme *sc, s7_pointer car_x, int32_t len) { s7_pointer s_slot; - s_slot = symbol_to_slot(sc, car(car_x)); + s_slot = lookup_slot_from(car(car_x), sc->curlet); if (is_slot(s_slot)) { @@ -66144,7 +65916,7 @@ static bool p_implicit(s7_scheme *sc, s7_pointer car_x, int32_t len) if (is_symbol(cadr(car_x))) { s7_pointer slot; - slot = symbol_to_slot(sc, cadr(car_x)); + slot = lookup_slot_from(cadr(car_x), sc->curlet); if (is_slot(slot)) { opc->v[2].p = slot; @@ -66463,8 +66235,6 @@ static bool is_some_number(s7_scheme *sc, s7_pointer tp) static bool check_type_uncertainty(s7_scheme *sc, s7_pointer target, s7_pointer car_x, opt_info *opc, int32_t start_pc) { s7_pointer code; - - /* fprintf(stderr, "%s[%d]:\n %s\n %s\n", __func__, __LINE__, display(sc->code), display(car_x)); */ /* if we're optimizing do, sc->code is (sometimes) ((vars...) (end...) car_x) where car_x is the do body, but it can also be for-each etc */ code = sc->code; @@ -66523,7 +66293,7 @@ static bool opt_cell_set(s7_scheme *sc, s7_pointer car_x) /* len == 3 here (p_sy if ((is_constant_symbol(sc, target)) || (symbol_has_setter(target))) return_false(sc, car_x); - settee = symbol_to_slot(sc, target); + settee = lookup_slot_from(target, sc->curlet); if ((is_slot(settee)) && (!is_immutable(settee)) && @@ -66616,7 +66386,7 @@ static bool opt_cell_set(s7_scheme *sc, s7_pointer car_x) /* len == 3 here (p_sy ((is_null(cddr(target))) || (is_null(cdddr(target))))) { s7_pointer s_slot; - s_slot = symbol_to_slot(sc, car(target)); + s_slot = lookup_slot_from(car(target), sc->curlet); if (is_slot(s_slot)) { s7_pointer obj; @@ -66941,15 +66711,12 @@ static void oo_idp_nr_fixup(opt_info *start) if (start->v[6].d_dd_f == add_d_dd) start->v[0].fp = opt_d_7pid_ssfo_fv_add_nr; else - { - if (start->v[6].d_dd_f == subtract_d_dd) - start->v[0].fp = opt_d_7pid_ssfo_fv_sub_nr; - }}}} + if (start->v[6].d_dd_f == subtract_d_dd) + start->v[0].fp = opt_d_7pid_ssfo_fv_sub_nr; + }}} else - { - if (start->v[0].fp == i_to_p) - start->v[0].fp = i_to_p_nr; - } + if (start->v[0].fp == i_to_p) + start->v[0].fp = i_to_p_nr; } static bool opt_cell_begin(s7_scheme *sc, s7_pointer car_x, int32_t len) @@ -67626,7 +67393,7 @@ static bool opt_cell_let_temporarily(s7_scheme *sc, s7_pointer car_x, int32_t le opt_info *opc; int32_t i; opc = alloc_opo(sc); - opc->v[1].p = symbol_to_slot(sc, caar(cadr(car_x))); + opc->v[1].p = lookup_slot_from(caar(cadr(car_x)), sc->curlet); if (!is_slot(opc->v[1].p)) return_false(sc, car_x); @@ -68334,7 +68101,7 @@ static bool opt_cell_do(s7_scheme *sc, s7_pointer car_x, int32_t len) return_false(sc, car_x); } if (is_symbol(cadr(var))) - slot_set_value(slot, slot_value(symbol_to_slot(sc, cadr(var)))); + slot_set_value(slot, slot_value(lookup_slot_from(cadr(var), sc->curlet))); else { if (!is_pair(cadr(var))) @@ -68617,7 +68384,7 @@ static bool opt_cell_do(s7_scheme *sc, s7_pointer car_x, int32_t len) s7_pointer slot; slot = let_slots(let); let_set_dox_slot1(let, slot); - let_set_dox_slot2_unchecked(let, (is_symbol(caddr(end))) ? symbol_to_slot(sc, caddr(end)) : sc->undefined); + let_set_dox_slot2_unchecked(let, (is_symbol(caddr(end))) ? lookup_slot_from(caddr(end), sc->curlet) : sc->undefined); slot_set_value(slot, make_mutable_integer(sc, integer(slot_value(slot)))); opc->v[4].i = body_index; if (body_len == 1) @@ -68745,7 +68512,7 @@ static bool float_optimize(s7_scheme *sc, s7_pointer expr) if ((is_global(head)) || ((is_slot(global_slot(head))) && - (symbol_to_slot(sc, head) == global_slot(head)))) + (lookup_slot_from(head, sc->curlet) == global_slot(head)))) s_func = slot_value(global_slot(head)); else return(d_implicit_ok(sc, car_x, len)); @@ -68800,11 +68567,10 @@ static bool float_optimize(s7_scheme *sc, s7_pointer expr) }} else { - if (is_macro(s_func)) - { - if (!no_cell_opt(expr)) - return(float_optimize(sc, set_plist_1(sc, s7_macroexpand(sc, s_func, cdar(expr))))); /* is this use of plist safe? */ - }}} + if ((is_macro(s_func)) && + (!no_cell_opt(expr))) + return(float_optimize(sc, set_plist_1(sc, s7_macroexpand(sc, s_func, cdar(expr))))); /* is this use of plist safe? */ + }} return_false(sc, car_x); } @@ -68829,7 +68595,7 @@ static bool int_optimize(s7_scheme *sc, s7_pointer expr) if ((is_global(head)) || ((is_slot(global_slot(head))) && - (symbol_to_slot(sc, head) == global_slot(head)))) + (lookup_slot_from(head, sc->curlet) == global_slot(head)))) s_func = slot_value(global_slot(head)); else return(i_implicit_ok(sc, car_x, len)); @@ -68875,11 +68641,10 @@ static bool int_optimize(s7_scheme *sc, s7_pointer expr) }} else { - if (is_macro(s_func)) - { - if (!no_cell_opt(expr)) - return(int_optimize(sc, set_plist_1(sc, s7_macroexpand(sc, s_func, cdar(expr))))); - }}} + if ((is_macro(s_func)) && + (!no_cell_opt(expr))) + return(int_optimize(sc, set_plist_1(sc, s7_macroexpand(sc, s_func, cdar(expr))))); + }} return_false(sc, car_x); } @@ -68904,7 +68669,7 @@ static bool cell_optimize(s7_scheme *sc, s7_pointer expr) if ((is_global(head)) || ((is_slot(global_slot(head))) && - (symbol_to_slot(sc, head) == global_slot(head)))) + (lookup_slot_from(head, sc->curlet) == global_slot(head)))) s_func = slot_value(global_slot(head)); else return(p_implicit(sc, car_x, len)); @@ -69085,14 +68850,14 @@ static bool bool_optimize_nw(s7_scheme *sc, s7_pointer expr) { if (head == sc->and_symbol) return(opt_b_and(sc, car_x, len)); - if (head == sc->or_symbol) + if (head == sc->or_symbol) return(opt_b_or(sc, car_x, len)); return_false(sc, car_x); } if ((is_global(head)) || ((is_slot(global_slot(head))) && - (symbol_to_slot(sc, head) == global_slot(head)))) + (lookup_slot_from(head, sc->curlet) == global_slot(head)))) s_func = slot_value(global_slot(head)); else return_false(sc, car_x); @@ -69154,10 +68919,9 @@ static bool bool_optimize_nw(s7_scheme *sc, s7_pointer expr) break; }} else - { - if (is_macro(s_func)) - return_false(sc, car_x); - }} + if (is_macro(s_func)) + return_false(sc, car_x); + } return_false(sc, car_x); } @@ -69380,12 +69144,11 @@ static s7_pointer g_for_each_closure(s7_scheme *sc, s7_pointer f, s7_pointer seq fd(o); }} else - { - for (i = 0; i < len; i++) - { - real(sv) = vals[i]; - func(sc, expr); - }} + for (i = 0; i < len; i++) + { + real(sv) = vals[i]; + func(sc, expr); + } return(sc->unspecified); } for (i = 0; i < len; i++) @@ -69424,12 +69187,11 @@ static s7_pointer g_for_each_closure(s7_scheme *sc, s7_pointer f, s7_pointer seq fi(o); }} else - { - for (i = 0; i < len; i++) - { - integer(sv) = vals[i]; - func(sc, expr); - }} + for (i = 0; i < len; i++) + { + integer(sv) = vals[i]; + func(sc, expr); + } return(sc->unspecified); } @@ -69547,10 +69309,8 @@ Each object can be a list, string, vector, hash-table, or any other sequence." arity_ok = true; } else - { - if (!is_applicable(f)) - return(method_or_bust_with_type(sc, f, sc->for_each_symbol, args, something_applicable_string, 1)); - } + if (!is_applicable(f)) + return(method_or_bust_with_type(sc, f, sc->for_each_symbol, args, something_applicable_string, 1)); if ((!arity_ok) && (!s7_is_aritable(sc, f, len))) @@ -69584,8 +69344,7 @@ Each object can be a list, string, vector, hash-table, or any other sequence." /* not pop_stack here since that can clobber sc->code et al, and if this for-each call is * being treated as safe, c_call(for-each) assumes everywhere that sc->code is left alone. */ - unstack(sc); - /* free_cell(sc, x); */ /* 16-Jan-19 */ + unstack(sc); /* free_cell(sc, x); */ /* 16-Jan-19 */ return(sc->unspecified); } func(sc, y); @@ -69689,8 +69448,7 @@ static Inline bool op_for_each_2(s7_scheme *sc) if (!is_pair(lst)) /* '(1 2 . 3) as arg? -- counter_list can be anything here */ { sc->value = sc->unspecified; - free_cell(sc, c); - /* sc->args = sc->nil; */ + free_cell(sc, c); /* not sc->args = sc->nil; */ return(true); } counter_set_list(c, cdr(lst)); @@ -69700,8 +69458,7 @@ static Inline bool op_for_each_2(s7_scheme *sc) if (counter_result(c) == counter_list(c)) { sc->value = sc->unspecified; - free_cell(sc, c); - /* sc->args = sc->nil; */ + free_cell(sc, c); /* not sc->args = sc->nil; */ return(true); } push_stack_direct(sc, OP_FOR_EACH_2); @@ -69749,7 +69506,7 @@ static s7_pointer g_map_closure(s7_scheme *sc, s7_pointer f, s7_pointer seq) expr = car(body); if (is_symbol(expr)) { - expr = symbol_to_slot(sc, expr); + expr = lookup_slot_from(expr, sc->curlet); func = slookup; } else func = s7_optimize(sc, body); @@ -69758,7 +69515,7 @@ static s7_pointer g_map_closure(s7_scheme *sc, s7_pointer f, s7_pointer seq) { expr = cons(sc, sc->begin_symbol, body); sc->w = expr; /* GC protection? */ - func = s7_cell_optimize(sc, cons(sc, expr, sc->nil), false); + func = s7_cell_optimize(sc, list_1(sc, expr), false); } if (func) { @@ -69967,8 +69724,7 @@ static bool op_map(s7_scheme *sc) if (iterator_is_at_end(car(y))) { sc->value = safe_reverse_in_place(sc, counter_result(sc->args)); - free_cell(sc, sc->args); - /* sc->args = sc->nil; */ + free_cell(sc, sc->args); /* not sc->args = sc->nil; */ return(true); } sc->x = cons(sc, x, sc->x); @@ -69994,9 +69750,7 @@ static bool op_map_1(s7_scheme *sc) if (iterator_is_at_end(p)) { sc->value = safe_reverse_in_place(sc, counter_result(args)); - /* an experiment */ - free_cell(sc, sc->args); - /* sc->args = sc->nil; */ + free_cell(sc, sc->args); /* not sc->args = sc->nil; */ return(true); } push_stack_direct(sc, OP_MAP_GATHER_1); @@ -70033,8 +69787,7 @@ static bool op_map_2(s7_scheme *sc) if (!is_pair(p)) { sc->value = safe_reverse_in_place(sc, counter_result(c)); - free_cell(sc, sc->args); - /* sc->args = sc->nil; */ + free_cell(sc, sc->args); /* not sc->args = sc->nil; */ return(true); } x = car(p); @@ -70047,8 +69800,7 @@ static bool op_map_2(s7_scheme *sc) if (closure_map_list(code) == counter_list(c)) { sc->value = safe_reverse_in_place(sc, counter_result(c)); - free_cell(sc, c); - /* sc->args = sc->nil; */ + free_cell(sc, c); /* not sc->args = sc->nil; */ return(true); } push_stack_direct(sc, OP_MAP_GATHER_2); @@ -70073,6 +69825,18 @@ static bool op_map_2(s7_scheme *sc) /* -------------------------------- multiple-values -------------------------------- */ +#if S7_DEBUGGING +#define T_Mut(p) T_Mut_1(p, __func__, __LINE__) +static s7_pointer T_Mut_1(s7_pointer p, const char *func, int line) +{ + if ((is_pair(p)) && ((is_immutable(p)) || (not_in_heap(p)))) /* might be nil */ + fprintf(stderr, "%s[%d]: immutable list: %p\n", func, line, p); + return(p); +} +#else +#define T_Mut(p) p +#endif + static s7_pointer splice_in_values(s7_scheme *sc, s7_pointer args) { int64_t top; @@ -70097,7 +69861,7 @@ static s7_pointer splice_in_values(s7_scheme *sc, s7_pointer args) * (all this to avoid consing), clobbers the variable's value. */ for (x = args; is_not_null(cdr(x)); x = cdr(x)) - stack_args(sc->stack, top) = cons(sc, car(x), stack_args(sc->stack, top)); + stack_args(sc->stack, top) = cons(sc, car(x), T_Mut(stack_args(sc->stack, top))); return(car(x)); /* in the next set, the main evaluator branches blithely assume no multiple-values, @@ -70161,7 +69925,6 @@ static s7_pointer splice_in_values(s7_scheme *sc, s7_pointer args) case OP_SAFE_CLOSURE_AP_1: case OP_CLOSURE_AP_1: case OP_SAFE_CLOSURE_PP_1: case OP_CLOSURE_PP_1: case OP_SAFE_CLOSURE_PA_1: case OP_CLOSURE_PA_1: /* arity is 2, we have 2 args, this has to be an error (see optimize_closure_dotted_args) */ - case OP_EVAL_DONE_NO_MV: case OP_ANY_CLOSURE_3P_1: case OP_ANY_CLOSURE_3P_2: case OP_ANY_CLOSURE_3P_3: case OP_ANY_CLOSURE_4P_1: case OP_ANY_CLOSURE_4P_2: case OP_ANY_CLOSURE_4P_3: case OP_ANY_CLOSURE_4P_4: return(s7_error(sc, sc->wrong_number_of_args_symbol, set_elist_3(sc, too_many_arguments_string, stack_code(sc->stack, top), sc->value))); @@ -70187,7 +69950,7 @@ static s7_pointer splice_in_values(s7_scheme *sc, s7_pointer args) if (is_null(cdr(args))) return(car(args)); - stack_args(sc->stack, top) = cons(sc, stack_code(sc->stack, top), stack_args(sc->stack, top)); + stack_args(sc->stack, top) = cons(sc, stack_code(sc->stack, top), T_Mut(stack_args(sc->stack, top))); for (x = args; is_not_null(cddr(x)); x = cdr(x)) stack_args(sc->stack, top) = cons(sc, car(x), stack_args(sc->stack, top)); stack_code(sc->stack, top) = car(x); @@ -70196,10 +69959,10 @@ static s7_pointer splice_in_values(s7_scheme *sc, s7_pointer args) /* look for errors here rather than glomming up the set! and let code. */ case OP_SET_SAFE: /* symbol is sc->code after pop */ case OP_SET1: /* (set! var (values 1 2 3)) */ - eval_error_with_caller2(sc, "~A: can't set ~A to ~S", 22, sc->set_symbol, stack_code(sc->stack, top), cons(sc, sc->values_symbol, args)); + eval_error_with_caller2(sc, "~A: can't set ~A to ~S", 22, sc->set_symbol, stack_code(sc->stack, top), set_ulist_1(sc, sc->values_symbol, args)); case OP_SET_PAIR_P_1: - eval_error(sc, "too many values to set! ~S", 26, cons(sc, sc->values_symbol, args)); + eval_error(sc, "too many values to set! ~S", 26, set_ulist_1(sc, sc->values_symbol, args)); case OP_INCREMENT_SP_1: /* slot is in stack_args(top), args is the values list */ stack_element(sc->stack, top) = (s7_pointer)OP_INCREMENT_SP_MV; @@ -70212,7 +69975,7 @@ static s7_pointer splice_in_values(s7_scheme *sc, s7_pointer args) for (let_code = p; is_pair(cdr(let_code)); let_code = cdr(let_code)); for (vars = caar(let_code); is_pair(cdr(p)); p = cdr(p), vars = cdr(vars)); sym = caar(vars); - eval_error_with_caller2(sc, "~A: can't bind ~A to ~S", 23, sc->let_symbol, sym, cons(sc, sc->values_symbol, args)); + eval_error_with_caller2(sc, "~A: can't bind ~A to ~S", 23, sc->let_symbol, sym, set_ulist_1(sc, sc->values_symbol, args)); /* stack_args: ((((x (values 1 2))) x)) in (let ((x (values 1 2))) x) * (1 (((x 1) (y (values 1 2))) x)) in (let ((x 1) (y (values 1 2))) x) */ @@ -70221,24 +69984,24 @@ static s7_pointer splice_in_values(s7_scheme *sc, s7_pointer args) case OP_LET_ONE_NEW_1: case OP_LET_ONE_P_NEW_1: eval_error_with_caller2(sc, "~A: can't bind ~A to ~S", 23, sc->let_symbol, - opt2_sym(stack_code(sc->stack, top)), cons(sc, sc->values_symbol, args)); + opt2_sym(stack_code(sc->stack, top)), set_ulist_1(sc, sc->values_symbol, args)); case OP_LET_ONE_OLD_1: /* can these happen? */ case OP_LET_ONE_P_OLD_1: eval_error_with_caller2(sc, "~A: can't bind ~A to ~S", 23, sc->let_symbol, - opt2_sym(cdr(stack_code(sc->stack, top))), cons(sc, sc->values_symbol, args)); + opt2_sym(cdr(stack_code(sc->stack, top))), set_ulist_1(sc, sc->values_symbol, args)); case OP_LET_STAR1: /* here caar(sc->code) is bound to sc->value */ eval_error_with_caller2(sc, "~A: can't bind ~A to ~S", 23, sc->let_star_symbol, - caar(stack_code(sc->stack, top)), cons(sc, sc->values_symbol, args)); + caar(stack_code(sc->stack, top)), set_ulist_1(sc, sc->values_symbol, args)); case OP_LETREC1: /* here sc->args is the slot about to receive a value */ eval_error_with_caller2(sc, "~A: can't bind ~A to ~S", 23, sc->letrec_symbol, - slot_symbol(stack_args(sc->stack, top)), cons(sc, sc->values_symbol, args)); + slot_symbol(stack_args(sc->stack, top)), set_ulist_1(sc, sc->values_symbol, args)); case OP_LETREC_STAR1: eval_error_with_caller2(sc, "~A: can't bind ~A to ~S", 23, sc->letrec_star_symbol, - slot_symbol(stack_args(sc->stack, top)), cons(sc, sc->values_symbol, args)); + slot_symbol(stack_args(sc->stack, top)), set_ulist_1(sc, sc->values_symbol, args)); /* handle 'and' and 'or' specially */ case OP_AND_P1: @@ -70306,10 +70069,16 @@ static s7_pointer splice_in_values(s7_scheme *sc, s7_pointer args) */ top -= 4; for (x = args; is_not_null(cdr(x)); x = cdr(x)) - stack_args(sc->stack, top) = cons(sc, car(x), stack_args(sc->stack, top)); + stack_args(sc->stack, top) = cons(sc, car(x), T_Mut(stack_args(sc->stack, top))); pop_stack(sc); /* need GC protection in loop above, so do this afterwards */ return(car(x)); /* sc->value from OP_READ_LIST point of view */ + case OP_EVAL_DONE: + stack_element(sc->stack, top) = (s7_pointer)OP_SPLICE_VALUES; /* tricky -- continue from eval_done with the current splice */ + stack_args(sc->stack, top) = args; + push_stack_op(sc, OP_EVAL_DONE); + return(args); + default: /* fprintf(stderr, "%s[%d]: splice on: %s\n", __func__, __LINE__, op_names[stack_op(sc->stack, top)]); */ break; @@ -70319,7 +70088,7 @@ static s7_pointer splice_in_values(s7_scheme *sc, s7_pointer args) * the is_immutable check protects against setting the multiple value bit on (say) sc->hash_table_signature */ if (is_immutable(args)) - args = copy_proper_list(sc, args); /* copy need else (apply values x) where x is a list can leave the mv bit on for x's value */ + args = copy_proper_list(sc, args); /* copy needed else (apply values x) where x is a list can leave the mv bit on for x's value */ if (needs_copied_args(args)) { clear_needs_copied_args(args); @@ -70341,6 +70110,7 @@ s7_pointer s7_values(s7_scheme *sc, s7_pointer args) if (is_null(cdr(args))) return(car(args)); set_needs_copied_args(args); + /* copy needed: see s7test (test `(,x ,@y ,x) '(3 a b c 3)) -> (append (list-values x (apply-values y)) x), and apply_values calls s7_values directly */ return(splice_in_values(sc, args)); } @@ -70349,6 +70119,12 @@ 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 *sc, s7_pointer p) {return(p);} +static s7_pointer values_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool ops) +{ + if (args > 1) return(sc->values_uncopied); + return(f); +} + /* -------------------------------- list-values -------------------------------- */ static s7_pointer g_list_values(s7_scheme *sc, s7_pointer args) @@ -70368,16 +70144,15 @@ static s7_pointer g_list_values(s7_scheme *sc, s7_pointer args) checked = true; } else - { - if (car(x) == sc->no_value) /* unchecked_car|cdr unrolled here is not faster */ - break; - }} + if (car(x) == sc->no_value) /* unchecked_car|cdr unrolled here is not faster */ + break; + } if (is_null(x)) { if (checked) { sc->u = args; - check_heap_size(sc, 8192); + check_free_heap_size(sc, 8192); #if S7_DEBUGGING if (tree_is_cyclic(sc, args)) { @@ -70473,10 +70248,8 @@ static bool is_simple_code(s7_scheme *sc, s7_pointer form) return(false); } else - { - if (car(tmp) == sc->unquote_symbol) - return(false); - } + if (car(tmp) == sc->unquote_symbol) + return(false); tmp = cdr(tmp); if (!is_pair(tmp)) return(is_null(tmp)); if (tmp == slow) return(false); @@ -70486,10 +70259,9 @@ static bool is_simple_code(s7_scheme *sc, s7_pointer form) return(false); } else - { - if (car(tmp) == sc->unquote_symbol) - return(false); - }} + if (car(tmp) == sc->unquote_symbol) + return(false); + } return(is_null(tmp)); } @@ -70551,7 +70323,7 @@ and splices the resultant list into the outer list. `(1 ,(+ 1 1) ,@(list 3 4)) - } return(list_2(sc, sc->quote_symbol, form)); } - + { s7_int len, i; s7_pointer orig, bq, old_scw; @@ -70566,9 +70338,10 @@ and splices the resultant list into the outer list. `(1 ,(+ 1 1) ,@(list 3 4)) - old_scw = sc->w; push_stack_no_let_no_code(sc, OP_GC_PROTECT, sc->w); + check_free_heap_size(sc, len); sc->w = sc->nil; for (i = 0; i <= len; i++) - sc->w = cons(sc, sc->nil, sc->w); + sc->w = cons_unchecked(sc, sc->nil, sc->w); set_car(sc->w, sc->list_values_symbol); if (!dotted) @@ -70987,7 +70760,7 @@ static s7_pointer unknown_string_constant(s7_scheme *sc, int32_t c) if (hook_has_functions(sc->read_error_hook)) { s7_pointer result; - result = s7_call(sc, sc->read_error_hook, list_2(sc, sc->F, s7_make_character(sc, (uint8_t)c))); + result = s7_call(sc, sc->read_error_hook, set_plist_2(sc, sc->F, s7_make_character(sc, (uint8_t)c))); if (s7_is_character(result)) return(result); } @@ -71056,10 +70829,9 @@ static s7_pointer read_string_constant(s7_scheme *sc, s7_pointer pt) break; } else - { - if (*s == '\n') - port_line_number(pt)++; - }}} + if (*s == '\n') + port_line_number(pt)++; + }} while (true) { @@ -71323,7 +71095,7 @@ static int32_t read_atom(s7_scheme *sc, s7_pointer pt) push_stack_no_let_no_code(sc, OP_READ_LIST, sc->args); check_stack_size(sc); sc->value = port_read_name(pt)(sc, pt); - sc->args = cons(sc, sc->value, sc->nil); + sc->args = list_1(sc, sc->value); pair_set_current_input_location(sc, sc->args); return(port_read_white_space(pt)(sc, pt)); } @@ -71344,6 +71116,9 @@ static s7_pointer unbound_variable_error(s7_scheme *sc, s7_pointer sym) { if (s7_tree_memq(sc, sym, current_code(sc))) return(s7_error(sc, sc->unbound_variable_symbol, set_elist_3(sc, wrap_string(sc, "unbound variable ~S in ~S", 25), sym, current_code(sc)))); + if ((symbol_name(sym)[symbol_name_length(sym) - 1] == ',') && + (lookup_unexamined(sc, make_symbol_with_length(sc, symbol_name(sym), symbol_name_length(sym) - 1)))) + return(s7_error(sc, sc->unbound_variable_symbol, set_elist_2(sc, wrap_string(sc, "unbound variable ~S (perhaps a stray comma?)", 44), sym))); return(s7_error(sc, sc->unbound_variable_symbol, set_elist_2(sc, wrap_string(sc, "unbound variable ~S", 19), sym))); } @@ -71383,12 +71158,12 @@ static s7_pointer unbound_variable(s7_scheme *sc, s7_pointer sym) result = sc->undefined; x = sc->x; z = sc->z; - sc->temp7 = cons(sc, code, cons(sc, args, cons(sc, value, cons(sc, cur_code, cons(sc, x, cons(sc, z, sc->nil)))))); /* not s7_list (debugger checks) */ + sc->temp7 = cons(sc, code, cons(sc, args, list_4(sc, value, cur_code, x, z))); /* not s7_list (debugger checks) */ if (!is_pair(cur_code)) { /* isolated typo perhaps -- no pair to hold the position info, so make one. current_code(sc) is GC-protected, so this should be safe. */ - cur_code = cons(sc, sym, sc->nil); /* the error will say "(sym)" which is not too misleading */ + cur_code = list_1(sc, sym); /* the error will say "(sym)" which is not too misleading */ pair_set_current_input_location(sc, cur_code); } @@ -71412,7 +71187,7 @@ static s7_pointer unbound_variable(s7_scheme *sc, s7_pointer sym) if ((!e) || (!is_let(e))) { if (hook_has_functions(sc->autoload_hook)) - s7_apply_function(sc, sc->autoload_hook, list_2(sc, sym, sc->temp6 = s7_make_string(sc, file))); + s7_apply_function(sc, sc->autoload_hook, set_plist_2(sc, sym, sc->temp6 = s7_make_string(sc, file))); e = s7_load(sc, file); /* s7_load can return NULL */ } result = s7_symbol_value(sc, sym); /* calls lookup, does not trigger unbound_variable search */ @@ -71441,7 +71216,7 @@ static s7_pointer unbound_variable(s7_scheme *sc, s7_pointer sym) if (is_string(val)) /* val should be a filename. *load-path* is searched if necessary. */ { if (hook_has_functions(sc->autoload_hook)) - s7_apply_function(sc, sc->autoload_hook, list_2(sc, sym, val)); + s7_apply_function(sc, sc->autoload_hook, set_plist_2(sc, sym, val)); s7_load(sc, string_value(val)); } else @@ -71449,8 +71224,8 @@ static s7_pointer unbound_variable(s7_scheme *sc, s7_pointer sym) if (is_closure(val)) /* val should be a function of one argument, the current (calling) environment */ { if (hook_has_functions(sc->autoload_hook)) - s7_apply_function(sc, sc->autoload_hook, list_2(sc, sym, val)); - s7_call(sc, val, s7_cons(sc, sc->curlet, sc->nil)); + s7_apply_function(sc, sc->autoload_hook, set_plist_2(sc, sym, val)); + s7_call(sc, val, set_ulist_1(sc, sc->curlet, sc->nil)); }} result = s7_symbol_value(sc, sym); /* calls lookup, does not trigger unbound_variable search */ } @@ -71469,7 +71244,7 @@ static s7_pointer unbound_variable(s7_scheme *sc, s7_pointer sym) old_hook = sc->unbound_variable_hook; set_car(sc->z2_1, old_hook); sc->unbound_variable_hook = sc->error_hook; /* avoid the infinite loop mentioned above -- error_hook might be () or #f if we're in error-hook now */ - result = s7_call(sc, old_hook, list_1(sc, sym)); /* not s7_apply_function */ + result = s7_call(sc, old_hook, set_plist_1(sc, sym)); /* not s7_apply_function */ sc->unbound_variable_hook = old_hook; s7_set_history_enabled(sc, old_history_enabled); }} @@ -71491,7 +71266,7 @@ static s7_pointer unbound_variable(s7_scheme *sc, s7_pointer sym) static bool gx_annotate_arg(s7_scheme *sc, s7_pointer p, s7_pointer e) { - if (is_gxable(car(p))) + if ((!no_gx(p)) && (is_gxable(car(p)))) { opcode_t old_op; s7_pointer fxf; @@ -71503,6 +71278,7 @@ static bool gx_annotate_arg(s7_scheme *sc, s7_pointer p, s7_pointer e) set_has_gx(p); set_opt2(p, fxf, F_CALL); } + else set_no_gx(p); set_optimize_op(car(p), old_op); return(fxf); } @@ -71546,7 +71322,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 (is_constant_symbol(sc, car(expr))) hop = 1; + if ((hop != 1) && (is_constant_symbol(sc, car(expr)))) hop = 1; if ((is_closure(func)) || (is_closure_star(func))) { @@ -71649,7 +71425,6 @@ static int32_t combine_ops(s7_scheme *sc, s7_pointer func, s7_pointer expr, comb case OP_SAFE_C_SC: return(OP_SAFE_C_opSCq); case OP_SAFE_C_CS: return(OP_SAFE_C_opCSq); case OP_SAFE_C_opSq: return(OP_SAFE_C_op_opSqq); - case OP_SAFE_C_opSq_C: return(OP_SAFE_C_op_opSq_Cq); case OP_SAFE_C_S_opSq: return(OP_SAFE_C_op_S_opSqq); case OP_SAFE_C_opSq_S: return(OP_SAFE_C_op_opSq_Sq); case OP_SAFE_C_A: return(OP_SAFE_C_opAq); @@ -71682,10 +71457,7 @@ static int32_t combine_ops(s7_scheme *sc, s7_pointer func, s7_pointer expr, comb set_opt2_sym(cdr(expr), caddr(arg)); return(OP_SAFE_C_S_opSSq); - case OP_SAFE_C_opSq_C: return(OP_SAFE_C_S_op_opSq_Cq); case OP_SAFE_C_S_opSSq: return(OP_SAFE_C_S_op_S_opSSqq); - case OP_SAFE_C_S_opSq: return(OP_SAFE_C_S_op_S_opSqq); - case OP_SAFE_C_opSSq_opSSq: return(OP_SAFE_C_S_op_opSSq_opSSqq); case OP_SAFE_C_A: set_opt3_pair(expr, cdaddr(expr)); return(OP_SAFE_C_S_opAq); @@ -71701,14 +71473,9 @@ static int32_t combine_ops(s7_scheme *sc, s7_pointer func, s7_pointer expr, comb { case OP_SAFE_C_S: return(OP_SAFE_C_opSq_S); case OP_SAFE_C_SS: return(OP_SAFE_C_opSSq_S); - case OP_SAFE_C_D: set_opt2_sym(cdr(expr), e2); return(OP_SAFE_C_opDq_S); case OP_SAFE_C_CS: return(OP_SAFE_C_opCSq_S); case OP_SAFE_C_A: return(OP_SAFE_C_opAq_S); case OP_SAFE_C_opSSq: set_opt1_pair(cdr(expr), cadadr(expr)); return(OP_SAFE_C_op_opSSqq_S); - case OP_SAFE_C_opSSq_S: - set_opt3_pair(expr, cadadr(expr)); - set_opt1_sym(cdr(expr), caddadr(expr)); - return(OP_SAFE_C_op_opSSq_Sq_S); } return(OP_SAFE_C_PS); @@ -71718,13 +71485,11 @@ static int32_t combine_ops(s7_scheme *sc, s7_pointer func, s7_pointer expr, comb switch (arg_op) { case OP_SAFE_C_S: - set_opt1_con(cdr(expr), (is_quoted_pair(cadr(e1))) ? cadadr(e1) : cadr(e1)); + set_opt1_sym(cdr(expr), cadr(e1)); set_opt2_con(cdr(expr), e2); return(OP_SAFE_C_opSq_C); case OP_SAFE_C_CS: return(OP_SAFE_C_opCSq_C); case OP_SAFE_C_SC: return(OP_SAFE_C_opSCq_C); - case OP_SAFE_C_opSq: return(OP_SAFE_C_op_opSqq_C); - case OP_SAFE_C_opSSq: return(OP_SAFE_C_op_opSSqq_C); case OP_SAFE_C_SS: return(OP_SAFE_C_opSSq_C); } set_opt3_any(cdr(expr), caddr(expr)); @@ -71743,10 +71508,6 @@ static int32_t combine_ops(s7_scheme *sc, s7_pointer func, s7_pointer expr, comb set_opt3_pair(expr, arg); return(OP_SAFE_C_C_opSq); - case OP_SAFE_C_CS: - set_opt2_sym(cdr(expr), caddr(arg)); - return(OP_SAFE_C_C_opCSq); - case OP_SAFE_C_SC: set_opt1_sym(cdr(expr), cadr(arg)); set_opt2_con(cdr(expr), caddr(arg)); @@ -71789,10 +71550,33 @@ static bool arg_findable(s7_scheme *sc, s7_pointer arg1, s7_pointer e) { if (pair_symbol_is_safe(sc, arg1, e)) return(true); /* includes global_slot check */ return((!sc->in_with_let) && - (is_slot(symbol_to_slot(sc, arg1)))); + (is_slot(lookup_slot_from(arg1, sc->curlet)))); +} + +static bool safe_c_aa_to_ag_ga(s7_scheme *sc, s7_pointer arg, int hop) +{ + if (c_callee(cddr(arg)) == fx_s) {set_opt3_sym(arg, caddr(arg)); set_safe_optimize_op(arg, hop + OP_SAFE_C_AS); return(true);} + if (c_callee(cdr(arg)) == fx_s) {set_opt3_sym(arg, cadr(arg)); set_safe_optimize_op(arg, hop + OP_SAFE_C_SA); return(true);} + if (c_callee(cddr(arg)) == fx_c) {set_opt3_con(arg, caddr(arg)); set_safe_optimize_op(arg, hop + OP_SAFE_C_AC); return(true);} + if (c_callee(cdr(arg)) == fx_c) {set_opt3_con(arg, cadr(arg)); set_safe_optimize_op(arg, hop + OP_SAFE_C_CA); return(true);} + if (c_callee(cddr(arg)) == fx_q) {set_opt3_con(arg, cadaddr(arg)); set_safe_optimize_op(arg, hop + OP_SAFE_C_AC); return(true);} + if (c_callee(cdr(arg)) == fx_q) {set_opt3_con(arg, cadadr(arg)); set_safe_optimize_op(arg, hop + OP_SAFE_C_CA); return(true);} + return(false); +} + +static opt_t check_c_aa(s7_scheme *sc, s7_pointer expr, s7_pointer func, int32_t hop, s7_pointer e) +{ + fx_annotate_args(sc, cdr(expr), e); + if (!safe_c_aa_to_ag_ga(sc, expr, hop)) + { + set_optimize_op(expr, hop + OP_SAFE_C_AA); + set_opt3_arglen(expr, int_two); + } + choose_c_function(sc, expr, func, 2); + return(OPT_T); } -static opt_t wrap_bad_args(s7_scheme *sc, s7_pointer func, s7_pointer expr, int32_t n_args, int32_t hop) +static opt_t wrap_bad_args(s7_scheme *sc, s7_pointer func, s7_pointer expr, int32_t n_args, int32_t hop, s7_pointer e) { set_opt3_arglen(expr, small_int(n_args)); if (is_c_function(func)) @@ -71800,6 +71584,9 @@ static opt_t wrap_bad_args(s7_scheme *sc, s7_pointer func, s7_pointer expr, int3 set_safe_optimize_op(expr, hop + ((is_safe_procedure(func)) ? ((n_args == 1) ? OP_SAFE_C_A : OP_SAFE_C_AA) : ((n_args == 1) ? OP_C_A : OP_C_AA))); + if (optimize_op(expr) == HOP_SAFE_C_AA) + return(check_c_aa(sc, expr, func, hop, e)); + set_c_function(expr, func); return(OPT_T); } @@ -71836,7 +71623,7 @@ static opt_t wrap_bad_args(s7_scheme *sc, s7_pointer func, s7_pointer expr, int3 else { if (closure_star_arity_to_int(sc, func) == 2) - set_optimize_op(expr, ((is_safe_closure(func)) ? ((is_null(cdr(closure_body(func)))) ? OP_SAFE_CLOSURE_STAR_AA_O : + set_optimize_op(expr, ((is_safe_closure(func)) ? ((is_null(cdr(closure_body(func)))) ? OP_SAFE_CLOSURE_STAR_AA_O : OP_SAFE_CLOSURE_STAR_AA) : OP_CLOSURE_STAR_FX)); else set_optimize_op(expr, ((is_safe_closure(func)) ? OP_SAFE_CLOSURE_STAR_FX : OP_CLOSURE_STAR_FX)); } @@ -71901,7 +71688,7 @@ static opt_t optimize_c_function_one_arg(s7_scheme *sc, s7_pointer expr, s7_poin arg1 = cadr(expr); func_is_safe = is_safe_procedure(func); - if ((hop == 0) && (symbol_id(car(expr)) == 0)) hop = 1; + if ((hop == 0) && (symbol_id(car(expr)) == 0) && (!sc->in_with_let)) hop = 1; if (pairs == 0) { @@ -72127,114 +71914,158 @@ static bool check_tc_cond(s7_scheme *sc, s7_pointer name, int32_t vars, s7_point s7_pointer p, clause1; p = cdr(body); clause1 = car(p); - if ((is_proper_list_2(sc, clause1)) && - (is_fxable(sc, car(clause1)))) + if ((is_proper_list_2(sc, clause1)) && (is_fxable(sc, car(clause1)))) /* cond_a... */ { s7_pointer clause2; p = cdr(p); - clause2 = car(p); - if ((is_proper_list_2(sc, clause2)) && - (is_fxable(sc, car(clause2)))) - { - s7_pointer else_clause, else_p; - else_p = cdr(p); - else_clause = car(else_p); - - if ((is_proper_list_2(sc, else_clause)) && - ((car(else_clause) == sc->else_symbol) || (car(else_clause) == sc->T))) - { - bool zs_fxable = true; - if ((vars == 2) && /* ...laa_laa case */ - (is_proper_list_3(sc, cadr(clause2))) && (caadr(clause2) == name) && - (is_fxable(sc, cadadr(clause2))) && (is_safe_fxable(sc, caddadr(clause2))) && - (is_proper_list_3(sc, cadr(else_clause))) && (caadr(else_clause) == name) && - (is_fxable(sc, cadadr(else_clause))) && (is_safe_fxable(sc, caddadr(else_clause)))) + if ((is_pair(p)) && (is_null(cdr(p))) && ((caar(p) == sc->else_symbol) || (caar(p) == sc->T))) + { + s7_pointer else_clause; + if (((vars != 1) && (vars != 2)) || (tree_count(sc, name, body, 0) != 1)) return(false); + else_clause = cdar(p); + if (is_proper_list_1(sc, else_clause)) + { + bool zs_fxable; + s7_pointer la; + la = car(else_clause); + fx_annotate_arg(sc, clause1, args); + if ((is_pair(la)) && (car(la) == name) && (is_pair(cdr(la)))) { - set_optimize_op(body, OP_TC_COND_A_Z_A_LAA_LAA); - if (is_fxable(sc, cadr(clause1))) - fx_annotate_args(sc, clause1, args); - else + if ((is_fxable(sc, cadr(la))) && + ((((vars == 1) && (is_null(cddr(la)))) || + ((vars == 2) && (is_pair(cddr(la))) && (is_null(cdddr(la))) && (is_fxable(sc, caddr(la))))))) { - fx_annotate_arg(sc, clause1, args); - zs_fxable = false; - } - fx_annotate_arg(sc, clause2, args); - fx_annotate_args(sc, cdadr(clause2), args); - fx_annotate_args(sc, cdadr(else_clause), args); - fx_tree(sc, cdr(body), car(args), cadr(args)); - if (zs_fxable) set_optimized(body); - return(zs_fxable); - } + zs_fxable = is_fxable(sc, cadr(clause1)); + set_optimize_op(body, (vars == 1) ? OP_TC_COND_A_Z_LA : OP_TC_COND_A_Z_LAA); + if (zs_fxable) fx_annotate_arg(sc, cdr(clause1), args); + fx_annotate_args(sc, cdr(la), args); + fx_tree(sc, cdr(body), car(args), (vars == 1) ? NULL : cadr(args)); + if (zs_fxable) set_optimized(body); + return(zs_fxable); + }} + else + { + la = cadr(clause1); + if ((is_pair(la)) && (car(la) == name) && (is_pair(cdr(la)))) + { + if ((is_fxable(sc, cadr(la))) && + (((vars == 1) && (is_null(cddr(la)))) || + ((vars == 2) && (is_pair(cddr(la))) && (is_null(cdddr(la))) && (is_fxable(sc, caddr(la)))))) + { + zs_fxable = is_fxable(sc, car(else_clause)); + set_optimize_op(body, (vars == 1) ? OP_TC_COND_A_LA_Z : OP_TC_COND_A_LAA_Z); + if (zs_fxable) fx_annotate_arg(sc, else_clause, args); + fx_annotate_args(sc, cdr(la), args); + fx_tree(sc, cdr(body), car(args), (vars == 1) ? NULL : cadr(args)); + if (zs_fxable) set_optimized(body); + return(zs_fxable); + }}}} + return(false); + } + if (is_proper_list_2(sc, p)) + { + clause2 = car(p); + if ((is_proper_list_2(sc, clause2)) && + (is_fxable(sc, car(clause2)))) + { + s7_pointer else_clause, else_p; + else_p = cdr(p); + else_clause = car(else_p); - if ((tree_count(sc, name, body, 0) == 1) && /* needed to filter out cond_a_a_a_laa_opa_laa */ - - (((is_pair(cadr(else_clause))) && (caadr(else_clause) == name) && - (is_pair(cdadr(else_clause))) && (is_fxable(sc, cadadr(else_clause))) && - (((vars == 1) && (is_null(cddadr(else_clause)))) || - ((vars == 2) && (is_proper_list_3(sc, cadr(else_clause))) && (is_fxable(sc, caddadr(else_clause)))))) || - - ((is_pair(cadr(clause2))) && (caadr(clause2) == name) && - (is_pair(cdadr(clause2))) && (is_fxable(sc, cadadr(clause2))) && - (((vars == 1) && (is_null(cddadr(clause2)))) || - ((vars == 2) && (is_pair(cddadr(clause2))) && (is_fxable(sc, caddadr(clause2))) && (is_null(cdddr(cadr(clause2))))))))) + if ((is_proper_list_2(sc, else_clause)) && + ((car(else_clause) == sc->else_symbol) || (car(else_clause) == sc->T))) { - s7_pointer test2, la_test; - test2 = clause2; - la_test = else_clause; - if (vars == 1) + bool zs_fxable = true; + if ((vars == 2) && /* ...laa_laa case */ + (is_proper_list_3(sc, cadr(clause2))) && (caadr(clause2) == name) && + (is_fxable(sc, cadadr(clause2))) && (is_safe_fxable(sc, caddadr(clause2))) && + (is_proper_list_3(sc, cadr(else_clause))) && (caadr(else_clause) == name) && + (is_fxable(sc, cadadr(else_clause))) && (is_safe_fxable(sc, caddadr(else_clause)))) { - if ((is_pair(cadr(else_clause))) && (caadr(else_clause) == name)) - set_optimize_op(body, OP_TC_COND_A_Z_A_Z_LA); + set_optimize_op(body, OP_TC_COND_A_Z_A_LAA_LAA); + if (is_fxable(sc, cadr(clause1))) + fx_annotate_args(sc, clause1, args); else { - set_optimize_op(body, OP_TC_COND_A_Z_A_LA_Z); - test2 = else_clause; - la_test = clause2; - fx_annotate_arg(sc, clause2, args); - }} - else + fx_annotate_arg(sc, clause1, args); + zs_fxable = false; + } + fx_annotate_arg(sc, clause2, args); + fx_annotate_args(sc, cdadr(clause2), args); + fx_annotate_args(sc, cdadr(else_clause), args); + fx_tree(sc, cdr(body), car(args), cadr(args)); + if (zs_fxable) set_optimized(body); + return(zs_fxable); + } + + if ((tree_count(sc, name, body, 0) == 1) && /* needed to filter out cond_a_a_a_laa_opa_laa */ + + (((is_pair(cadr(else_clause))) && (caadr(else_clause) == name) && + (is_pair(cdadr(else_clause))) && (is_fxable(sc, cadadr(else_clause))) && + (((vars == 1) && (is_null(cddadr(else_clause)))) || + ((vars == 2) && (is_proper_list_3(sc, cadr(else_clause))) && (is_fxable(sc, caddadr(else_clause)))))) || + + ((is_pair(cadr(clause2))) && (caadr(clause2) == name) && + (is_pair(cdadr(clause2))) && (is_fxable(sc, cadadr(clause2))) && + (((vars == 1) && (is_null(cddadr(clause2)))) || + ((vars == 2) && (is_pair(cddadr(clause2))) && (is_fxable(sc, caddadr(clause2))) && (is_null(cdddr(cadr(clause2))))))))) { - if ((is_pair(cadr(else_clause))) && (caadr(else_clause) == name)) + s7_pointer test2, la_test; + test2 = clause2; + la_test = else_clause; + if (vars == 1) { - set_opt3_pair(body, cdadr(else_clause)); - set_optimize_op(body, OP_TC_COND_A_Z_A_Z_LAA); + if ((is_pair(cadr(else_clause))) && (caadr(else_clause) == name)) + set_optimize_op(body, OP_TC_COND_A_Z_A_Z_LA); + else + { + set_optimize_op(body, OP_TC_COND_A_Z_A_LA_Z); + test2 = else_clause; + la_test = clause2; + fx_annotate_arg(sc, clause2, args); + }} + else + { + if ((is_pair(cadr(else_clause))) && (caadr(else_clause) == name)) + { + set_opt3_pair(body, cdadr(else_clause)); + set_optimize_op(body, OP_TC_COND_A_Z_A_Z_LAA); + } + else + { + set_optimize_op(body, OP_TC_COND_A_Z_A_LAA_Z); + test2 = else_clause; + la_test = clause2; + fx_annotate_arg(sc, clause2, args); + }} + if (is_fxable(sc, cadr(clause1))) + fx_annotate_args(sc, clause1, args); + else + { + fx_annotate_arg(sc, clause1, args); + zs_fxable = false; } + if (is_fxable(sc, cadr(test2))) + fx_annotate_args(sc, test2, args); else { - set_optimize_op(body, OP_TC_COND_A_Z_A_LAA_Z); - test2 = else_clause; - la_test = clause2; - fx_annotate_arg(sc, clause2, args); - }} - if (is_fxable(sc, cadr(clause1))) - fx_annotate_args(sc, clause1, args); - else - { - fx_annotate_arg(sc, clause1, args); - zs_fxable = false; - } - if (is_fxable(sc, cadr(test2))) - fx_annotate_args(sc, test2, args); - else - { - fx_annotate_arg(sc, test2, args); - zs_fxable = false; - } - fx_annotate_args(sc, cdadr(la_test), args); - fx_tree(sc, cdr(body), car(args), (vars == 2) ? cadr(args) : NULL); - if (zs_fxable) set_optimized(body); - return(zs_fxable); - }}}} + fx_annotate_arg(sc, test2, args); + zs_fxable = false; + } + fx_annotate_args(sc, cdadr(la_test), args); + fx_tree(sc, cdr(body), car(args), (vars == 2) ? cadr(args) : NULL); + if (zs_fxable) set_optimized(body); + return(zs_fxable); + }}}}} return(false); } static bool check_tc_let(s7_scheme *sc, s7_pointer name, int32_t vars, s7_pointer args, s7_pointer body) { s7_pointer let_body; - /* fprintf(stderr, "%s[%d]: %s %d %s %s\n", __func__, __LINE__, display(name), vars, display(args), display(body)); */ - let_body = caddr(body); - if ((vars == 2) && - ((car(let_body) == sc->if_symbol) || (car(let_body) == sc->when_symbol) || (car(let_body) == sc->unless_symbol))) + let_body = caddr(body); /* body: (let ((x (- y 1))) (if (<= x 0) 0 (f1 (- x 1)))) etc */ + if (((vars == 2) && ((car(let_body) == sc->if_symbol) || (car(let_body) == sc->when_symbol) || (car(let_body) == sc->unless_symbol))) || + ((vars == 1) && (car(let_body) == sc->if_symbol))) { s7_pointer test_expr; test_expr = cadr(let_body); @@ -72244,22 +72075,24 @@ static bool check_tc_let(s7_scheme *sc, s7_pointer name, int32_t vars, s7_pointe { s7_pointer laa; laa = cadddr(let_body); - if ((car(laa) == name) && - (is_proper_list_3(sc, laa)) && - (is_fxable(sc, cadr(laa))) && - (is_safe_fxable(sc, caddr(laa)))) + if ((is_pair(laa)) && /* else caddr is laa and cadddr is z */ + (car(laa) == name) && + (((vars == 1) && (is_proper_list_2(sc, laa))) || + ((vars == 2) && (is_proper_list_3(sc, laa)) && (is_safe_fxable(sc, caddr(laa))))) && + (is_fxable(sc, cadr(laa)))) { - set_optimize_op(body, OP_TC_LET_IF_A_Z_LAA); - fx_annotate_arg(sc, cdaadr(body), args); + bool z_fxable; + set_optimize_op(body, (vars == 1) ? OP_TC_LET_IF_A_Z_LA : OP_TC_LET_IF_A_Z_LAA); + fx_annotate_arg(sc, cdaadr(body), args); /* let var binding, caadr: (x (- y 1)) etc */ fx_annotate_arg(sc, cdr(let_body), args); /* test_expr */ fx_annotate_args(sc, cdr(laa), args); - if (!is_fxable(sc, caddr(let_body))) return(false); - fx_annotate_arg(sc, cddr(let_body), args); - fx_tree(sc, cdaadr(body), car(args), cadr(args)); /* these are references to the outer let */ + z_fxable = is_fxable(sc, caddr(let_body)); + if (z_fxable) fx_annotate_arg(sc, cddr(let_body), args); + fx_tree(sc, cdaadr(body), car(args), (vars == 1) ? NULL : cadr(args)); /* these are references to laa args, applied to the let var binding */ fx_tree(sc, cdr(let_body), car(caadr(body)), NULL); - fx_tree_outer(sc, cdr(let_body), car(args), cadr(args)); - set_optimized(body); - return(true); + fx_tree_outer(sc, cdr(let_body), car(args), (vars == 1) ? NULL : cadr(args)); + if (z_fxable) set_optimized(body); + return(z_fxable); }} else { @@ -72367,7 +72200,6 @@ static bool check_tc_let(s7_scheme *sc, s7_pointer name, int32_t vars, s7_pointe static bool check_tc(s7_scheme *sc, s7_pointer name, int32_t vars, s7_pointer args, s7_pointer body) { if (!is_pair(body)) return(false); - /* fprintf(stderr, "%s[%d]: %s %d %s %s\n", __func__, __LINE__, display(name), vars, display(args), display(body)); */ if (((vars == 1) || (vars == 2)) && ((car(body) == sc->and_symbol) || (car(body) == sc->or_symbol)) && @@ -72709,7 +72541,6 @@ static bool check_tc(s7_scheme *sc, s7_pointer name, int32_t vars, s7_pointer ar /* cond */ if ((car(body) == sc->cond_symbol) && - (is_proper_list_4(sc, body)) && (vars <= 2)) return(check_tc_cond(sc, name, vars, args, body)); @@ -72952,12 +72783,41 @@ static bool check_recur_if(s7_scheme *sc, s7_pointer name, int32_t vars, s7_poin static bool check_recur(s7_scheme *sc, s7_pointer name, int32_t vars, s7_pointer args, s7_pointer body) { - /* fprintf(stderr, "%s[%d]: %s %d %s %s\n", __func__, __LINE__, display(name), vars, display(args), display(body)); */ - if ((car(body) == sc->if_symbol) && (safe_list_length(body) == 4)) return(check_recur_if(sc, name, vars, args, body)); + if ((car(body) == sc->and_symbol) && + (vars == 2) && + (safe_list_length(body) == 3) && + (safe_list_length(caddr(body)) == 4) && + (caaddr(body) == sc->or_symbol) && + (is_fxable(sc, cadr(body)))) + { + s7_pointer or_p, la1, la2; + or_p = caddr(body); + la1 = caddr(or_p); + la2 = cadddr(or_p); + if ((is_fxable(sc, cadr(or_p))) && + (safe_list_length(la1) == 3) && + (safe_list_length(la2) == 3) && + (car(la1) == name) && + (car(la2) == name) && + (is_fxable(sc, cadr(la1))) && + (is_fxable(sc, caddr(la1))) && + (is_fxable(sc, cadr(la2))) && + (is_fxable(sc, caddr(la2)))) + { + set_safe_optimize_op(body, OP_RECUR_AND_A_OR_A_LAA_LAA); + fx_annotate_args(sc, cdr(la1), args); + fx_annotate_args(sc, cdr(la2), args); + fx_annotate_arg(sc, cdr(body), args); + fx_annotate_arg(sc, cdr(or_p), args); + fx_tree(sc, cdr(body), car(args), cadr(args)); + set_opt3_pair(body, or_p); + return(true); + }} + if (car(body) == sc->cond_symbol) { s7_pointer clause, clause2 = NULL; @@ -73139,7 +72999,7 @@ static opt_t fxify_closure_s(s7_scheme *sc, s7_pointer func, s7_pointer expr, s7 { s7_pointer body_arg2; body_arg2 = caddar(body); - set_opt3_any(cdr(expr), (is_pair(body_arg2)) ? cadr(body_arg2) : body_arg2); + set_opt3_con(cdr(expr), (is_pair(body_arg2)) ? cadr(body_arg2) : body_arg2); set_safe_optimize_op(expr, hop + OP_SAFE_CLOSURE_S_TO_SC); if ((caar(body) == sc->vector_ref_symbol) && (is_global(sc->vector_ref_symbol))) set_c_call_direct(cdr(expr), (s7_pointer)fx_safe_closure_s_to_vref); @@ -73176,7 +73036,7 @@ static bool fxify_closure_a(s7_scheme *sc, s7_pointer func, bool one_form, bool { s7_pointer body_arg2; body_arg2 = caddar(body); - set_opt3_any(cdr(expr), (is_pair(body_arg2)) ? cadr(body_arg2) : body_arg2); + set_opt3_con(cdr(expr), (is_pair(body_arg2)) ? cadr(body_arg2) : body_arg2); set_safe_optimize_op(expr, hop + OP_SAFE_CLOSURE_A_TO_SC); if ((caar(body) == sc->vector_ref_symbol) && (is_global(sc->vector_ref_symbol))) set_c_call_direct(expr, (s7_pointer)fx_safe_closure_a_to_vref); @@ -73273,6 +73133,7 @@ static opt_t optimize_func_one_arg(s7_scheme *sc, s7_pointer expr, s7_pointer fu if (direct_memq(sc->quote_symbol, e)) return(OPT_OOPS); if ((bad_pairs == quotes) && + (is_symbol(car(expr))) && (is_constant_symbol(sc, car(expr)))) hop = 1; } @@ -73286,7 +73147,7 @@ static opt_t optimize_func_one_arg(s7_scheme *sc, s7_pointer expr, s7_pointer fu if (s7_is_aritable(sc, func, 1)) { set_c_call_direct(cdr(expr), fx_unsafe_s); - return(wrap_bad_args(sc, func, expr, 1, hop)); + return(wrap_bad_args(sc, func, expr, 1, hop, e)); } return(OPT_F); } @@ -73333,7 +73194,7 @@ static opt_t optimize_func_one_arg(s7_scheme *sc, s7_pointer expr, s7_pointer fu (c_function_all_args(func) >= 1) && (!is_keyword(arg1))) /* the only arg should not be a keyword (needs error checks later) */ { - if ((hop == 0) && (symbol_id(car(expr)) == 0)) hop = 1; + if ((hop == 0) && (symbol_id(car(expr)) == 0) && (!sc->in_with_let)) hop = 1; set_safe_optimize_op(expr, hop + OP_SAFE_C_FUNCTION_STAR_A); fx_annotate_arg(sc, cdr(expr), e); set_opt3_arglen(expr, int_one); @@ -73395,7 +73256,7 @@ static opt_t set_any_closure_fp(s7_scheme *sc, s7_pointer func, s7_pointer expr, static bool two_args_ok(s7_scheme *sc, s7_pointer expr, s7_pointer e) { - if ((car(expr) == sc->member_symbol) || (car(expr) == sc->assoc_symbol)) return(true); + if ((is_symbol(car(expr))) && ((car(expr) == sc->member_symbol) || (car(expr) == sc->assoc_symbol))) return(true); return(unsafe_is_safe(sc, cadr(expr), e)); } @@ -73429,29 +73290,6 @@ static opt_t set_any_c_fp(s7_scheme *sc, s7_pointer func, s7_pointer expr, s7_po return(OPT_F); } -static bool safe_c_aa_to_ag_ga(s7_scheme *sc, s7_pointer arg, int hop) -{ - if (c_callee(cddr(arg)) == fx_s) {set_opt3_any(arg, caddr(arg)); set_safe_optimize_op(arg, hop + OP_SAFE_C_AS); return(true);} - if (c_callee(cdr(arg)) == fx_s) {set_opt3_any(arg, cadr(arg)); set_safe_optimize_op(arg, hop + OP_SAFE_C_SA); return(true);} - if (c_callee(cddr(arg)) == fx_c) {set_opt3_any(arg, caddr(arg)); set_safe_optimize_op(arg, hop + OP_SAFE_C_AC); return(true);} - if (c_callee(cdr(arg)) == fx_c) {set_opt3_any(arg, cadr(arg)); set_safe_optimize_op(arg, hop + OP_SAFE_C_CA); return(true);} - if (c_callee(cddr(arg)) == fx_q) {set_opt3_any(arg, cadaddr(arg)); set_safe_optimize_op(arg, hop + OP_SAFE_C_AC); return(true);} - if (c_callee(cdr(arg)) == fx_q) {set_opt3_any(arg, cadadr(arg)); set_safe_optimize_op(arg, hop + OP_SAFE_C_CA); return(true);} - return(false); -} - -static opt_t check_c_aa(s7_scheme *sc, s7_pointer expr, s7_pointer func, int32_t hop, s7_pointer e) -{ - fx_annotate_args(sc, cdr(expr), e); - if (!safe_c_aa_to_ag_ga(sc, expr, hop)) - { - set_optimize_op(expr, hop + OP_SAFE_C_AA); - set_opt3_arglen(expr, int_two); - } - choose_c_function(sc, expr, func, 2); - return(OPT_T); -} - static int32_t check_lambda(s7_scheme *sc, s7_pointer form, bool optl); static opt_t optimize_func_two_args(s7_scheme *sc, s7_pointer expr, s7_pointer func, int32_t hop, int32_t pairs, int32_t symbols, int32_t quotes, int32_t bad_pairs, s7_pointer e) @@ -73463,6 +73301,7 @@ static opt_t optimize_func_two_args(s7_scheme *sc, s7_pointer expr, s7_pointer f if (direct_memq(sc->quote_symbol, e)) return(OPT_OOPS); if ((bad_pairs == quotes) && + (is_symbol(car(expr))) && (is_constant_symbol(sc, car(expr)))) hop = 1; } @@ -73480,7 +73319,7 @@ static opt_t optimize_func_two_args(s7_scheme *sc, s7_pointer expr, s7_pointer f (s7_is_aritable(sc, func, 2))) { fx_annotate_args(sc, cdr(expr), e); - return(wrap_bad_args(sc, func, expr, 2, hop)); + return(wrap_bad_args(sc, func, expr, 2, hop, e)); } return(OPT_F); } @@ -73493,9 +73332,7 @@ static opt_t optimize_func_two_args(s7_scheme *sc, s7_pointer expr, s7_pointer f /* this is a mess */ bool func_is_safe; - if ((hop == 0) && (symbol_id(car(expr)) == 0)) - hop = 1; - + if ((hop == 0) && (symbol_id(car(expr)) == 0) && (!sc->in_with_let)) hop = 1; func_is_safe = is_safe_procedure(func); if (pairs == 0) { @@ -73529,6 +73366,7 @@ static opt_t optimize_func_two_args(s7_scheme *sc, s7_pointer expr, s7_pointer f choose_c_function(sc, expr, func, 2); return(OPT_T); } + set_unsafely_optimized(expr); if (symbols == 2) { @@ -73658,10 +73496,9 @@ static opt_t optimize_func_two_args(s7_scheme *sc, s7_pointer expr, s7_pointer f set_opt3_any(cdr(expr), arg1); } else - { - if (op == OP_SAFE_C_PC) - set_opt3_any(cdr(expr), arg2); - } + if (op == OP_SAFE_C_PC) + set_opt3_any(cdr(expr), arg2); + if ((!has_fx(cdr(expr))) && ((op_no_hop(expr) == OP_SAFE_C_PS) || (op_no_hop(expr) == OP_SAFE_C_PC))) gx_annotate_arg(sc, cdr(expr), e); if ((!has_fx(cdr(expr))) && ((op_no_hop(expr) == OP_SAFE_C_SP) || (op_no_hop(expr) == OP_SAFE_C_CP))) @@ -73671,24 +73508,23 @@ static opt_t optimize_func_two_args(s7_scheme *sc, s7_pointer expr, s7_pointer f return(OPT_T); } - if (symbols == 1) + if ((symbols == 1) && + (is_normal_symbol(arg1))) { - if (is_normal_symbol(arg1)) + if (is_safe_c_s(arg2)) { - if (is_safe_c_s(arg2)) - { - set_unsafe_optimize_op(expr, hop + OP_C_S_opSq); - set_opt1_sym(cdr(expr), cadr(arg2)); - choose_c_function(sc, expr, func, 2); - return(OPT_F); - } - if (optimize_op_match(arg2, OP_SAFE_C_D)) - { - set_unsafe_optimize_op(expr, hop + OP_C_S_opDq); - set_opt1_pair(cdr(expr), cdr(arg2)); - choose_c_function(sc, expr, func, 2); - return(OPT_F); - }}}} + set_unsafe_optimize_op(expr, hop + OP_C_S_opSq); + set_opt1_sym(cdr(expr), cadr(arg2)); + choose_c_function(sc, expr, func, 2); + return(OPT_F); + } + if (optimize_op_match(arg2, OP_SAFE_C_D)) + { + set_unsafe_optimize_op(expr, hop + OP_C_S_opDq); + set_opt1_pair(cdr(expr), cdr(arg2)); + choose_c_function(sc, expr, func, 2); + return(OPT_F); + }}} if ((bad_pairs == 1) && (quotes == 1)) { @@ -73817,7 +73653,7 @@ static opt_t optimize_func_two_args(s7_scheme *sc, s7_pointer expr, s7_pointer f if (!is_proper_list_1(sc, cdr(arg2))) return(OPT_OOPS); set_safe_optimize_op(expr, hop + OP_SAFE_C_opSq_C); - set_opt1_con(cdr(expr), cadr(arg1)); + set_opt1_sym(cdr(expr), cadr(arg1)); set_opt2_con(cdr(expr), cadr(arg2)); choose_c_function(sc, expr, func, 2); return(OPT_T); @@ -73944,7 +73780,8 @@ static opt_t optimize_func_two_args(s7_scheme *sc, s7_pointer expr, s7_pointer f return(OPT_F); } - if ((car(expr) != sc->values_symbol) && + if ((is_symbol(car(expr))) && + (car(expr) != sc->values_symbol) && (is_fxable(sc, arg2))) { if ((is_pair(arg1)) && @@ -74139,7 +73976,7 @@ static opt_t optimize_func_two_args(s7_scheme *sc, s7_pointer expr, s7_pointer f else { if ((lambda_has_simple_defaults(func)) && (arity == 2)) - set_optimize_op(expr, hop + ((is_safe_closure(func)) ? ((is_null(cdr(closure_body(func)))) ? OP_SAFE_CLOSURE_STAR_AA_O : + set_optimize_op(expr, hop + ((is_safe_closure(func)) ? ((is_null(cdr(closure_body(func)))) ? OP_SAFE_CLOSURE_STAR_AA_O : OP_SAFE_CLOSURE_STAR_AA) : OP_CLOSURE_STAR_FX)); else set_optimize_op(expr, hop + ((is_safe_closure(func)) ? OP_SAFE_CLOSURE_STAR_FX_2 : OP_CLOSURE_STAR_FX)); } @@ -74154,7 +73991,7 @@ static opt_t optimize_func_two_args(s7_scheme *sc, s7_pointer expr, s7_pointer f (c_function_all_args(func) >= 1) && (!is_keyword(arg2))) { - if ((hop == 0) && (symbol_id(car(expr)) == 0)) hop = 1; + if ((hop == 0) && (symbol_id(car(expr)) == 0) && (!sc->in_with_let)) hop = 1; set_optimized(expr); set_optimize_op(expr, hop + OP_SAFE_C_FUNCTION_STAR_AA); /* k+c? = cc */ fx_annotate_args(sc, cdr(expr), e); @@ -74175,12 +74012,166 @@ static opt_t optimize_func_two_args(s7_scheme *sc, s7_pointer expr, s7_pointer f return((is_optimized(expr)) ? OPT_T : OPT_F); } +static opt_t optimize_safe_c_func_three_args(s7_scheme *sc, s7_pointer expr, s7_pointer func, int32_t hop, int32_t pairs, int32_t symbols, int32_t quotes, s7_pointer e) +{ + s7_pointer arg1, arg2, arg3; + arg1 = cadr(expr); + arg2 = caddr(expr); + arg3 = cadddr(expr); + if (pairs == 0) + { + set_optimized(expr); + if (symbols == 0) + set_optimize_op(expr, hop + OP_SAFE_C_D); + else + { + if (symbols == 3) + { + set_optimize_op(expr, hop + OP_SAFE_C_SSS); + set_opt1_sym(cdr(expr), arg2); + set_opt2_sym(cdr(expr), arg3); + } + else + { + if (symbols == 2) + { + if (!is_normal_symbol(arg1)) + { + set_optimize_op(expr, hop + OP_SAFE_C_CSS); + set_opt1_sym(cdr(expr), arg2); + set_opt2_sym(cdr(expr), arg3); + } + else + { + if (!is_normal_symbol(arg3)) + { + set_opt2_con(cdr(expr), arg3); + set_opt1_sym(cdr(expr), arg2); + set_optimize_op(expr, hop + OP_SAFE_C_SSC); + } + else + { + set_opt1_con(cdr(expr), arg2); + set_opt2_sym(cdr(expr), arg3); + set_optimize_op(expr, hop + OP_SAFE_C_SCS); + }}} + else + { + if (is_normal_symbol(arg1)) + { + set_opt1_con(cdr(expr), arg2); + set_opt2_con(cdr(expr), arg3); + set_optimize_op(expr, hop + OP_SAFE_C_SCC); + } + else + { + if (is_normal_symbol(arg2)) + { + set_opt1_sym(cdr(expr), arg2); + set_opt2_con(cdr(expr), arg3); + set_opt3_con(cdr(expr), arg1); + set_optimize_op(expr, hop + OP_SAFE_C_CSC); + } + else + { + set_opt1_sym(cdr(expr), arg3); + set_opt2_con(cdr(expr), arg2); + set_opt3_con(cdr(expr), arg1); + set_optimize_op(expr, hop + OP_SAFE_C_CCS); + }}}}} + choose_c_function(sc, expr, func, 3); + return(OPT_T); + } + + /* pairs != 0 */ + if (fx_count(sc, expr) == 3) + { + set_optimized(expr); + if (quotes == 1) + { + if ((symbols == 2) && + (is_normal_symbol(arg1)) && + (is_normal_symbol(arg3))) + { + set_opt1_con(cdr(expr), cadr(arg2)); /* fx_c_scs uses opt1_con */ + set_opt2_sym(cdr(expr), arg3); + set_optimize_op(expr, hop + OP_SAFE_C_SCS); /* used to be SQS */ + choose_c_function(sc, expr, func, 3); + return(OPT_T); + } + if (symbols == 1) + { + if ((is_normal_symbol(arg3)) && + (is_proper_quote(sc, arg2)) && + (is_safe_c_s(arg1))) + { + set_safe_optimize_op(expr, hop + OP_SAFE_C_opSq_CS); + set_opt1_con(cdr(expr), cadr(arg2)); /* opt1_con is T_Pos (unchecked) */ + set_opt2_sym(cdr(expr), arg3); + set_opt3_sym(cdr(expr), cadr(arg1)); + choose_c_function(sc, expr, func, 3); + return(OPT_T); + } + if ((is_normal_symbol(arg2)) && + (is_proper_quote(sc, arg1)) && + (!is_pair(arg3))) + { + set_optimize_op(expr, hop + OP_SAFE_C_CSC); + set_opt1_sym(cdr(expr), arg2); + set_opt2_con(cdr(expr), arg3); + set_opt3_con(cdr(expr), cadr(arg1)); + choose_c_function(sc, expr, func, 3); + return(OPT_T); + }}} + fx_annotate_args(sc, cdr(expr), e); + set_opt3_arglen(expr, int_three); + set_opt3_pair(cdr(expr), cdddr(expr)); + set_optimize_op(expr, hop + OP_SAFE_C_AAA); + + if (pairs == 1) + { + if ((symbols == 0) && (is_pair(arg2))) + set_optimize_op(expr, hop + OP_SAFE_C_CAC); + else + { + if ((symbols == 1) && (is_pair(arg3))) + set_optimize_op(expr, hop + ((is_normal_symbol(arg2)) ? OP_SAFE_C_CSA : OP_SAFE_C_SCA)); + else + { + if (symbols == 2) + { + if (is_normal_symbol(arg1)) + { + if (is_normal_symbol(arg2)) + { + if ((hop == 1) && (s7_p_ppp_function(func))) + { + set_optimize_op(expr, HOP_SSA_DIRECT); + set_opt2_direct(cdr(expr), (s7_pointer)(s7_p_ppp_function(func))); + } + else set_optimize_op(expr, hop + OP_SAFE_C_SSA); + } + else set_optimize_op(expr, hop + OP_SAFE_C_SAS); + } + else + if (is_pair(arg1)) + set_optimize_op(expr, hop + OP_SAFE_C_ASS); + }}}} + else + if ((is_normal_symbol(arg1)) && (pairs == 2)) + set_optimize_op(expr, hop + OP_SAFE_C_SAA); + + choose_c_function(sc, expr, func, 3); + return(OPT_T); + } + return(OPT_F); /* tell caller to try something else */ +} + static opt_t optimize_func_three_args(s7_scheme *sc, s7_pointer expr, s7_pointer func, int32_t hop, int32_t pairs, int32_t symbols, int32_t quotes, int32_t bad_pairs, s7_pointer e) { s7_pointer arg1, arg2, arg3; - /* fprintf(stderr, "%s[%d]: %s %d\n", __func__, __LINE__, display_80(expr), hop); */ if ((quotes > 0) && (direct_memq(sc->quote_symbol, e))) return(OPT_OOPS); @@ -74237,6 +74228,7 @@ static opt_t optimize_func_three_args(s7_scheme *sc, s7_pointer expr, s7_pointer } /* end of bad symbol wrappers */ if ((bad_pairs == quotes) && + (is_symbol(car(expr))) && (is_constant_symbol(sc, car(expr)))) hop = 1; @@ -74244,160 +74236,12 @@ static opt_t optimize_func_three_args(s7_scheme *sc, s7_pointer expr, s7_pointer (c_function_required_args(func) <= 3) && (c_function_all_args(func) >= 3)) { - if ((hop == 0) && (symbol_id(car(expr)) == 0)) - hop = 1; - + if ((hop == 0) && (symbol_id(car(expr)) == 0) && (!sc->in_with_let)) hop = 1; if ((is_safe_procedure(func)) || ((is_maybe_safe(func)) && (unsafe_is_safe(sc, arg3, e)))) { - if (pairs == 0) - { - set_optimized(expr); - if (symbols == 0) - set_optimize_op(expr, hop + OP_SAFE_C_D); - else - { - if (symbols == 3) - { - set_optimize_op(expr, hop + OP_SAFE_C_SSS); - set_opt1_sym(cdr(expr), arg2); - set_opt2_sym(cdr(expr), arg3); - } - else - { - if (symbols == 2) - { - if (!is_normal_symbol(arg1)) - { - set_optimize_op(expr, hop + OP_SAFE_C_CSS); - set_opt1_sym(cdr(expr), arg2); - set_opt2_sym(cdr(expr), arg3); - } - else - { - if (!is_normal_symbol(arg3)) - { - set_opt2_con(cdr(expr), arg3); - set_opt1_sym(cdr(expr), arg2); - set_optimize_op(expr, hop + OP_SAFE_C_SSC); - } - else - { - set_opt1_con(cdr(expr), arg2); - set_opt2_sym(cdr(expr), arg3); - set_optimize_op(expr, hop + OP_SAFE_C_SCS); - }}} - else - { - if (is_normal_symbol(arg1)) - { - set_opt1_con(cdr(expr), arg2); - set_opt2_con(cdr(expr), arg3); - set_optimize_op(expr, hop + OP_SAFE_C_SCC); - } - else - { - if (is_normal_symbol(arg2)) - { - set_opt1_sym(cdr(expr), arg2); - set_opt2_con(cdr(expr), arg3); - set_opt3_any(cdr(expr), arg1); - set_optimize_op(expr, hop + OP_SAFE_C_CSC); - } - else - { - set_opt1_sym(cdr(expr), arg3); - set_opt2_con(cdr(expr), arg2); - set_opt3_any(cdr(expr), arg1); - set_optimize_op(expr, hop + OP_SAFE_C_CCS); - }}}}} - choose_c_function(sc, expr, func, 3); - return(OPT_T); - } - - /* pairs != 0 */ - if (fx_count(sc, expr) == 3) - { - set_optimized(expr); - if (quotes == 1) - { - if ((symbols == 2) && - (is_normal_symbol(arg1)) && - (is_normal_symbol(arg3))) - { - set_opt1_con(cdr(expr), cadr(arg2)); /* fx_c_scs uses opt1_con */ - set_opt2_sym(cdr(expr), arg3); - set_optimize_op(expr, hop + OP_SAFE_C_SCS); /* used to be SQS */ - choose_c_function(sc, expr, func, 3); - return(OPT_T); - } - if (symbols == 1) - { - if ((is_normal_symbol(arg3)) && - (is_proper_quote(sc, arg2)) && - (is_safe_c_s(arg1))) - { - set_safe_optimize_op(expr, hop + OP_SAFE_C_opSq_CS); - set_opt1_con(cdr(expr), cadr(arg2)); /* opt1_con is T_Pos (unchecked) */ - set_opt2_sym(cdr(expr), arg3); - set_opt3_sym(cdr(expr), cadr(arg1)); - choose_c_function(sc, expr, func, 3); - return(OPT_T); - } - if ((is_normal_symbol(arg2)) && - (is_proper_quote(sc, arg1)) && - (!is_pair(arg3))) - { - set_optimize_op(expr, hop + OP_SAFE_C_CSC); - set_opt1_sym(cdr(expr), arg2); - set_opt2_con(cdr(expr), arg3); - set_opt3_any(cdr(expr), cadr(arg1)); - choose_c_function(sc, expr, func, 3); - return(OPT_T); - }}} - fx_annotate_args(sc, cdr(expr), e); - set_opt3_arglen(expr, int_three); - set_opt3_pair(cdr(expr), cdddr(expr)); - set_optimize_op(expr, hop + OP_SAFE_C_AAA); - - if (pairs == 1) - { - if ((symbols == 0) && (is_pair(arg2))) - set_optimize_op(expr, hop + OP_SAFE_C_CAC); - else - { - if ((symbols == 1) && (is_pair(arg3))) - set_optimize_op(expr, hop + ((is_normal_symbol(arg2)) ? OP_SAFE_C_CSA : OP_SAFE_C_SCA)); - else - { - if (symbols == 2) - { - if (is_normal_symbol(arg1)) - { - if (is_normal_symbol(arg2)) - { - if ((hop == 1) && (s7_p_ppp_function(func))) - { - set_optimize_op(expr, HOP_SSA_DIRECT); - set_opt2_direct(cdr(expr), (s7_pointer)(s7_p_ppp_function(func))); - } - else set_optimize_op(expr, hop + OP_SAFE_C_SSA); - } - else set_optimize_op(expr, hop + OP_SAFE_C_SAS); - } - else - { - if (is_pair(arg1)) - set_optimize_op(expr, hop + OP_SAFE_C_ASS); - }}}}} - else - { - if ((is_normal_symbol(arg1)) && (pairs == 2)) - set_optimize_op(expr, hop + OP_SAFE_C_SAA); - } - choose_c_function(sc, expr, func, 3); - return(OPT_T); - } + if (optimize_safe_c_func_three_args(sc, expr, func, hop, pairs, symbols, quotes, e) == OPT_T) + return(OPT_T); if ((is_normal_symbol(arg1)) && (is_normal_symbol(arg2))) { set_opt3_pair(expr, arg3); @@ -74613,13 +74457,12 @@ static bool symbols_are_safe(s7_scheme *sc, s7_pointer args, s7_pointer e) static opt_t optimize_func_many_args(s7_scheme *sc, s7_pointer expr, s7_pointer func, int32_t hop, int32_t args, int32_t pairs, int32_t symbols, int32_t quotes, int32_t bad_pairs, s7_pointer e) { bool func_is_closure; - /* fprintf(stderr, "%s[%d]: %s, args: %d, bad: %d, quotes: %d\n", __func__, __LINE__, display_80(expr), args, bad_pairs, quotes); */ - if (quotes > 0) { if (direct_memq(sc->quote_symbol, e)) return(OPT_OOPS); if ((bad_pairs == quotes) && + (is_symbol(car(expr))) && (is_constant_symbol(sc, car(expr)))) hop = 1; } @@ -74628,8 +74471,7 @@ static opt_t optimize_func_many_args(s7_scheme *sc, s7_pointer expr, s7_pointer (c_function_required_args(func) <= args) && (c_function_all_args(func) >= args)) { - if ((hop == 0) && (symbol_id(car(expr)) == 0)) hop = 1; - + if ((hop == 0) && (symbol_id(car(expr)) == 0) && (!sc->in_with_let)) hop = 1; if (is_safe_procedure(func)) { if (pairs == 0) @@ -74738,10 +74580,9 @@ static opt_t optimize_func_many_args(s7_scheme *sc, s7_pointer expr, s7_pointer if (args == 4) return(set_any_closure_fp(sc, func, expr, e, 4, hop + OP_ANY_CLOSURE_4P)); else - { - if (args < GC_TRIGGER_SIZE) - return(set_any_closure_fp(sc, func, expr, e, args, hop + OP_ANY_CLOSURE_FP)); - }} + if (args < GC_TRIGGER_SIZE) + return(set_any_closure_fp(sc, func, expr, e, args, hop + OP_ANY_CLOSURE_FP)); + } if ((is_closure_star(func)) && ((!lambda_has_simple_defaults(func)) || @@ -74849,10 +74690,9 @@ static opt_t optimize_syntax(s7_scheme *sc, s7_pointer expr, s7_pointer func, in if (is_null(vars)) e = cons(sc, sc->nil, e); else - { - if (!is_pair(vars)) - return(OPT_OOPS); - }} + if (!is_pair(vars)) + return(OPT_OOPS); + } if (!is_pair(body)) return(OPT_OOPS); if (!vars_syntax_ok(vars)) @@ -74903,11 +74743,10 @@ static opt_t optimize_syntax(s7_scheme *sc, s7_pointer expr, s7_pointer func, in if ((is_pair(var)) && (is_pair(cdr(var))) && (is_pair(cadr(var))) && - (!is_checked(cadr(var)))) - { - if (optimize_expression(sc, cadr(var), hop, e, false) == OPT_OOPS) - return(OPT_OOPS); - }} + (!is_checked(cadr(var))) && + (optimize_expression(sc, cadr(var), hop, e, false) == OPT_OOPS)) + return(OPT_OOPS); + } /* e = cons(sc, sc->nil, e); */ /* !? currently let-temporarily does not make a new let, so it is like begin? */ body_export_ok = export_ok; /* (list x (let-temporarily () (define x 0))) just as in begin */ break; @@ -74917,10 +74756,8 @@ static opt_t optimize_syntax(s7_scheme *sc, s7_pointer expr, s7_pointer func, in if (is_null(vars)) e = cons(sc, sc->nil, e); else - { - if (!is_pair(vars)) - return(OPT_OOPS); - } + if (!is_pair(vars)) + return(OPT_OOPS); body = cddr(expr); for (p = vars; is_pair(p); p = cdr(p)) @@ -75028,10 +74865,8 @@ static opt_t optimize_syntax(s7_scheme *sc, s7_pointer expr, s7_pointer func, in if (is_null(vars)) e = cons(sc, sc->nil, e); else - { - if ((!is_pair(vars)) && (!is_symbol(vars))) - return(OPT_OOPS); - } + if ((!is_pair(vars)) && (!is_symbol(vars))) + return(OPT_OOPS); e = collect_parameters(sc, vars, e); body = cddr(expr); break; @@ -75064,16 +74899,13 @@ static opt_t optimize_syntax(s7_scheme *sc, s7_pointer expr, s7_pointer func, in case OP_WITH_LET: /* we can't trust anything here, so hop ought to be off. For example, - * (define (hi) - * (let ((e (sublet (curlet) - * (cons :abs (lambda (a) (- a 1)))))) - * (with-let e (abs -1)))) - * returns 1 if hop is 1, but -2 otherwise + * (define (hi) (let ((e (sublet (curlet) :abs (lambda (a) (- a 1))))) (with-let e (abs -1)))) + * returns 1 if hop is 1, but -2 otherwise. (with-let (unlet)...) is safe however. */ { bool old_with_let; - old_with_let = sc->in_with_let; - sc->in_with_let = true; + old_with_let = sc->in_with_let; + sc->in_with_let = (old_with_let) || (!is_pair(body)) || (!is_pair(car(body))) || (caar(body) != sc->unlet_symbol); for (p = body; is_pair(p); p = cdr(p)) if ((is_pair(car(p))) && (!is_checked(car(p))) && @@ -75173,7 +75005,8 @@ static opt_t optimize_syntax(s7_scheme *sc, s7_pointer expr, s7_pointer func, in sc->temp9 = sc->nil; if ((hop == 1) && - (symbol_id(car(expr)) == 0)) + ((is_syntax(car(expr))) || + (symbol_id(car(expr)) == 0))) { if (op == OP_IF) { @@ -75344,9 +75177,63 @@ static opt_t optimize_syntax(s7_scheme *sc, s7_pointer expr, s7_pointer func, in return(OPT_F); } + +static opt_t optimize_funcs(s7_scheme *sc, s7_pointer expr, s7_pointer func, int32_t hop, int32_t orig_hop, s7_pointer e) +{ + int32_t pairs = 0, symbols = 0, args = 0, bad_pairs = 0, quotes = 0; + s7_pointer p; + for (p = cdr(expr); is_pair(p); p = cdr(p), args++) /* check the args (the calling expression) */ + { + s7_pointer car_p; + car_p = car(p); + if (is_normal_symbol(car_p)) /* for opt func */ + symbols++; + else + { + if (is_pair(car_p)) + { + pairs++; + if (!is_checked(car_p)) + { + opt_t res; + res = optimize_expression(sc, car_p, orig_hop, e, false); + if (res == OPT_F) + { + bad_pairs++; + if (is_proper_quote(sc, car_p)) + quotes++; + } + else + if (res == OPT_OOPS) + return(OPT_OOPS); + } + else + { + if ((!is_optimized(car_p)) || + (is_unsafe(car_p))) + { + bad_pairs++; + if (is_proper_quote(sc, car_p)) + quotes++; + }}}}} + if (is_null(p)) /* if not null, dotted list of args? */ + { + switch (args) + { + case 0: return(optimize_thunk(sc, expr, func, hop, e)); + case 1: return(optimize_func_one_arg(sc, expr, func, hop, pairs, symbols, quotes, bad_pairs, e)); + case 2: return(optimize_func_two_args(sc, expr, func, hop, pairs, symbols, quotes, bad_pairs, e)); + case 3: return(optimize_func_three_args(sc, expr, func, hop, pairs, symbols, quotes, bad_pairs, e)); + default: return(optimize_func_many_args(sc, expr, func, hop, args, pairs, symbols, quotes, bad_pairs, e)); + }} + return(OPT_F); +} + static opt_t optimize_expression(s7_scheme *sc, s7_pointer expr, int32_t hop, s7_pointer e, bool export_ok) { s7_pointer car_expr; + int32_t orig_hop; + orig_hop = hop; set_checked(expr); car_expr = car(expr); @@ -75360,7 +75247,6 @@ static opt_t optimize_expression(s7_scheme *sc, s7_pointer expr, int32_t hop, s7 return(OPT_OOPS); return(optimize_syntax(sc, expr, T_Syn(slot_value(global_slot(car_expr))), hop, e, export_ok)); } - slot = find_uncomplicated_symbol(sc, car_expr, e); /* local vars (recursive calls too??) are considered "complicated" */ if (is_slot(slot)) { @@ -75375,14 +75261,10 @@ static opt_t optimize_expression(s7_scheme *sc, s7_pointer expr, int32_t hop, s7 /* we miss implicit indexing here because at this time, the data are not set */ /* if ((is_any_closure(func)) && (!is_safe_procedure(func))) fprintf(stderr, "unsafe: %s %s\n", display(func), display_80(expr)); */ - if ((is_t_procedure(func)) || + if ((is_t_procedure(func)) || /* t_procedure_p: c_funcs, closures, etc */ (is_any_closure(func)) || /* added 11-Mar-20 */ (is_safe_procedure(func))) /* built-in applicable objects like vectors */ { - int32_t pairs = 0, symbols = 0, args = 0, bad_pairs = 0, quotes = 0, orig_hop; - s7_pointer p; - orig_hop = hop; - if ((hop != 0) && ((is_any_closure(func)) || /* see use-redef in s7test -- I'm not sure about this */ ((!is_global(car_expr)) && @@ -75405,7 +75287,7 @@ static opt_t optimize_expression(s7_scheme *sc, s7_pointer expr, int32_t hop, s7 * So, closures are always checked, but built-in functions are used as if never redefined until that redefinition. * Syntax handling is already impure in s7, so the special handling of built-in functions doesn't * offend me much. Consider each a sort of reader macro until someone redefines it -- previous - * uses may not be affected because they might have been optimized away -- the result depends on the + * uses might not be affected because they might have been optimized away -- the result depends on the * current optimizer. * Another case (from K Matheussen): * (define (call-func func arg1 arg2) (define (call) (func arg1 arg2)) (call)) (call-func + 1 2.5) (call-func - 5 2) @@ -75417,53 +75299,7 @@ static opt_t optimize_expression(s7_scheme *sc, s7_pointer expr, int32_t hop, s7 * This can be confused if lambda is redefined at some point, but... */ } - - for (p = cdr(expr); is_pair(p); p = cdr(p), args++) /* check the args (the calling expression) */ - { - s7_pointer car_p; - car_p = car(p); - if (is_normal_symbol(car_p)) /* for opt func */ - symbols++; - else - { - if (is_pair(car_p)) - { - pairs++; - if (!is_checked(car_p)) - { - opt_t res; - res = optimize_expression(sc, car_p, orig_hop, e, false); - if (res == OPT_F) - { - bad_pairs++; - if (is_proper_quote(sc, car_p)) - quotes++; - } - else - { - if (res == OPT_OOPS) - return(OPT_OOPS); - }} - else - { - if ((!is_optimized(car_p)) || - (is_unsafe(car_p))) - { - bad_pairs++; - if (is_proper_quote(sc, car_p)) - quotes++; - }}}}} - if (is_null(p)) /* if not null, dotted list of args? */ - { - switch (args) - { - case 0: return(optimize_thunk(sc, expr, func, hop, e)); - case 1: return(optimize_func_one_arg(sc, expr, func, hop, pairs, symbols, quotes, bad_pairs, e)); - case 2: return(optimize_func_two_args(sc, expr, func, hop, pairs, symbols, quotes, bad_pairs, e)); - case 3: return(optimize_func_three_args(sc, expr, func, hop, pairs, symbols, quotes, bad_pairs, e)); - default: return(optimize_func_many_args(sc, expr, func, hop, args, pairs, symbols, quotes, bad_pairs, e)); - }} - return(OPT_F); + return(optimize_funcs(sc, expr, func, hop, orig_hop, e)); }} else { @@ -75479,7 +75315,7 @@ static opt_t optimize_expression(s7_scheme *sc, s7_pointer expr, int32_t hop, s7 (port_filename(p))) s7_warn(sc, 1024, "%s might be undefined (%s %u)\n", display(car_expr), port_filename(p), port_line_number(p)); else s7_warn(sc, 1024, "; %s might be undefined\n", display(car_expr)); - symbol_set_tag(car_expr, 1); /* one warning is enough */ + symbol_set_tag(car_expr, 1); /* one warning is enough */ }} /* car_expr is a symbol but it's not a built-in procedure or a "safe" case = vector etc */ { @@ -75499,10 +75335,9 @@ static opt_t optimize_expression(s7_scheme *sc, s7_pointer expr, int32_t hop, s7 return(OPT_OOPS); } else - { - if (is_symbol(car_p)) + if (is_symbol(car_p)) symbols++; - }} + } if ((is_null(p)) && /* (+ 1 . 2) */ (!is_optimized(expr))) @@ -75612,6 +75447,19 @@ static opt_t optimize_expression(s7_scheme *sc, s7_pointer expr, int32_t hop, s7 /* (define (hi a) (case 1 ((1) (if (> a 2) a 2)))) */ s7_pointer p; + if (is_c_function(car_expr)) /* (#_abs x) etc */ + return(optimize_funcs(sc, expr, car_expr, 1, orig_hop, e)); + + if (is_syntax(car_expr)) /* (#_cond ...) */ + { + if (!is_pair(cdr(expr))) + return(OPT_OOPS); + return(optimize_syntax(sc, expr, car_expr, orig_hop, e, export_ok)); + } + if (is_any_macro(car_expr)) + return(OPT_F); + + /* if car is a pair, we can't easily tell whether its value is (say) + or cond, so we need to catch this case and fixup fx settings */ for (p = expr; is_pair(p); p = cdr(p)) if ((is_pair(car(p))) && (!is_checked(car(p))) && @@ -75621,13 +75469,11 @@ static opt_t optimize_expression(s7_scheme *sc, s7_pointer expr, int32_t hop, s7 if (((is_proper_list_1(sc, cdr(expr))) || (is_proper_list_2(sc, cdr(expr)))) && /* looking for ((if fx s s) fx [fx]) */ (is_pair(car_expr)) && (car(car_expr) == sc->if_symbol) && + (!direct_memq(sc->if_symbol, e)) && /* (define (func) (with-output-to-string (lambda* (if) ((if (> 3 2) + -) 3 2)))) ! */ (is_pair(cdr(car_expr))) && - (is_pair(cddr(car_expr))) && - (is_symbol(caddr(car_expr))) && - (is_pair(cdddr(car_expr))) && - (is_symbol(cadddr(car_expr))) && - (is_fxable(sc, cadr(car_expr))) && - (is_fxable(sc, cadr(expr))) && + (is_pair(cddr(car_expr))) && (is_symbol(caddr(car_expr))) && + (is_pair(cdddr(car_expr))) && (is_symbol(cadddr(car_expr))) && + (is_fxable(sc, cadr(car_expr))) && (is_fxable(sc, cadr(expr))) && ((is_null(cddr(expr))) || (is_fxable(sc, caddr(expr))))) { s7_pointer ptrue; @@ -75654,9 +75500,9 @@ static opt_t optimize_expression(s7_scheme *sc, s7_pointer expr, int32_t hop, s7 return(OPT_T); }}}}} /* here we get for example: - * ((if (not (let? p)) write write-to-vector) obj p) ; not "uncomplicated"?? [((if 3d fourth third) p) in index] - * ((if (symbol? (cadr f)) cadr (if (pair? (cadr f)) caadr not)) f) ; fx not symbol - * ((if (input-port? port) call-with-input-file call-with-output-file) port proc) ?? why is this not ok? + * ((if (not (let? p)) write write-to-vector) obj p) ; not uncomplicated/c-function [((if 3d fourth third) p) in index] + * ((if (symbol? (cadr f)) cadr (if (pair? (cadr f)) caadr not)) f) ; fx not symbol -- opif_a_aaq_a + * ((if (input-port? port) call-with-input-file call-with-output-file) port proc) ; not safe I guess */ } return(OPT_F); @@ -75665,7 +75511,6 @@ static opt_t optimize_expression(s7_scheme *sc, s7_pointer expr, int32_t hop, s7 static opt_t optimize(s7_scheme *sc, s7_pointer code, int32_t hop, s7_pointer e) { s7_pointer x; - /* fprintf(stderr, "%s[%d]: %d %s\n", __func__, __LINE__, hop, display_80(code)); */ for (x = code; (is_pair(x)) && (!is_checked(x)); x = cdr(x)) { s7_pointer obj; @@ -75673,16 +75518,15 @@ static opt_t optimize(s7_scheme *sc, s7_pointer code, int32_t hop, s7_pointer e) set_checked(x); if (is_pair(obj)) { - if (!is_checked(obj)) + if ((!is_checked(obj)) && + (optimize_expression(sc, obj, hop, e, true) == OPT_OOPS)) { - if (optimize_expression(sc, obj, hop, e, true) == OPT_OOPS) - { - s7_pointer p; - for (p = cdr(x); is_pair(p); p = cdr(p)); - if (!is_null(p)) - eval_error(sc, "stray dot in function body: ~S", 30, code); - return(OPT_OOPS); - }}} + s7_pointer p; + for (p = cdr(x); is_pair(p); p = cdr(p)); + if (!is_null(p)) + eval_error(sc, "stray dot in function body: ~S", 30, code); + return(OPT_OOPS); + }} else { /* new 22-Sep-19, but I don't think this saves anything over falling into trailers */ @@ -75831,10 +75675,8 @@ static s7_pointer check_lambda_star_args(s7_scheme *sc, s7_pointer args, s7_poin set_local(w); } else - { - if ((body) && (!has_defaults) && (is_pair(args))) - set_has_no_defaults(body); - } + if ((body) && (!has_defaults) && (is_pair(args))) + set_has_no_defaults(body); return(top); } @@ -75843,10 +75685,8 @@ static void set_rec_tc_args(s7_scheme *sc, s7_int args) if (sc->rec_tc_args == -1) sc->rec_tc_args = args; else - { - if (sc->rec_tc_args != args) - sc->rec_tc_args = -2; - } + if (sc->rec_tc_args != args) + sc->rec_tc_args = -2; } typedef enum {UNSAFE_BODY=0, RECUR_BODY, SAFE_BODY, VERY_SAFE_BODY} body_t; @@ -75857,6 +75697,7 @@ static body_t form_is_safe(s7_scheme *sc, s7_pointer func, s7_pointer x, bool at { s7_pointer expr; body_t result = VERY_SAFE_BODY; + #if S7_DEBUGGING if (!is_pair(x)) {fprintf(stderr, "form_is_safe x is not a pair! %s\n", display(x)); abort();} #endif @@ -76111,7 +75952,7 @@ static body_t form_is_safe(s7_scheme *sc, s7_pointer func, s7_pointer x, bool at */ return(UNSAFE_BODY); }} - else /* car(x) is not syntactic ?? */ + else /* car(x) is not syntactic */ { if (expr == func) /* try to catch tail call, expr is car(x) */ { @@ -76119,6 +75960,7 @@ static body_t form_is_safe(s7_scheme *sc, s7_pointer func, s7_pointer x, bool at s7_pointer sp, p; sc->got_rec = true; /* (walk (car tree)) lint and almost all others in s7test */ set_rec_tc_args(sc, safe_list_length(cdr(x))); + if (!at_end) {result = RECUR_BODY; sc->not_tc = true;} sp = x; for (p = cdr(x); is_pair(p); p = cdr(p)) { @@ -76126,8 +75968,7 @@ static body_t form_is_safe(s7_scheme *sc, s7_pointer func, s7_pointer x, bool at { if (caar(p) == func) /* func called as arg, so not tail call */ { - sc->got_rec = true; /* (ack (- m 1) (ack m (- n 1))) s7test -- this is redundant */ - set_rec_tc_args(sc, safe_list_length(cdar(p))); + sc->not_tc = true; result = RECUR_BODY; } result = min_body(result, form_is_safe(sc, func, car(p), false)); @@ -76135,14 +75976,13 @@ static body_t form_is_safe(s7_scheme *sc, s7_pointer func, s7_pointer x, bool at return(UNSAFE_BODY); } else - { - if (car(p) == func) /* func itself as arg */ - return(UNSAFE_BODY); - } + if (car(p) == func) /* func itself as arg */ + return(UNSAFE_BODY); + if (follow) {sp = cdr(sp); if (p == sp) return(UNSAFE_BODY);} follow = (!follow); } - if ((at_end) && (is_null(p))) /* tail call, so safe */ + if ((at_end) && (!sc->not_tc) && (is_null(p))) /* tail call, so safe */ { sc->got_tc = true; set_rec_tc_args(sc, safe_list_length(cdr(x))); @@ -76158,10 +75998,9 @@ static body_t form_is_safe(s7_scheme *sc, s7_pointer func, s7_pointer x, bool at bool c_safe; if (symbol_is_in_list(sc, expr)) - /* return((at_end) ? RECUR_BODY : UNSAFE_BODY); */ return(UNSAFE_BODY); - f_slot = symbol_to_slot(sc, expr); + f_slot = lookup_slot_from(expr, sc->curlet); if (!is_slot(f_slot)) return(UNSAFE_BODY); f = slot_value(f_slot); @@ -76178,6 +76017,7 @@ static body_t form_is_safe(s7_scheme *sc, s7_pointer func, s7_pointer x, bool at s7_pointer sp, p; p = cdr(x); sp = x; + for (; is_pair(p); p = cdr(p)) { if (is_unquoted_pair(car(p))) @@ -76212,10 +76052,9 @@ static body_t form_is_safe(s7_scheme *sc, s7_pointer func, s7_pointer x, bool at return(UNSAFE_BODY); } else - { - if (car(p) == func) /* the current function passed as an argument to something */ - return(UNSAFE_BODY); - } + if (car(p) == func) /* the current function passed as an argument to something */ + return(UNSAFE_BODY); + if (follow) {sp = cdr(sp); if (p == sp) return(UNSAFE_BODY);} follow = (!follow); } @@ -76248,7 +76087,7 @@ static body_t form_is_safe(s7_scheme *sc, s7_pointer func, s7_pointer x, bool at s7_pointer fn_slot; if (symbol_is_in_list(sc, fn)) return(UNSAFE_BODY); - fn_slot = symbol_to_slot(sc, fn); + fn_slot = lookup_slot_from(fn, sc->curlet); if (!is_slot(fn_slot)) return(UNSAFE_BODY); fn = slot_value(fn_slot); @@ -76294,9 +76133,8 @@ static bool tree_has_definers_or_binders(s7_scheme *sc, s7_pointer tree) } static void optimize_lambda(s7_scheme *sc, bool unstarred_lambda, s7_pointer func, s7_pointer args, s7_pointer body) -{ +{ /* func is either sc->unused or a symbol */ s7_int len; - len = s7_list_length(sc, body); if (len < 0) /* (define (hi) 1 . 2) */ @@ -76316,9 +76154,10 @@ static void optimize_lambda(s7_scheme *sc, bool unstarred_lambda, s7_pointer fun if (!is_null(p)) add_symbol_to_list(sc, p); sc->got_tc = false; + sc->not_tc = false; sc->got_rec = false; sc->rec_tc_args = -1; - result = body_is_safe(sc, func, body, true); + result = ((is_symbol(func)) && (symbol_is_in_list(sc, func))) ? UNSAFE_BODY : body_is_safe(sc, func, body, true); /* (define (f f)...) */ clear_symbol_list(sc); /* if the body is safe, we can optimize the calling sequence */ @@ -76344,7 +76183,7 @@ static void optimize_lambda(s7_scheme *sc, bool unstarred_lambda, s7_pointer fun if (happy) lambda_set_simple_defaults(body); } - if (result >= SAFE_BODY) /* not RECUR_BODY here */ + if (result >= SAFE_BODY) /* not RECUR_BODY here (need new let for one thing: cons-r in s7test) */ { set_safe_closure_body(body); if (result == VERY_SAFE_BODY) @@ -76353,7 +76192,7 @@ static void optimize_lambda(s7_scheme *sc, bool unstarred_lambda, s7_pointer fun if (is_symbol(func)) { - lst = cons(sc, add_symbol_to_list(sc, func), sc->nil); + lst = list_1(sc, add_symbol_to_list(sc, func)); sc->temp1 = lst; } else lst = sc->nil; @@ -76366,45 +76205,40 @@ static void optimize_lambda(s7_scheme *sc, bool unstarred_lambda, s7_pointer fun { int32_t nvars; for (nvars = 0, p = args; is_pair(p); nvars++, p = cdr(p)); - - if (is_null(p)) - { - if (nvars > 0) - { - fx_annotate_args(sc, body, cleared_args); /* this is incomplete (optimize_expression misses fx_choose cases) */ - fx_tree(sc, body, - (is_pair(car(args))) ? caar(args) : car(args), - (nvars > 1) ? ((is_pair(cadr(args))) ? caadr(args) : cadr(args)) : NULL); - /* fx_tree_outer using sc->curlet? and outest using cleared-args and outlet? */ - /* local is args (cleared_args has func as last), out(loc) runtime is funclet+func - * so let_outlet(let_outlet(local)) is sc->curlet? - */ - /* macros confuse this */ - }} - - if ((unstarred_lambda) || ((is_null(p)) && (nvars == sc->rec_tc_args))) + if ((is_null(p)) && + (nvars > 0)) { - if (is_null(cdr(body))) + fx_annotate_args(sc, body, cleared_args); /* this is incomplete (optimize_expression misses fx_choose cases) */ + fx_tree(sc, body, + (is_pair(car(args))) ? caar(args) : car(args), + (nvars > 1) ? ((is_pair(cadr(args))) ? caadr(args) : cadr(args)) : NULL); + /* fx_tree_outer using sc->curlet? */ + /* local is args (cleared_args has func as last), out(loc) runtime is funclet+func + * so let_outlet(let_outlet(local)) is sc->curlet? + */ + /* macros confuse this */ + } + if (((unstarred_lambda) || ((is_null(p)) && (nvars == sc->rec_tc_args))) && + (is_null(cdr(body)))) + { /* (if <a> #t|#f...) happens only rarely */ + if (sc->got_tc) { - /* (if <a> #t|#f...) happens only rarely */ - if (sc->got_tc) - { - if (check_tc(sc, func, nvars, args, car(body))) - set_safe_closure_body(body); - /* if not check_tc, car(body) is either not a tc op or it is not optimized so that is_fxable will return false */ - } - if ((sc->got_rec) && - (!is_tc_op(optimize_op(car(body))))) - { - if (check_recur(sc, func, nvars, args, car(body))) - set_safe_closure_body(body); - }}}}} + if (check_tc(sc, func, nvars, args, car(body))) + set_safe_closure_body(body); /* (very_)safe_closure set above if > RECUR_BODY */ + /* if not check_tc, car(body) is either not a tc op or it is not optimized so that is_fxable will return false */ + } + if ((sc->got_rec) && + (!is_tc_op(optimize_op(car(body)))) && + (check_recur(sc, func, nvars, args, car(body)))) + set_safe_closure_body(body); + }}} if (is_symbol(func)) { sc->temp1 = sc->nil; free_cell(sc, lst); } sc->got_tc = false; + sc->not_tc = false; sc->got_rec = false; } } @@ -76415,7 +76249,6 @@ static int32_t check_lambda(s7_scheme *sc, s7_pointer form, bool opt) /* this includes unevaluated symbols (direct symbol table refs) in macro arg list */ s7_pointer code, body; int32_t arity = 0; - /* fprintf(stderr, "%s[%d]: %s\n", __func__, __LINE__, display_80(form)); */ if ((sc->safety > NO_SAFETY) && (tree_is_cyclic(sc, form))) @@ -76565,10 +76398,8 @@ static s7_pointer check_case(s7_scheme *sc) if (key_type == T_FREE) key_type = type(car(y)); else - { - if (key_type != type(car(y))) - key_type = NUM_TYPES; - } + if (key_type != type(car(y))) + key_type = NUM_TYPES; if (key_type == T_SYMBOL) set_case_key(car(y)); for (y = cdr(y); is_pair(y); y = cdr(y)) @@ -76759,10 +76590,8 @@ static bool op_case_e_g_1(s7_scheme *sc, s7_pointer selector, bool ok) if (sc->code == sc->unused) /* set in check_case if no else clause */ sc->value = sc->unspecified; else - { - if (is_pair(sc->code)) - goto ELSE_CASE_2; - } + if (is_pair(sc->code)) + goto ELSE_CASE_2; pop_stack(sc); return(true); @@ -76944,10 +76773,8 @@ static void check_let_a_body(s7_scheme *sc, s7_pointer form) pair_set_syntax_op(form, OP_LET_A_A_OLD); } else - { - if (is_pair(cadr(code))) - pair_set_syntax_op(form, OP_LET_A_P_OLD); - } + if (is_pair(cadr(code))) + pair_set_syntax_op(form, OP_LET_A_P_OLD); } static void check_let_one_var(s7_scheme *sc, s7_pointer form, s7_pointer start) @@ -77182,10 +77009,9 @@ static s7_pointer check_let(s7_scheme *sc) /* called only from op_let */ if (vars == 2) pair_set_syntax_op(sc->code, OP_LET_2A_OLD); else - { - if (vars == 3) - pair_set_syntax_op(sc->code, OP_LET_3A_OLD); - }}}} + if (vars == 3) + pair_set_syntax_op(sc->code, OP_LET_3A_OLD); + }}} else { pair_set_syntax_op(sc->code, OP_LET_UNCHECKED); @@ -77402,7 +77228,7 @@ static bool op_let(s7_scheme *sc) static bool op_let_unchecked(s7_scheme *sc) /* not named, but has vars */ { s7_pointer x, code; - sc->args = cons(sc, cdr(sc->code), sc->nil); + sc->args = list_1(sc, cdr(sc->code)); code = cadr(sc->code); x = cdar(code); if (has_fx(x)) @@ -77446,11 +77272,6 @@ static bool op_named_let_fx(s7_scheme *sc) return(op_named_let_1(sc, sc->args)); /* sc->code = (name vars . body), args = vals in decl order */ } -/* tail_let woe: thunk may not have outer let, recursion with let at end can confuse which let_number is current, - * hard to see let-expr (start_let cdr(code)), and if restricted to safe-closures with > 0 args, overhead is - * greater than the savings! - */ - static void op_let_no_vars(s7_scheme *sc) { sc->curlet = make_let(sc, sc->curlet); @@ -77554,6 +77375,7 @@ static void op_let_a_fx_new(s7_scheme *sc) free_cell(sc, sc->curlet); } +/* this and others like it could easily be fx funcs, but check_let is called too late, so it's never seen as fxable */ static void op_let_a_fx_old(s7_scheme *sc) { s7_pointer let, p; @@ -77686,7 +77508,7 @@ static void op_let_fx_old(s7_scheme *sc) { /* GC protected because it's a permanent let? or perhaps use sc->args? */ slot_set_value(slot, fx_call(sc, cdar(p))); - symbol_set_local_slot(slot_symbol(slot), id, slot); + symbol_set_local_slot_unincremented(slot_symbol(slot), id, slot); } let_set_outlet(let, sc->curlet); sc->curlet = let; @@ -77773,10 +77595,8 @@ static bool check_let_star(s7_scheme *sc) set_local(car(code)); } else - { - if (!is_list(car(code))) /* (let* x ... ) */ - eval_error(sc, "let* variable declaration value is missing: ~A", 46, form); - } + if (!is_list(car(code))) /* (let* x ... ) */ + eval_error(sc, "let* variable declaration value is missing: ~A", 46, form); for (vars = ((named_let) ? cadr(code) : car(code)); is_pair(vars); vars = cdr(vars)) { @@ -77909,16 +77729,6 @@ static bool check_let_star(s7_scheme *sc) static inline bool op_let_star1(s7_scheme *sc) { - /* we can't skip (or reuse) this new let -- we have to imitate a nested let, otherwise - * (let ((f1 (lambda (arg) (+ arg 1)))) - * (let* ((x 32) - * (f1 (lambda (arg) (f1 (+ x arg))))) - * (f1 1))) - * will hang. - * To get around this requires lookup or s7_tree_memq in check_let_star, - * both (much) more expensive than making a useless let! - */ - uint64_t let_counter = S7_INT64_MAX; while (true) { @@ -78251,10 +78061,8 @@ static void check_let_temporarily(s7_scheme *sc) set_elist_2(sc, wrap_string(sc, "can't set! ~A", 13), car(carx))); } else - { - if (!is_pair(car(carx))) /* (let-temporarily ((1 2)) ...) */ - eval_error(sc, "let-temporarily: bad variable ~S", 32, carx); - } + if (!is_pair(car(carx))) /* (let-temporarily ((1 2)) ...) */ + eval_error(sc, "let-temporarily: bad variable ~S", 32, carx); if (!is_pair(cdr(carx))) /* (let-temporarily ((x . 1))...) */ eval_error(sc, "let-temporarily: variable declaration value is messed up: ~S", 60, carx); @@ -78363,7 +78171,7 @@ static goto_t op_let_temp_init2(s7_scheme *sc) sc->code = list_3(sc, sc->set_symbol, settee, new_value); return(goto_top_no_pop); } - slot = symbol_to_slot(sc, settee); + slot = lookup_slot_from(settee, sc->curlet); if (!is_slot(slot)) unbound_variable_error(sc, settee); if (is_immutable_slot(slot)) @@ -78416,7 +78224,7 @@ static bool op_let_temp_done1(s7_scheme *sc) else sc->code = list_3(sc, sc->set_symbol, settee, sc->value); return(false); /* goto eval */ } - slot = symbol_to_slot(sc, settee); + slot = lookup_slot_from(settee, sc->curlet); if (is_immutable_slot(slot)) immutable_object_error(sc, set_elist_3(sc, immutable_error_string, sc->let_temporarily_symbol, settee)); slot_set_value(slot, sc->value); @@ -78482,7 +78290,7 @@ static bool op_let_temp_fx(s7_scheme *sc) /* all entries are of the form (symbol { var = car(p); settee = car(var); - slot = symbol_to_slot(sc, settee); + slot = lookup_slot_from(settee, sc->curlet); if (!is_slot(slot)) unbound_variable_error(sc, settee); if (is_immutable_slot(slot)) @@ -78509,7 +78317,7 @@ static bool op_let_temp_fx_1(s7_scheme *sc) /* one entry */ sc->code = cdr(sc->code); var = caar(sc->code); settee = car(var); - slot = symbol_to_slot(sc, settee); + slot = lookup_slot_from(settee, sc->curlet); if (!is_slot(slot)) unbound_variable_error(sc, settee); if (is_immutable_slot(slot)) @@ -78541,7 +78349,7 @@ static bool op_let_temp_setter(s7_scheme *sc) sym = fx_call(sc, cdr(var)); e = sc->curlet; sc->curlet = fx_call(sc, cddr(var)); - slot = symbol_to_slot(sc, sym); + slot = lookup_slot_from(sym, sc->curlet); sc->curlet = e; push_stack(sc, OP_LET_TEMP_SETTER_UNWIND, slot_setter(slot), slot); slot_set_setter(slot, sc->F); @@ -78636,10 +78444,9 @@ static bool check_and(s7_scheme *sc, s7_pointer expr) if (!has_fx(cdr(code))) pair_set_syntax_op(expr, OP_AND_SAFE_P2); else - { - if ((!has_fx(cddr(code))) && (len == 3)) - pair_set_syntax_op(expr, OP_AND_SAFE_P3); - }}}} + if ((!has_fx(cddr(code))) && (len == 3)) + pair_set_syntax_op(expr, OP_AND_SAFE_P3); + }}} return(false); } @@ -78790,7 +78597,8 @@ static void set_if_opts(s7_scheme *sc, s7_pointer form, bool one_branch, bool re return; } - if (is_h_safe_c_s(test)) + if ((is_h_safe_c_s(test)) && + (is_symbol(car(test)))) /* TODO: c_func itself here -- can we get type? */ { uint8_t typ; typ = symbol_type(car(test)); @@ -78938,19 +78746,18 @@ static s7_pointer check_if(s7_scheme *sc) eval_error(sc, "(if): if needs at least 2 expressions: ~A", 41, form); cdr_code = cdr(code); - if (!is_pair(cdr_code)) /* (if 1) */ + if (!is_pair(cdr_code)) /* (if 1) */ eval_error(sc, "(if ~A): if needs another clause", 32, car(sc->code)); if (is_pair(cdr(cdr_code))) { - if (is_not_null(cddr(cdr_code))) /* (if 1 2 3 4) */ + if (is_not_null(cddr(cdr_code))) /* (if 1 2 3 4) */ eval_error(sc, "too many clauses for if: ~A", 27, form); } else - { - if (is_not_null(cdr(cdr_code))) /* (if 1 2 . 3) */ - eval_error(sc, "if: ~A has improper list?", 25, form); - } + if (is_not_null(cdr(cdr_code))) /* (if 1 2 . 3) */ + eval_error(sc, "if: ~A has improper list?", 25, form); + pair_set_syntax_op(form, OP_IF_UNCHECKED); set_if_opts(sc, form, is_null(cdr(cdr_code)), false); return(code); @@ -78993,10 +78800,8 @@ static void check_when(s7_scheme *sc) if (!is_pair(cdr(code))) /* (when 1) or (when 1 . 1) */ eval_error(sc, "when has no body?: ~A", 22, form); else - { - if (!s7_is_proper_list(sc, cddr(code))) - eval_error(sc, "when: stray dot?", 16, form); - } + if (!s7_is_proper_list(sc, cddr(code))) + eval_error(sc, "when: stray dot?", 16, form); pair_set_syntax_op(form, OP_WHEN_P); if (is_null(cddr(code))) @@ -79024,15 +78829,13 @@ static void check_when(s7_scheme *sc) if (c_callee(code) == fx_and_2) pair_set_syntax_op(form, OP_WHEN_AND_2); else - { - if (c_callee(code) == fx_and_3) - pair_set_syntax_op(form, OP_WHEN_AND_3); - }} + if (c_callee(code) == fx_and_3) + pair_set_syntax_op(form, OP_WHEN_AND_3); + } else { if ((is_pair(test)) && (car(test) == sc->and_symbol)) { - /* an experiment... */ opcode_t new_op; pair_set_syntax_op(test, symbol_syntax_op_checked(test)); check_and(sc, test); @@ -79138,10 +78941,8 @@ static void check_unless(s7_scheme *sc) if (!is_pair(cdr(code))) /* (unless 1) or (unless 1 . 1) */ eval_error(sc, "unless has no body?: ~A", 24, form); else - { - if (!s7_is_proper_list(sc, cddr(code))) - eval_error(sc, "unless: stray dot?", 18, form); - } + if (!s7_is_proper_list(sc, cddr(code))) + eval_error(sc, "unless: stray dot?", 18, form); pair_set_syntax_op(form, OP_UNLESS_P); if (is_null(cddr(code))) @@ -79249,7 +79050,6 @@ static void check_define(s7_scheme *sc) bool starred; code = cdr(sc->code); - starred = (sc->cur_op == OP_DEFINE_STAR); if (starred) { @@ -79355,7 +79155,7 @@ static bool op_define_unchecked(s7_scheme *sc) (is_pair(cdar(code)))) { sc->value = make_closure(sc, cdar(code), cdr(code), T_CLOSURE_STAR, CLOSURE_ARITY_NOT_SET); - /* closure_body may not be cdr(code) after make_closure (add_trace) */ + /* closure_body might not be cdr(code) after make_closure (add_trace) */ if ((is_pair(locp)) && (has_location(locp))) { pair_set_location(closure_body(sc->value), pair_location(locp)); @@ -79404,7 +79204,6 @@ static bool op_define_unchecked(s7_scheme *sc) static s7_pointer make_funclet(s7_scheme *sc, s7_pointer new_func, s7_pointer func_name, s7_pointer outer_let) { s7_pointer new_let, arg; - /* fprintf(stderr, "%s[%d]: %s %s %s\n", __func__, __LINE__, display(new_func), display(func_name), display(outer_let)); */ new_cell_no_check(sc, new_let, T_LET | T_FUNCLET); let_set_id(new_let, ++sc->let_number); let_set_outlet(new_let, outer_let); @@ -79446,7 +79245,7 @@ static s7_pointer make_funclet(s7_scheme *sc, s7_pointer new_func, s7_pointer fu } set_is_rest_slot(last_slot); }} - else + else /* closure_star */ { s7_pointer slot, first_default; first_default = sc->nil; @@ -79539,7 +79338,7 @@ static void op_define_constant1(s7_scheme *sc) if (is_symbol(sc->code)) { s7_pointer slot; - slot = symbol_to_slot(sc, sc->code); + slot = lookup_slot_from(sc->code, sc->curlet); set_possibly_constant(sc->code); set_immutable(slot); if (is_any_closure(slot_value(slot))) @@ -79550,7 +79349,6 @@ static void op_define_constant1(s7_scheme *sc) static inline void define_funchecked(s7_scheme *sc) { s7_pointer new_func, code; - /* fprintf(stderr, "%s[%d]: %s\n", __func__, __LINE__, display(sc->code)); */ code = cdr(sc->code); sc->value = caar(code); /* func name */ @@ -79591,10 +79389,6 @@ static s7_pointer cur_op_to_caller(s7_scheme *sc, opcode_t op) case OP_MACRO_STAR: return(sc->macro_star_symbol); case OP_BACRO: return(sc->bacro_symbol); case OP_BACRO_STAR: return(sc->bacro_star_symbol); -#if S7_DEBUGGING - default: - fprintf(stderr, "%s[%d]: got %s?\n", __func__, __LINE__, op_names[op]); -#endif } return(sc->define_macro_symbol); } @@ -79691,7 +79485,7 @@ static bool op_define_macro(s7_scheme *sc) if (symbol_has_setter(caar(sc->code))) { s7_pointer x; - x = symbol_to_slot(sc, caar(sc->code)); + x = lookup_slot_from(caar(sc->code), sc->curlet); if ((is_slot(x)) && (slot_has_setter(x))) { @@ -79841,7 +79635,7 @@ static goto_t op_expansion(s7_scheme *sc) if ((symbol_id(symbol) == 0) || (sc->curlet == sc->nil)) slot = global_slot(symbol); - else slot = symbol_to_slot(sc, symbol); + else slot = lookup_slot_from(symbol, sc->curlet); sc->code = (is_slot(slot)) ? slot_value(slot) : sc->undefined; if ((!is_either_macro(sc->code)) || (!is_expansion(sc->code))) @@ -79993,10 +79787,8 @@ static void op_finish_expansion(s7_scheme *sc) if (sc->value == sc->no_value) sc->stack_end[-1] = (s7_pointer)OP_READ_NEXT; else - { - if (is_pair(sc->value)) - sc->value = copy_body(sc, sc->value); - } + if (is_pair(sc->value)) + sc->value = copy_body(sc, sc->value); } @@ -80184,10 +79976,9 @@ static void check_cond(s7_scheme *sc) pair_set_syntax_op(form, OP_COND_FX_3E); }}}} else - { - if (result_single) - pair_set_syntax_op(form, OP_COND_SIMPLE_O); - }} + if (result_single) + pair_set_syntax_op(form, OP_COND_SIMPLE_O); + } set_opt3_any(code, caar(code)); } @@ -80493,21 +80284,23 @@ static bool feed_to(s7_scheme *sc) { sc->args = multiple_value(sc->value); clear_multiple_value(sc->args); - } + if (is_symbol(cadr(sc->code))) + { + sc->code = lookup_global(sc, cadr(sc->code)); /* car is => */ + return(true); + }} else { if (is_symbol(cadr(sc->code))) { - s7_pointer func; - func = lookup_global(sc, cadr(sc->code)); /* car is => */ - sc->code = func; - sc->args = (needs_copied_args(func)) ? list_1(sc, sc->value) : set_plist_1(sc, sc->value); + sc->code = lookup_global(sc, cadr(sc->code)); /* car is => */ + sc->args = (needs_copied_args(sc->code)) ? list_1(sc, sc->value) : set_plist_1(sc, sc->value); return(true); } - sc->args = list_1(sc, sc->value); /* not plist here */ + sc->args = list_1(sc, sc->value); /* not plist here */ } push_stack_direct(sc, OP_FEED_TO_1); - sc->code = cadr(sc->code); /* need to evaluate the target function */ + sc->code = cadr(sc->code); /* need to evaluate the target function */ return(false); } @@ -80555,11 +80348,9 @@ static inline void check_set(s7_scheme *sc) if (is_pair(car(code))) { - if (is_pair(caar(code))) - { - if (!is_list(cdar(code))) /* (set! ('(1 2) . 0) 1) */ - eval_error(sc, "improper list of args to set!: ~A", 33, form); - } + if ((is_pair(caar(code))) && + (!is_list(cdar(code)))) /* (set! ('(1 2) . 0) 1) */ + eval_error(sc, "improper list of args to set!: ~A", 33, form); if (!s7_is_proper_list(sc, car(code))) /* (set! ("hi" . 1) #\a) or (set! (#(1 2) . 1) 0) */ eval_error(sc, "set! target is an improper list: (set! ~A ...)", 46, car(code)); } @@ -80568,10 +80359,9 @@ static inline void check_set(s7_scheme *sc) if (!is_symbol(car(code))) /* (set! 12345 1) */ eval_error(sc, "set! can't change ~S", 20, car(code)); else - { - if (is_constant_symbol(sc, car(code))) /* (set! pi 3) */ - eval_error(sc, (is_keyword(car(code))) ? "set!: can't change keyword's value: ~S" : "set!: can't alter constant's value: ~S", 38, car(code)); - }} + if (is_constant_symbol(sc, car(code))) /* (set! pi 3) */ + eval_error(sc, (is_keyword(car(code))) ? "set!: can't change keyword's value: ~S" : "set!: can't alter constant's value: ~S", 38, car(code)); + } if (is_pair(car(code))) { @@ -80669,6 +80459,7 @@ static inline void check_set(s7_scheme *sc) else /* is_pair(cadr(inner)) */ { if ((caadr(inner) == sc->quote_symbol) && + (is_global(sc->quote_symbol)) && /* (call/cc (lambda* 'x) ... (set! (setter 'y) ...)...) should return y */ (is_symbol(car(inner))) && ((is_normal_symbol(value)) || (is_fxable(sc, value)))) @@ -80703,7 +80494,7 @@ static inline void check_set(s7_scheme *sc) { if (is_normal_symbol(value)) { - if (is_slot(symbol_to_slot(sc, value))) + if (is_slot(lookup_slot_from(value, sc->curlet))) { pair_set_syntax_op(form, OP_SET_SYMBOL_S); set_opt2_sym(code, value); @@ -80801,10 +80592,9 @@ static inline void check_set(s7_scheme *sc) if (opt1_cfunc(value) == sc->add_x1) pair_set_syntax_op(form, OP_INCREMENT_BY_1); else - { - if (opt1_cfunc(value) == sc->subtract_x1) - pair_set_syntax_op(form, OP_DECREMENT_BY_1); - }} + if (opt1_cfunc(value) == sc->subtract_x1) + pair_set_syntax_op(form, OP_DECREMENT_BY_1); + } else { if ((cadr(value) == int_one) && @@ -80825,28 +80615,28 @@ static inline void check_set(s7_scheme *sc) static void op_set_symbol_c(s7_scheme *sc) { s7_pointer slot; - slot = symbol_to_slot(sc, cadr(sc->code)); + slot = lookup_slot_from(cadr(sc->code), sc->curlet); slot_set_value(slot, sc->value = opt2_con(cdr(sc->code))); } static void op_set_symbol_s(s7_scheme *sc) { s7_pointer slot; - slot = symbol_to_slot(sc, cadr(sc->code)); + slot = lookup_slot_from(cadr(sc->code), sc->curlet); slot_set_value(slot, sc->value = lookup(sc, opt2_sym(cdr(sc->code)))); } static void op_set_symbol_a(s7_scheme *sc) { s7_pointer slot; - slot = symbol_to_slot(sc, cadr(sc->code)); + slot = lookup_slot_from(cadr(sc->code), sc->curlet); slot_set_value(slot, sc->value = fx_call(sc, cddr(sc->code))); } static inline void op_set_cons(s7_scheme *sc) { s7_pointer slot; - slot = symbol_to_slot(sc, cadr(sc->code)); + slot = lookup_slot_from(cadr(sc->code), sc->curlet); slot_set_value(slot, sc->value = cons(sc, lookup(sc, opt2_sym(cdr(sc->code))), slot_value(slot))); /* ([set!] bindings (cons v bindings)) */ } @@ -80854,7 +80644,7 @@ static void op_increment_ss(s7_scheme *sc) { s7_pointer slot; sc->code = cdr(sc->code); - slot = symbol_to_slot(sc, car(sc->code)); + slot = lookup_slot_from(car(sc->code), sc->curlet); set_car(sc->t2_1, slot_value(slot)); set_car(sc->t2_2, lookup(sc, opt2_sym(sc->code))); slot_set_value(slot, sc->value = c_call(cadr(sc->code))(sc, sc->t2_1)); @@ -80864,7 +80654,7 @@ static void op_increment_saa(s7_scheme *sc) { s7_pointer slot, arg, val; sc->code = cdr(sc->code); - slot = symbol_to_slot(sc, car(sc->code)); + slot = lookup_slot_from(car(sc->code), sc->curlet); arg = opt2_pair(sc->code); /* cddr(value) */ val = fx_call(sc, cdr(arg)); set_car(sc->t3_2, fx_call(sc, arg)); @@ -80877,7 +80667,7 @@ static void op_increment_sa(s7_scheme *sc) { s7_pointer slot, arg; sc->code = cdr(sc->code); - slot = symbol_to_slot(sc, car(sc->code)); + slot = lookup_slot_from(car(sc->code), sc->curlet); arg = opt2_pair(sc->code); set_car(sc->t2_2, fx_call(sc, arg)); set_car(sc->t2_1, slot_value(slot)); @@ -81078,11 +80868,10 @@ static Inline bool op_set_pair_p_1(s7_scheme *sc) if (is_symbol(arg)) arg = lookup_checked(sc, arg); else - { - if (is_pair(arg)) - arg = cadr(arg); /* can only be (quote ...) in this case */ - } - return(set_pair_p_3(sc, symbol_to_slot(sc, caar(sc->code)), arg, value)); + if (is_pair(arg)) + arg = cadr(arg); /* can only be (quote ...) in this case */ + + return(set_pair_p_3(sc, lookup_slot_from(caar(sc->code), sc->curlet), arg, value)); } static bool op_set_pair(s7_scheme *sc) @@ -81098,20 +80887,19 @@ static bool op_set_pair(s7_scheme *sc) if (is_symbol(arg)) arg = lookup_checked(sc, arg); else - { - if (is_pair(arg)) - arg = cadr(arg); /* can only be (quote ...) in this case */ - } + if (is_pair(arg)) + arg = cadr(arg); /* can only be (quote ...) in this case */ + obj = caar(sc->code); if (is_symbol(obj)) - obj = symbol_to_slot(sc, obj); + obj = lookup_slot_from(obj, sc->curlet); return(set_pair_p_3(sc, obj, arg, value)); } static void op_set_safe(s7_scheme *sc) { s7_pointer lx; - lx = symbol_to_slot(sc, sc->code); /* SET_CASE above looks for car(sc->code) */ + lx = lookup_slot_from(sc->code, sc->curlet); /* SET_CASE above looks for car(sc->code) */ if (is_slot(lx)) slot_set_value(lx, sc->value); else unbound_variable_error(sc, sc->code); @@ -81121,7 +80909,7 @@ static s7_pointer op_set1(s7_scheme *sc) { s7_pointer lx; /* if unbound variable hook here, we need the binding, not the current value */ - lx = symbol_to_slot(sc, sc->code); + lx = lookup_slot_from(sc->code, sc->curlet); if (is_slot(lx)) { if (slot_has_setter(lx)) @@ -81191,7 +80979,7 @@ static goto_t op_set2(s7_scheme *sc) if (is_multiple_value(sc->value)) /* this has to be at least 2 args, sc->args and sc->code make 2 more, so... */ eval_error(sc, "set!: too many arguments: ~S", 28, - cons(sc, sc->set_symbol, pair_append(sc, multiple_value(sc->value), pair_append(sc, sc->args, sc->code)))); + set_ulist_1(sc, sc->set_symbol, pair_append(sc, multiple_value(sc->value), pair_append(sc, sc->args, sc->code)))); if (sc->args == sc->nil) eval_error(sc, "list set!: not enough arguments: ~S", 35, sc->code); @@ -81304,7 +81092,7 @@ static void op_increment_sp(s7_scheme *sc) { s7_pointer sym; sc->code = cdr(sc->code); - sym = symbol_to_slot(sc, car(sc->code)); + sym = lookup_slot_from(car(sc->code), sc->curlet); push_stack(sc, OP_INCREMENT_SP_1, sym, sc->code); sc->code = T_Pair(opt2_pair(sc->code)); /* caddadr(sc->code); */ } @@ -81319,9 +81107,7 @@ static void op_increment_sp_1(s7_scheme *sc) static void op_increment_sp_mv(s7_scheme *sc) { - set_car(sc->u1_1, slot_value(sc->args)); - set_cdr(sc->u1_1, sc->value); - sc->value = c_call(cadr(sc->code))(sc, sc->u1_1); + sc->value = c_call(cadr(sc->code))(sc, set_ulist_1(sc, slot_value(sc->args), sc->value)); set_car(sc->u1_1, sc->F); slot_set_value(sc->args, sc->value); } @@ -81333,11 +81119,10 @@ static goto_t op_set_dilambda_p_1(s7_scheme *sc) if (is_symbol(arg)) arg = lookup_checked(sc, arg); else - { - if (is_pair(arg)) - arg = cadr(arg); /* can only be (quote ...) in this case */ - } - obj = symbol_to_slot(sc, caar(sc->code)); + if (is_pair(arg)) + arg = cadr(arg); /* can only be (quote ...) in this case */ + + obj = lookup_slot_from(caar(sc->code), sc->curlet); func = slot_value(obj); if ((is_closure(func)) && (is_safe_closure(closure_setter(func)))) @@ -81377,10 +81162,8 @@ static bool safe_stepper_expr(s7_pointer expr, s7_pointer vars) return(false); } else - { - if (direct_memq(p, vars)) - return(false); - } + if (direct_memq(p, vars)) + return(false); return(true); } @@ -81970,7 +81753,7 @@ static goto_t set_implicit(s7_scheme *sc) /* sc->code incoming is (set! (...) .. if (is_symbol(caar_code)) { /* this was cx = s7_symbol_value(sc, caar_code) but the function call overhead is noticeable */ - cx = symbol_to_slot(sc, caar_code); + cx = lookup_slot_from(caar_code, sc->curlet); if (is_slot(cx)) cx = slot_value(cx); else s7_error(sc, sc->syntax_error_symbol, set_elist_3(sc, no_setter_string, caar_code, sc->prepackaged_type_names[type(cx)])); @@ -82155,7 +81938,7 @@ static bool do_is_safe(s7_scheme *sc, s7_pointer body, s7_pointer steppers, s7_p { bool res; set_match_symbol(settee); - res = tree_match(caaddr(sc->code)); /* (set! end ...) in some fashion */ + res = tree_match(caaddr(sc->code)); /* (set! end ...) in some fashion */ clear_match_symbol(settee); if (res) return(false); @@ -82166,7 +81949,7 @@ static bool do_is_safe(s7_scheme *sc, s7_pointer body, s7_pointer steppers, s7_p } if (!do_is_safe(sc, cddr(expr), steppers, var_list, has_set)) return(false); - if (!safe_stepper_expr(expr, steppers)) /* is step var's value used as the stored value by set!? */ + if (!safe_stepper_expr(expr, steppers)) /* is step var's value used as the stored value by set!? */ return(false); } break; @@ -82310,8 +82093,7 @@ static bool is_simple_end(s7_scheme *sc, s7_pointer end) (optimize_op(end) == HOP_SAFE_C_SS) || (optimize_op(end) == HOP_SAFE_C_SC))); } -#define fxify_step_exprs(Sc, Code) fxify_step_exprs_1(Sc, Code, __func__, __LINE__) -static s7_pointer fxify_step_exprs_1(s7_scheme *sc, s7_pointer code, const char *func, int line) +static s7_pointer fxify_step_exprs(s7_scheme *sc, s7_pointer code) { s7_pointer p, e, vars; vars = car(code); @@ -82392,10 +82174,15 @@ static inline bool do_tree_has_definers(s7_scheme *sc, s7_pointer tree) } else { - if ((is_normal_vector(pp)) && - (do_vector_has_definers(sc, pp))) - return(true); - }}} + if (is_applicable(pp)) + { + if ((is_normal_vector(pp)) && (do_vector_has_definers(sc, pp))) + return(true); + if ((is_c_function(pp)) && (is_func_definer(pp))) + return(true); + if ((is_syntax(pp)) && (is_syntax_definer(pp))) + return(true); + }}}} return(false); } @@ -82440,10 +82227,9 @@ static void check_do_for_obvious_errors(s7_scheme *sc, s7_pointer form) eval_error(sc, "do: step variable info is an improper list?: ~A", 47, x); } else - { - if (is_not_null(cdddr(y))) /* (do ((i 0 1 (+ i 1))) ...) */ - eval_error(sc, "do: step variable info has extra stuff after the increment: ~A", 62, x); - }} + if (is_not_null(cdddr(y))) /* (do ((i 0 1 (+ i 1))) ...) */ + eval_error(sc, "do: step variable info has extra stuff after the increment: ~A", 62, x); + } else eval_error(sc, "do: step variable has no initial value: ~A", 42, x); set_local(car(y)); @@ -82787,7 +82573,7 @@ static s7_pointer check_do(s7_scheme *sc) if (last_stepper) { fx_tree(sc, end, last_stepper, previous_stepper); - + if ((last_expr) && (is_pair(last_expr))) { if ((is_funclet(sc->curlet)) && (tis_slot(let_slots(sc->curlet)))) @@ -82799,7 +82585,7 @@ static s7_pointer check_do(s7_scheme *sc) last_expr = cdr(last_expr); if (is_pair(last_expr)) fx_tree(sc, last_expr, last_stepper, previous_stepper); - + if ((previous_expr) && (is_pair(previous_expr))) { if ((is_funclet(sc->curlet)) && (tis_slot(let_slots(sc->curlet)))) @@ -82978,7 +82764,7 @@ static goto_t op_dox(s7_scheme *sc) { s7_pointer slot; for (slot = slots; tis_slot(slot); slot = next_slot(slot)) - symbol_set_local_slot_unchecked(slot_symbol(slot), id, slot); + symbol_set_local_slot_unchecked_and_unincremented(slot_symbol(slot), id, slot); } end = cadr(sc->code); endp = car(end); @@ -83016,9 +82802,10 @@ static goto_t op_dox(s7_scheme *sc) do {slot_set_value(stepper, cdr(slot_value(stepper)));} while (endf(sc, endp) == sc->F); sc->value = sc->T; } - else + else { - if ((f == fx_add_t1) && (is_t_integer(slot_value(stepper)))) + /* (- n 1) tpeak dup */ + if (((f == fx_add_t1) || (f == fx_add_u1)) && (is_t_integer(slot_value(stepper)))) { s7_pointer p; p = make_mutable_integer(sc, integer(slot_value(stepper))); @@ -83027,7 +82814,7 @@ static goto_t op_dox(s7_scheme *sc) { sc->pc = 0; if (bool_optimize(sc, end)) /* in dup.scm this costs more than the fb(o) below saves (search is short) */ - { /* but tc is much slower (and bool|int_optimize dominates) */ + { /* but tc is much slower (and bool|int_optimize dominates) */ opt_info *o; bool (*fb)(opt_info *o); o = sc->opts[0]; @@ -83075,7 +82862,7 @@ static goto_t op_dox(s7_scheme *sc) sc->code = cdr(end); if (is_symbol(car(sc->code))) { - step1 = symbol_to_slot(sc, car(sc->code)); + step1 = lookup_slot_from(car(sc->code), sc->curlet); sc->value = slot_value(step1); if (is_t_real(sc->value)) clear_mutable_number(sc->value); @@ -83098,7 +82885,7 @@ static goto_t op_dox(s7_scheme *sc) else /* there is a body */ { /* is let activated? also multiexpr body and other fx? */ - if ((is_null(cdr(code))) && + if ((is_null(cdr(code))) && /* 1 expr, code is cdddr(form) here */ (is_pair(car(code)))) { s7_pointer body; @@ -83138,8 +82925,8 @@ static goto_t op_dox(s7_scheme *sc) sc->code = cdr(end); return(goto_do_end_clauses); } - - if ((stepf == fx_add_t1) && (stepper == slots) && (is_t_integer(slot_value(stepper)))) + /* a few + 1.0 here (s7test) */ + if (((stepf == fx_add_t1) || (stepf == fx_add_u1)) && (is_t_integer(slot_value(stepper)))) { s7_int i; i = integer(slot_value(stepper)); @@ -83235,6 +83022,7 @@ static goto_t op_dox(s7_scheme *sc) sc->code = cdr(end); return(goto_do_end_clauses); } + if ((steppers == 1) && (car(body) == sc->set_symbol) && (is_pair(cdr(body))) && @@ -83251,7 +83039,7 @@ static goto_t op_dox(s7_scheme *sc) set_c_call(val, fx_choose(sc, val, sc->curlet, let_symbol_is_safe)); valf = c_callee(val); val = car(val); - slot = symbol_to_slot(sc, cadr(body)); + slot = lookup_slot_from(cadr(body), sc->curlet); if (slot == sc->undefined) unbound_variable_error(sc, cadr(body)); stepf = c_callee(slot_expression(stepper)); @@ -83262,6 +83050,24 @@ 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))) + { + bodyf = c_call_unchecked(code); + do { + s7_pointer slot1; + bodyf(sc, body); + slot1 = slots; + 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 */ { @@ -83298,11 +83104,9 @@ static goto_t op_dox(s7_scheme *sc) }} if (p == code) - { - for (; is_pair(p); p = cdr(p)) - if (!is_fxable(sc, car(p))) - break; - } + for (; is_pair(p); p = cdr(p)) + if (!is_fxable(sc, car(p))) + break; if (is_null(p)) { @@ -83321,15 +83125,11 @@ static goto_t op_dox(s7_scheme *sc) while (true) { if (use_opts) - { - for (i = 0; i < body_len; i++) - body[i]->v[0].fp(body[i]); - } + for (i = 0; i < body_len; i++) + body[i]->v[0].fp(body[i]); else - { - for (p = code; is_pair(p); p = cdr(p)) - fx_call(sc, p); - } + for (p = code; is_pair(p); p = cdr(p)) + fx_call(sc, p); if (steppers == 1) slot_set_value(stepper, stepf(sc, stepa)); @@ -83357,7 +83157,6 @@ static goto_t op_dox(s7_scheme *sc) (is_syntactic_symbol(car(code)))) { push_stack_no_args_direct(sc, OP_DOX_STEP_O); - if (is_syntactic_pair(code)) sc->cur_op = (opcode_t)optimize_op(code); else @@ -83443,8 +83242,7 @@ static void op_dox_no_body(s7_scheme *sc) s7_pointer istep; incr = integer(opt2_con(sc->code)); istep = make_mutable_integer(sc, integer(slot_value(slot))); - /* this can cause unexpected, but correct behavior: - * (do ((x 0) (i 0 (+ i 1))) ((= i 1) x) (set! x (memq x '(0)))) -> #f + /* this can cause unexpected, but correct behavior: (do ((x 0) (i 0 (+ i 1))) ((= i 1) x) (set! x (memq x '(0)))) -> #f * because (eq? 0 x) here is false -- memv will return '(0). tree-count is similar. */ slot_set_value(slot, istep); @@ -83460,7 +83258,7 @@ static void op_dox_no_body(s7_scheme *sc) integer(istep) += incr; } else while (testf(sc, test) == sc->F) {integer(istep) += incr;} - if ((integer(istep) < NUM_SMALL_INTS) && (integer(istep) >= 0)) + if (is_small_int(integer(istep))) slot_set_value(slot, small_int(integer(istep))); else clear_mutable_integer(istep); sc->value = fx_call(sc, result); @@ -83482,7 +83280,7 @@ static void op_dox_no_body(s7_scheme *sc) f2 = c_callee(p); f3_arg = cadr(p); f3 = c_callee(cdr(p)); - if ((stepf == fx_add_t1) && (is_t_integer(slot_value(slot)))) + if (((stepf == fx_add_t1) || (stepf == fx_add_u1)) && (is_t_integer(slot_value(slot)))) { s7_pointer ip; ip = make_mutable_integer(sc, integer(slot_value(slot))); @@ -83734,7 +83532,7 @@ static bool do_step1(s7_scheme *sc) static bool op_do_step2(s7_scheme *sc) { if (is_multiple_value(sc->value)) - eval_error(sc, "do: variable step value can't be ~S", 35, cons(sc, sc->values_symbol, sc->value)); + eval_error(sc, "do: variable step value can't be ~S", 35, set_ulist_1(sc, sc->values_symbol, sc->value)); slot_set_pending_value(car(sc->args), sc->value); /* save current value */ sc->args = cdr(sc->args); /* go to next step var */ return(do_step1(sc)); @@ -83896,12 +83694,11 @@ static bool op_simple_do_1(s7_scheme *sc, s7_pointer code) fpt(sc, slot_value(o->v[1].p), o->v[5].fp(o->v[4].o1), slot_value(o->v[2].p)); }} else - { - for (i = start; i < stop; i++) - { - slot_set_value(ctr_slot, make_integer(sc, i)); - fp(o); - }}}} + for (i = start; i < stop; i++) + { + slot_set_value(ctr_slot, make_integer(sc, i)); + fp(o); + }}} else { /* splitting out opt_float_any_nr here saves almost nothing */ @@ -83938,12 +83735,11 @@ static bool op_simple_do_1(s7_scheme *sc, s7_pointer code) fp(o); }}} else - { - for (i = start; i >= stop; i--) - { - slot_set_value(ctr_slot, make_integer(sc, i)); - func(sc, body); - }} + for (i = start; i >= stop; i--) + { + slot_set_value(ctr_slot, make_integer(sc, i)); + func(sc, body); + } sc->value = sc->T; sc->code = cdadr(code); return(true); @@ -83970,12 +83766,11 @@ static bool op_simple_do_1(s7_scheme *sc, s7_pointer code) fp(o); }} else - { - for (i = start; i < stop; i += incr) - { - slot_set_value(ctr_slot, make_integer(sc, i)); - func(sc, body); - }} + for (i = start; i < stop; i += incr) + { + slot_set_value(ctr_slot, make_integer(sc, i)); + func(sc, body); + } sc->value = sc->T; sc->code = cdadr(code); return(true); @@ -84029,7 +83824,7 @@ static bool op_simple_do(s7_scheme *sc) end = caddr(caadr(code)); if (is_symbol(end)) - let_set_dox_slot2(sc->curlet, symbol_to_slot(sc, end)); + let_set_dox_slot2(sc->curlet, lookup_slot_from(end, sc->curlet)); else let_set_dox_slot2(sc->curlet, make_slot(sc, caaar(code), end)); set_car(sc->t2_1, slot_value(let_dox_slot1(sc->curlet))); @@ -84202,11 +83997,11 @@ static Inline bool op_dotimes_step_o(s7_scheme *sc) static bool opt_dotimes(s7_scheme *sc, s7_pointer code, s7_pointer scc, bool safe_step) { s7_int end; + end = denominator(slot_value(sc->args)); /* s7_optimize below can step on this value! */ if (safe_step) set_safe_stepper(sc->args); else set_safe_stepper(let_dox_slot1(sc->curlet)); - /* I think safe_step means the stepper is completely unproblematic */ if (is_null(cdr(code))) @@ -84220,7 +84015,6 @@ static bool opt_dotimes(s7_scheme *sc, s7_pointer code, s7_pointer scc, bool saf set_no_cell_opt(code); return(false); } - end = denominator(slot_value(sc->args)); if (safe_step) { s7_pointer stepper; @@ -84253,15 +84047,13 @@ static bool opt_dotimes(s7_scheme *sc, s7_pointer code, s7_pointer scc, bool saf integer(stepper)++; }} else - { - for (; integer(stepper) < end; integer(stepper)++) - fd(o); - }} + for (; integer(stepper) < end; integer(stepper)++) + fd(o); + } else { s7_pointer (*fp)(opt_info *o); fp = o->v[0].fp; - /* an experiment -- altogether 100 times as fast! */ if ((fp == opt_p_pip_ssc) && /* or any opt without f? */ (stepper == slot_value(o->v[2].p)) && /* i.e. index by do counter */ (o->v[3].p_pip_f == string_set_unchecked) && /* or any similar setter? */ @@ -84277,10 +84069,8 @@ static bool opt_dotimes(s7_scheme *sc, s7_pointer code, s7_pointer scc, bool saf if (fp == opt_if_bp) fp = opt_if_bp_nr; else - { - if (fp == opt_if_nbp_fs) - fp = opt_if_nbp_fs_nr; - } + if (fp == opt_if_nbp_fs) + fp = opt_if_nbp_fs_nr; for (; integer(stepper) < end; integer(stepper)++) fp(o); }}} @@ -84307,52 +84097,68 @@ static bool opt_dotimes(s7_scheme *sc, s7_pointer code, s7_pointer scc, bool saf integer(stepper) = end; } else - { - for (; integer(stepper) < end; integer(stepper)++) - ex[integer(stepper)] = val; - }} + for (; integer(stepper) < end; integer(stepper)++) + ex[integer(stepper)] = val; + } else - { - for (; integer(stepper) < end; integer(stepper)++) - fi(o); - /* if fi = opt_i_i_s for example, -> o->v[2].i_i_f(integer(slot_value(o->v[1].p))) - * and o->v[2].i_i_f can be pulled out leaving a loop of ov2(integer(slot_value(o->v[1].p))); - */ - }} + for (; integer(stepper) < end; integer(stepper)++) + fi(o); + /* if fi = opt_i_i_s for example, -> o->v[2].i_i_f(integer(slot_value(o->v[1].p))) + * and o->v[2].i_i_f can be pulled out leaving a loop of ov2(integer(slot_value(o->v[1].p))); + */ + } else - { - for (; integer(stepper) < end; integer(stepper)++) - func(sc, car(code)); - }} + for (; integer(stepper) < end; integer(stepper)++) + func(sc, car(code)); + } clear_mutable_integer(stepper); } - else + else /* not safe_step */ { s7_int step; s7_pointer step_slot, end_slot; step_slot = let_dox_slot1(sc->curlet); end_slot = let_dox_slot2(sc->curlet); + step = integer(slot_value(step_slot)); + if (func == opt_cell_any_nr) { opt_info *o; s7_pointer (*fp)(opt_info *o); o = sc->opts[0]; fp = o->v[0].fp; - if (!opt_do_copy(sc, o, integer(slot_value(step_slot)), integer(slot_value(end_slot)))) + if (!opt_do_copy(sc, o, step, integer(slot_value(end_slot)))) { - do { - fp(o); + if ((step >= 0) && (integer(slot_value(end_slot)) < NUM_SMALL_INTS)) + while (step < integer(slot_value(end_slot))) + { + slot_set_value(step_slot, small_int(step)); + fp(o); + step = integer(slot_value(step_slot)) + 1; + } + else + while (step < integer(slot_value(end_slot))) + { + slot_set_value(step_slot, make_integer(sc, step)); + fp(o); + step = integer(slot_value(step_slot)) + 1; + }}} + else + { + if ((step >= 0) && (integer(slot_value(end_slot)) < NUM_SMALL_INTS)) + while (step < integer(slot_value(end_slot))) + { + slot_set_value(step_slot, small_int(step)); + func(sc, car(code)); step = integer(slot_value(step_slot)) + 1; + } + else + while (step < integer(slot_value(end_slot))) + { slot_set_value(step_slot, make_integer(sc, step)); - } while (step != integer(slot_value(end_slot))); - }} - else - do { - func(sc, car(code)); - step = integer(slot_value(step_slot)) + 1; - slot_set_value(step_slot, make_integer(sc, step)); - } while (step != integer(slot_value(end_slot))); - } + func(sc, car(code)); + step = integer(slot_value(step_slot)) + 1; + }}} sc->value = sc->T; sc->code = cdadr(scc); return(true); @@ -84401,13 +84207,12 @@ static bool opt_dotimes(s7_scheme *sc, s7_pointer code, s7_pointer scc, bool saf s7_int step; step_slot = let_dox_slot1(sc->curlet); end_slot = let_dox_slot2(sc->curlet); - do { - for (i = 0; i < body_len; i++) - body[i]->v[0].fd(body[i]); - step = integer(slot_value(step_slot)) + 1; - slot_set_value(step_slot, make_integer(sc, step)); - } while (step != integer(slot_value(end_slot))); - } + for (step = integer(slot_value(step_slot)); step < integer(slot_value(end_slot)); step = integer(slot_value(step_slot)) + 1) + { + slot_set_value(step_slot, make_integer(sc, step)); + for (i = 0; i < body_len; i++) + body[i]->v[0].fd(body[i]); + }} sc->value = sc->T; sc->code = cdadr(scc); return(true); @@ -84445,20 +84250,16 @@ static bool opt_dotimes(s7_scheme *sc, s7_pointer code, s7_pointer scc, bool saf s7_int step; step_slot = let_dox_slot1(sc->curlet); end_slot = let_dox_slot2(sc->curlet); - do { - for (i = 0; i < body_len; i++) - body[i]->v[0].fp(body[i]); - step = integer(slot_value(step_slot)) + 1; - slot_set_value(step_slot, make_integer(sc, step)); - } while (step != integer(slot_value(end_slot))); - } + for (step = integer(slot_value(step_slot)); step < integer(slot_value(end_slot)); step = integer(slot_value(step_slot)) + 1) + { + slot_set_value(step_slot, make_integer(sc, step)); + for (i = 0; i < body_len; i++) + body[i]->v[0].fp(body[i]); + }} sc->value = sc->T; sc->code = cdadr(scc); return(true); }} - /* (((i 0 (+ i 1))) ((= i 10) 'gad) (set! ctr (+ ctr 1)) (if (= i 1) (exit arg))) - * (((k j (+ k 1))) ((= k len2) obj) (set! (obj n) (seq2 k)) (set! n (+ n 1))) - */ return(false); } @@ -84585,14 +84386,12 @@ static goto_t do_let(s7_scheme *sc, s7_pointer step_slot, s7_pointer scc) vf7(obj5, k, amp_env * vf5(obj6, vib + (vf4(obj4) * vf6(obj7, vib)))); }} else - { - - for (k = numerator(stepper) + 1; k < end; k++) - { - integer(ip) = k; - set_real(xp, f1(first)); - f2(o); - }}} /* body_len == 1 and var_len == 1 */ + for (k = numerator(stepper) + 1; k < end; k++) + { + integer(ip) = k; + set_real(xp, f1(first)); + f2(o); + }} /* body_len == 1 and var_len == 1 */ else { if (var_len == 2) @@ -84600,7 +84399,6 @@ static goto_t do_let(s7_scheme *sc, s7_pointer step_slot, s7_pointer scc) s7_pointer s1, s2; s1 = let_slots(sc->curlet); s2 = next_slot(s1); - for (k = numerator(stepper); k < end; k++) { integer(ip) = k; @@ -84609,23 +84407,20 @@ static goto_t do_let(s7_scheme *sc, s7_pointer step_slot, s7_pointer scc) body[0]->v[0].fd(body[0]); }} /* body_len == 1 and var_len == 2 */ else - { - - for (k = numerator(stepper); k < end; k++) - { - int32_t n; - integer(ip) = k; - for (n = 0, p = let_slots(sc->curlet); tis_slot(p); n++, p = next_slot(p)) - set_real(slot_value(p), vars[n]->v[0].fd(vars[n])); - body[0]->v[0].fd(body[0]); - }}}} /* end body_len == 1 */ + for (k = numerator(stepper); k < end; k++) + { + int32_t n; + integer(ip) = k; + for (n = 0, p = let_slots(sc->curlet); tis_slot(p); n++, p = next_slot(p)) + set_real(slot_value(p), vars[n]->v[0].fd(vars[n])); + body[0]->v[0].fd(body[0]); + }}} /* end body_len == 1 */ else { if ((body_len == 2) && (var_len == 1)) { s7_pointer s1; s1 = let_slots(sc->curlet); - for (k = numerator(stepper); k < end; k++) { integer(ip) = k; @@ -84776,7 +84571,7 @@ static goto_t op_safe_do(s7_scheme *sc) * (let ((x 0)) (do ((i i (+ i 1))) ((= i 7)) (set! x (+ x i))) x) * but end might not be an integer -- need to catch this earlier. */ - s7_pointer end, init_val, end_val, code, form, old_let; + s7_pointer end, init_val, end_val, code, form; /* inits, if not >= opt_dotimes else safe_do_step */ form = sc->code; @@ -84807,21 +84602,18 @@ static goto_t op_safe_do(s7_scheme *sc) } if (is_symbol(end)) - let_set_dox_slot2(sc->curlet, symbol_to_slot(sc, end)); + let_set_dox_slot2(sc->curlet, lookup_slot_from(end, sc->curlet)); else let_set_dox_slot2(sc->curlet, make_slot(sc, caaar(code), end)); sc->args = let_dox_slot2(sc->curlet); /* the various safe steps assume sc->args is the end slot */ - old_let = sc->curlet; - if ((!is_unsafe_do(sc->code)) && - ((!is_optimized(caadr(code))) || - (opt1_cfunc(caadr(code)) != sc->geq_2))) + if (!is_unsafe_do(sc->code)) { + s7_pointer old_let; + old_let = sc->curlet; + sc->temp7 = old_let; if (opt_dotimes(sc, cddr(sc->code), sc->code, false)) return(goto_safe_do_end_clauses); - set_unsafe_do(sc->code); - /* opt_dotimes can change sc->curlet (indirectly via s7_optimize I think), but OP_SAFE_DO_STEP assumes dox1 is ok (above), so we can't go on here */ - if (sc->curlet != old_let) - return(goto_do_unchecked); + sc->curlet = old_let; /* apparently s7_optimize can step on sc->curlet? */ } if (is_null(cdddr(sc->code))) { @@ -84842,7 +84634,7 @@ static goto_t op_safe_do(s7_scheme *sc) s7_pointer val_slot, fx_p, step_val; endi = integer(slot_value(let_dox_slot2(sc->curlet))); - val_slot = symbol_to_slot(sc, cadr(body)); + val_slot = lookup_slot_from(cadr(body), sc->curlet); fx_p = cddr(body); step = integer(slot_value(step_slot)); slot_set_value(step_slot, step_val = make_mutable_integer(sc, step)); @@ -84867,6 +84659,7 @@ static goto_t op_dotimes_p(s7_scheme *sc) { s7_pointer end, code, init_val, end_val, slot, old_e; /* (do ... (set! args ...)) -- one line, syntactic */ + code = cdr(sc->code); init_val = fx_call(sc, cdaar(code)); sc->value = init_val; @@ -84875,12 +84668,12 @@ static goto_t op_dotimes_p(s7_scheme *sc) end = caddr(opt2_pair(code)); if (is_symbol(end)) { - slot = symbol_to_slot(sc, end); + slot = lookup_slot_from(end, sc->curlet); end_val = slot_value(slot); } else { - slot = make_slot(sc, caaar(code), end); + slot = make_slot(sc, make_symbol(sc, "_end_"), end); end_val = end; } @@ -84895,11 +84688,7 @@ static goto_t op_dotimes_p(s7_scheme *sc) sc->curlet = make_let_slowly(sc, sc->curlet); let_set_dox_slot1(sc->curlet, make_slot_2(sc, sc->curlet, caaar(code), init_val)); let_set_dox_slot2(sc->curlet, slot); - if (!is_symbol(end)) - { - slot_set_next(slot, let_slots(sc->curlet)); - let_set_slots(sc->curlet, slot); - } + set_car(sc->t2_1, slot_value(let_dox_slot1(sc->curlet))); set_car(sc->t2_2, slot_value(let_dox_slot2(sc->curlet))); if (is_true(sc, sc->value = c_call(caadr(code))(sc, sc->t2_1))) @@ -84997,7 +84786,7 @@ static goto_t op_do_init_1(s7_scheme *sc) static bool op_do_init(s7_scheme *sc) { if (is_multiple_value(sc->value)) /* (do ((i (values 1 2)))...) */ - eval_error_any(sc, sc->wrong_type_arg_symbol, "do: variable initial value can't be ~S", 38, cons(sc, sc->values_symbol, sc->value)); + eval_error_any(sc, sc->wrong_type_arg_symbol, "do: variable initial value can't be ~S", 38, set_ulist_1(sc, sc->values_symbol, sc->value)); return(op_do_init_1(sc) != goto_eval); } @@ -85162,8 +84951,7 @@ static goto_t op_read_s(s7_scheme *sc) sc->value = g_read(sc, list_1(sc, port)); return(goto_start); } - /* I guess the port_is_closed check is needed because we're going down a level below */ - if (port_is_closed(port)) + if (port_is_closed(port)) /* I guess the port_is_closed check is needed because we're going down a level below */ simple_wrong_type_argument_with_type(sc, sc->read_symbol, port, an_open_port_string); if (is_function_port(port)) @@ -85327,40 +85115,39 @@ static bool op_implicit_vector_set_4(s7_scheme *sc) return(false); } -static inline void op_increment_by_1(s7_scheme *sc) /* ([set!] ctr (+ ctr 1)) */ +static Inline void op_increment_by_1(s7_scheme *sc) /* ([set!] ctr (+ ctr 1)) */ { s7_pointer val, y; - y = symbol_to_slot(sc, cadr(sc->code)); + y = lookup_slot_from(cadr(sc->code), sc->curlet); if (!is_slot(y)) s7_error(sc, sc->unbound_variable_symbol, set_elist_3(sc, wrap_string(sc, "~S in ~S", 8), cadr(sc->code), sc->code)); val = slot_value(y); if (is_t_integer(val)) sc->value = make_integer(sc, integer(val) + 1); else - { - switch (type(val)) - { - case T_RATIO: - new_cell(sc, sc->value, T_RATIO); - numerator(sc->value) = numerator(val) + denominator(val); - denominator(sc->value) = denominator(val); - break; - - case T_REAL: - sc->value = make_real(sc, real(val) + 1.0); - break; - - case T_COMPLEX: - new_cell(sc, sc->value, T_COMPLEX); - set_real_part(sc->value, real_part(val) + 1.0); - set_imag_part(sc->value, imag_part(val)); - break; - - default: - sc->value = add_p_pp(sc, val, int_one); - break; - }} + switch (type(val)) + { + case T_RATIO: + new_cell(sc, sc->value, T_RATIO); + numerator(sc->value) = numerator(val) + denominator(val); + denominator(sc->value) = denominator(val); + break; + + case T_REAL: + sc->value = make_real(sc, real(val) + 1.0); + break; + + case T_COMPLEX: + new_cell(sc, sc->value, T_COMPLEX); + set_real_part(sc->value, real_part(val) + 1.0); + set_imag_part(sc->value, imag_part(val)); + break; + + default: + sc->value = add_p_pp(sc, val, int_one); + break; + } slot_set_value(y, sc->value); } @@ -85368,36 +85155,35 @@ static void op_decrement_by_1(s7_scheme *sc) /* ([set!] ctr (- ctr 1)) */ { s7_pointer val, y; - y = symbol_to_slot(sc, cadr(sc->code)); + y = lookup_slot_from(cadr(sc->code), sc->curlet); if (!is_slot(y)) s7_error(sc, sc->unbound_variable_symbol, set_elist_3(sc, wrap_string(sc, "~S in ~S", 8), cadr(sc->code), sc->code)); val = slot_value(y); if (is_t_integer(val)) sc->value = make_integer(sc, integer(val) - 1); /* increment (set!) returns the new value in sc->value */ else - { - switch (type(val)) - { - case T_RATIO: - new_cell(sc, sc->value, T_RATIO); - numerator(sc->value) = numerator(val) - denominator(val); - denominator(sc->value) = denominator(val); - break; - - case T_REAL: - sc->value = make_real(sc, real(val) - 1.0); - break; - - case T_COMPLEX: - new_cell(sc, sc->value, T_COMPLEX); - set_real_part(sc->value, real_part(val) - 1.0); - set_imag_part(sc->value, imag_part(val)); - break; - - default: - sc->value = g_subtract(sc, set_plist_2(sc, val, int_one)); - break; - }} + switch (type(val)) + { + case T_RATIO: + new_cell(sc, sc->value, T_RATIO); + numerator(sc->value) = numerator(val) - denominator(val); + denominator(sc->value) = denominator(val); + break; + + case T_REAL: + sc->value = make_real(sc, real(val) - 1.0); + break; + + case T_COMPLEX: + new_cell(sc, sc->value, T_COMPLEX); + set_real_part(sc->value, real_part(val) - 1.0); + set_imag_part(sc->value, imag_part(val)); + break; + + default: + sc->value = g_subtract(sc, set_plist_2(sc, val, int_one)); + break; + } slot_set_value(y, sc->value); } @@ -85409,7 +85195,7 @@ static void op_set_pws(s7_scheme *sc) obj = caar(code); if (is_symbol(obj)) { - obj = symbol_to_slot(sc, obj); + obj = lookup_slot_from(obj, sc->curlet); if (is_slot(obj)) obj = slot_value(obj); else s7_error(sc, sc->syntax_error_symbol, set_elist_3(sc, no_setter_string, caar(code), sc->prepackaged_type_names[type(obj)])); @@ -85611,7 +85397,6 @@ static Inline void apply_lambda(s7_scheme *sc) /* -------- n { /* load up the current args into the ((args) (lambda)) layout [via the current environment] */ s7_pointer x, z, e, sym, slot, last_slot; uint64_t id; - /* fprintf(stderr, "%s[%d]: %s\n", __func__, __LINE__, display(sc->code)); */ e = sc->curlet; id = let_id(e); @@ -85891,7 +85676,7 @@ static bool op_lambda_star_default(s7_scheme *sc) { /* sc->args is the current let slots position, sc->value is the default expression's value */ if (is_multiple_value(sc->value)) - eval_error(sc, "lambda*: argument default value can't be ~S", 43, cons(sc, sc->values_symbol, sc->value)); + eval_error(sc, "lambda*: argument default value can't be ~S", 43, set_ulist_1(sc, sc->values_symbol, sc->value)); slot_set_value(sc->args, sc->value); sc->args = next_slot(sc->args); if (lambda_star_default(sc) == goto_eval) return(true); @@ -85972,12 +85757,11 @@ static bool apply_unsafe_closure_star_1(s7_scheme *sc) /* make_slot_1(sc, sc->curlet, car_z, sc->F); */ add_slot(sc, sc->curlet, car_z, sc->F); else - { - if (car_z == sc->key_rest_symbol) /* else it's :allow-other-keys? */ - { - set_is_rest_slot(make_slot_2(sc, sc->curlet, cadr(z), sc->nil)); - z = cdr(z); - }}}} + if (car_z == sc->key_rest_symbol) /* else it's :allow-other-keys? */ + { + set_is_rest_slot(make_slot_2(sc, sc->curlet, cadr(z), sc->nil)); + z = cdr(z); + }}} if (is_symbol(z)) set_is_rest_slot(make_slot_2(sc, sc->curlet, z, sc->nil)); /* set up rest arg */ let_set_slots(sc->curlet, reverse_slots(sc, let_slots(sc->curlet))); @@ -85999,12 +85783,11 @@ static void apply_macro_star_1(s7_scheme *sc) if (!is_keyword(par)) make_slot_2(sc, sc->curlet, par, sc->F); else - { - if (par == sc->key_rest_symbol) - { - set_is_rest_slot(make_slot_2(sc, sc->curlet, cadr(p), sc->nil)); - p = cdr(p); - }}}} + if (par == sc->key_rest_symbol) + { + set_is_rest_slot(make_slot_2(sc, sc->curlet, cadr(p), sc->nil)); + p = cdr(p); + }}} if (is_symbol(p)) set_is_rest_slot(make_slot_2(sc, sc->curlet, p, sc->nil)); let_set_slots(sc->curlet, reverse_slots(sc, let_slots(sc->curlet))); @@ -86277,7 +86060,7 @@ static goto_t op_define1(s7_scheme *sc) if (is_constant_symbol(sc, sc->code)) /* (define pi 3) or (define (pi a) a) */ { s7_pointer x; - x = (is_slot(global_slot(sc->code))) ? global_slot(sc->code) : symbol_to_slot(sc, sc->code); + x = (is_slot(global_slot(sc->code))) ? global_slot(sc->code) : lookup_slot_from(sc->code, sc->curlet); /* local_slot can be free even if sc->code is immutable (local constant now defunct) */ if (!((is_slot(x)) && @@ -86288,7 +86071,7 @@ static goto_t op_define1(s7_scheme *sc) if (symbol_has_setter(sc->code)) { s7_pointer x; - x = symbol_to_slot(sc, sc->code); + x = lookup_slot_from(sc->code, sc->curlet); if ((is_slot(x)) && (slot_has_setter(x))) { @@ -86381,7 +86164,7 @@ static void op_define_with_setter(s7_scheme *sc) if (slot_symbol(slot) == code) { if (is_immutable(slot)) - eval_error(sc, "define ~S: but it is immutable", 30, code); + eval_error(sc, "define ~S, but it is immutable", 30, code); slot_set_value(slot, new_func); symbol_set_local_slot(code, sc->let_number, slot); set_local(code); @@ -86408,7 +86191,7 @@ static void op_define_with_setter(s7_scheme *sc) old_value = slot_value(global_slot(code)); if ((type(old_value) != type(new_func)) || (!s7_is_equivalent(sc, old_value, new_func))) /* if value is unchanged, just ignore this (re)definition */ - eval_error(sc, "define ~S: but it is immutable", 30, old_symbol); + eval_error(sc, "define ~S, but it is immutable", 30, old_symbol); } s7_make_slot(sc, sc->curlet, code, new_func); } @@ -86427,7 +86210,7 @@ static void op_define_with_setter(s7_scheme *sc) old_value = slot_value(lx); if ((type(old_value) != type(sc->value)) || (!s7_is_equivalent(sc, old_value, sc->value))) /* if value is unchanged, just ignore this (re)definition */ - eval_error(sc, "define ~S: but it is immutable", 30, old_symbol); + eval_error(sc, "define ~S, but it is immutable", 30, old_symbol); } slot_set_value_with_hook(lx, sc->value); } @@ -86612,14 +86395,12 @@ static void op_safe_closure_ssa(s7_scheme *sc) static void op_safe_closure_saa(s7_scheme *sc) { - s7_pointer args, z, f, arg2; + s7_pointer args, f, arg2; f = opt1_lambda(sc->code); args = cddr(sc->code); arg2 = lookup(sc, cadr(sc->code)); sc->code = fx_call(sc, args); - args = cdr(args); - z = fx_call(sc, args); - sc->curlet = update_let_with_three_slots(sc, closure_let(f), arg2, sc->code, z); + sc->curlet = update_let_with_three_slots(sc, closure_let(f), arg2, sc->code, fx_call(sc, cdr(args))); sc->code = T_Pair(closure_body(f)); } @@ -86778,15 +86559,6 @@ static void op_safe_closure_pp_1(s7_scheme *sc) sc->code = caddr(sc->code); } -static inline void make_let_with_three_slots(s7_scheme *sc, s7_pointer func, s7_pointer val1, s7_pointer val2, s7_pointer val3) -{ - s7_pointer last_slot, cargs; - cargs = closure_args(func); - sc->curlet = make_let_with_two_slots(sc, closure_let(func), car(cargs), val1, cadr(cargs), val2); - last_slot = next_slot(let_slots(sc->curlet)); - add_slot_at_end(sc, let_id(sc->curlet), last_slot, caddr(cargs), val3); -} - static void op_any_closure_3p(s7_scheme *sc) { s7_pointer p; @@ -86798,7 +86570,7 @@ static void op_any_closure_3p(s7_scheme *sc) if (has_fx(p)) { s7_pointer val; - val = sc->args; + val = sc->args; /* protect from fx_call? */ sc->args = cons(sc, val, fx_call(sc, p)); push_stack_direct(sc, OP_ANY_CLOSURE_3P_3); sc->code = cadr(p); @@ -86869,37 +86641,12 @@ static void op_any_closure_3p_3(s7_scheme *sc) sc->curlet = update_let_with_three_slots(sc, closure_let(func), car(p), cdr(p), sc->value); else make_let_with_three_slots(sc, func, car(p), cdr(p), sc->value); free_cell(sc, p); +#if S7_DEBUGGING sc->args = sc->nil; /* needed if s7_debugging */ +#endif sc->code = T_Pair(closure_body(func)); } -static s7_pointer update_let_with_four_slots(s7_scheme *sc, s7_pointer let, s7_pointer val1, s7_pointer val2, s7_pointer val3, s7_pointer val4) -{ - s7_pointer x; - uint64_t id; - - id = ++sc->let_number; - let_set_id(let, id); - x = let_slots(let); - update_slot(x, val1, id); - x = next_slot(x); - update_slot(x, val2, id); - x = next_slot(x); - update_slot(x, val3, id); - x = next_slot(x); - update_slot(x, val4, id); - return(let); -} - -static void make_let_with_four_slots(s7_scheme *sc, s7_pointer func, s7_pointer val1, s7_pointer val2, s7_pointer val3, s7_pointer val4) -{ - s7_pointer last_slot; - sc->curlet = make_let_with_two_slots(sc, closure_let(func), car(closure_args(func)), val1, cadr(closure_args(func)), val2); - last_slot = next_slot(let_slots(sc->curlet)); - last_slot = add_slot_at_end(sc, let_id(sc->curlet), last_slot, caddr(closure_args(func)), val3); - add_slot_at_end(sc, let_id(sc->curlet), last_slot, cadddr(closure_args(func)), val4); -} - static void op_any_closure_4p(s7_scheme *sc) { s7_pointer p; @@ -87185,22 +86932,20 @@ static void op_safe_closure_aa(s7_scheme *sc) s7_pointer p, f; p = cdr(sc->code); f = opt1_lambda(sc->code); - sc->code = fx_call(sc, cdr(p)); - sc->value = fx_call(sc, p); /* fx_call can affect sc->value, but not sc->code, I think */ - sc->curlet = update_let_with_two_slots(sc, closure_let(f), sc->value, sc->code); + sc->code = fx_call(sc, cdr(p)); /* fx_call can affect sc->value, but not sc->code, I think */ + sc->curlet = update_let_with_two_slots(sc, closure_let(f), fx_call(sc, p), sc->code); p = T_Pair(closure_body(f)); push_stack_no_args(sc, sc->begin_op, cdr(p)); sc->code = car(p); } -static void op_safe_closure_aa_o(s7_scheme *sc) +static inline void op_safe_closure_aa_o(s7_scheme *sc) { s7_pointer p, f; p = cdr(sc->code); f = opt1_lambda(sc->code); sc->code = fx_call(sc, cdr(p)); - sc->value = fx_call(sc, p); - sc->curlet = update_let_with_two_slots(sc, closure_let(f), sc->value, sc->code); + sc->curlet = update_let_with_two_slots(sc, closure_let(f), fx_call(sc, p), sc->code); sc->code = car(closure_body(f)); } @@ -87478,12 +87223,12 @@ static s7_pointer g_report_missed_calls(s7_scheme *sc, s7_pointer args) return(sc->F); } -static void tick_tc_rec(s7_scheme *sc, int op) +static void tick_tc(s7_scheme *sc, int op) { sc->tc_rec_calls[op]++; } #else -#define tick_tc_rec(Sc, Op) +#define tick_tc(Sc, Op) #endif static bool op_tc_case_la(s7_scheme *sc, s7_pointer code) @@ -87540,7 +87285,7 @@ static bool op_tc_case_la(s7_scheme *sc, s7_pointer code) static s7_pointer fx_tc_case_la(s7_scheme *sc, s7_pointer arg) { - tick_tc_rec(sc, OP_TC_CASE_LA); + tick_tc(sc, OP_TC_CASE_LA); op_tc_case_la(sc, arg); return(sc->value); } @@ -87577,7 +87322,7 @@ static void op_tc_and_a_or_a_la(s7_scheme *sc, s7_pointer code) static s7_pointer fx_tc_and_a_or_a_la(s7_scheme *sc, s7_pointer arg) { - tick_tc_rec(sc, OP_TC_AND_A_OR_A_LA); + tick_tc(sc, OP_TC_AND_A_OR_A_LA); op_tc_and_a_or_a_la(sc, arg); return(sc->value); } @@ -87603,7 +87348,7 @@ static void op_tc_or_a_and_a_la(s7_scheme *sc, s7_pointer code) static s7_pointer fx_tc_or_a_and_a_la(s7_scheme *sc, s7_pointer arg) { - tick_tc_rec(sc, OP_TC_OR_A_AND_A_LA); + tick_tc(sc, OP_TC_OR_A_AND_A_LA); op_tc_or_a_and_a_la(sc, arg); return(sc->value); } @@ -87631,7 +87376,7 @@ static void op_tc_and_a_or_a_a_la(s7_scheme *sc, s7_pointer code) static s7_pointer fx_tc_and_a_or_a_a_la(s7_scheme *sc, s7_pointer arg) { - tick_tc_rec(sc, OP_TC_AND_A_OR_A_A_LA); + tick_tc(sc, OP_TC_AND_A_OR_A_A_LA); op_tc_and_a_or_a_a_la(sc, arg); return(sc->value); } @@ -87659,7 +87404,7 @@ static void op_tc_or_a_and_a_a_la(s7_scheme *sc, s7_pointer code) static s7_pointer fx_tc_or_a_and_a_a_la(s7_scheme *sc, s7_pointer arg) { - tick_tc_rec(sc, OP_TC_OR_A_AND_A_A_LA); + tick_tc(sc, OP_TC_OR_A_AND_A_A_LA); op_tc_or_a_and_a_a_la(sc, arg); return(sc->value); } @@ -87689,7 +87434,7 @@ static void op_tc_or_a_a_and_a_a_la(s7_scheme *sc, s7_pointer code) static s7_pointer fx_tc_or_a_a_and_a_a_la(s7_scheme *sc, s7_pointer arg) { - tick_tc_rec(sc, OP_TC_OR_A_A_AND_A_A_LA); + tick_tc(sc, OP_TC_OR_A_A_AND_A_A_LA); op_tc_or_a_a_and_a_a_la(sc, arg); return(sc->value); } @@ -87733,7 +87478,7 @@ static void op_tc_and_a_or_a_laa(s7_scheme *sc, s7_pointer code) static s7_pointer fx_tc_and_a_or_a_laa(s7_scheme *sc, s7_pointer arg) { - tick_tc_rec(sc, OP_TC_AND_A_OR_A_LAA); + tick_tc(sc, OP_TC_AND_A_OR_A_LAA); op_tc_and_a_or_a_laa(sc, arg); sc->rec_p1 = sc->F; return(sc->value); @@ -87763,7 +87508,7 @@ static void op_tc_or_a_and_a_laa(s7_scheme *sc, s7_pointer code) static s7_pointer fx_tc_or_a_and_a_laa(s7_scheme *sc, s7_pointer arg) { - tick_tc_rec(sc, OP_TC_OR_A_AND_A_LAA); + tick_tc(sc, OP_TC_OR_A_AND_A_LAA); op_tc_or_a_and_a_laa(sc, arg); sc->rec_p1 = sc->F; return(sc->value); @@ -87814,19 +87559,19 @@ static void op_tc_or_a_and_a_a_l3a(s7_scheme *sc, s7_pointer code) static s7_pointer fx_tc_or_a_and_a_a_l3a(s7_scheme *sc, s7_pointer arg) { - tick_tc_rec(sc, OP_TC_OR_A_AND_A_A_L3A); + tick_tc(sc, OP_TC_OR_A_AND_A_A_L3A); op_tc_or_a_and_a_a_l3a(sc, arg); sc->rec_p1 = sc->F; sc->rec_p2 = sc->F; return(sc->value); } -static bool op_tc_if_a_z_la(s7_scheme *sc, s7_pointer code) +static bool op_tc_if_a_z_la(s7_scheme *sc, s7_pointer code, bool cond) { s7_pointer if_test, if_true, la, la_slot; - if_test = cdr(code); + if_test = (cond) ? cadr(code) : cdr(code); if_true = cdr(if_test); - la = cdadr(if_true); + la = (cond) ? cdr(cadr(caddr(code))) : cdadr(if_true); la_slot = let_slots(sc->curlet); if (is_t_integer(slot_value(la_slot))) @@ -87850,19 +87595,25 @@ static bool op_tc_if_a_z_la(s7_scheme *sc, s7_pointer code) static s7_pointer fx_tc_if_a_z_la(s7_scheme *sc, s7_pointer arg) { - tick_tc_rec(sc, OP_TC_IF_A_Z_LA); - op_tc_if_a_z_la(sc, arg); + tick_tc(sc, OP_TC_IF_A_Z_LA); + op_tc_if_a_z_la(sc, arg, false); return(sc->value); } -static bool op_tc_if_a_la_z(s7_scheme *sc, s7_pointer code) +static s7_pointer fx_tc_cond_a_z_la(s7_scheme *sc, s7_pointer arg) +{ + tick_tc(sc, OP_TC_COND_A_Z_LA); + op_tc_if_a_z_la(sc, arg, true); + return(sc->value); +} + +static bool op_tc_if_a_la_z(s7_scheme *sc, s7_pointer code, bool cond) { s7_pointer if_test, if_false, la, la_slot; - if_test = cdr(code); - if_false = cddr(if_test); + if_test = (cond) ? cadr(code): cdr(code); + if_false = (cond) ? cdr(caddr(code)) : cddr(if_test); la = cdadr(if_test); la_slot = let_slots(sc->curlet); - if (is_t_integer(slot_value(la_slot))) { sc->pc = 0; @@ -87884,18 +87635,36 @@ static bool op_tc_if_a_la_z(s7_scheme *sc, s7_pointer code) static s7_pointer fx_tc_if_a_la_z(s7_scheme *sc, s7_pointer arg) { - tick_tc_rec(sc, OP_TC_IF_A_LA_Z); - op_tc_if_a_la_z(sc, arg); + tick_tc(sc, OP_TC_IF_A_LA_Z); + op_tc_if_a_la_z(sc, arg, false); return(sc->value); } -static bool op_tc_if_a_z_laa(s7_scheme *sc, s7_pointer code, bool z_first) +static s7_pointer fx_tc_cond_a_la_z(s7_scheme *sc, s7_pointer arg) +{ + tick_tc(sc, OP_TC_COND_A_LA_Z); + op_tc_if_a_la_z(sc, arg, true); + return(sc->value); +} + +typedef enum {TC_IF, TC_COND, TC_AND} tc_choice_t; + +static bool op_tc_if_a_z_laa(s7_scheme *sc, s7_pointer code, bool z_first, tc_choice_t cond) { s7_pointer if_test, if_z, la, laa, la_slot, laa_slot; s7_function tf; - if_test = cdr(code); - if_z = (z_first) ? cdr(if_test) : cddr(if_test); - la = (z_first) ? cdaddr(if_test) : cdadr(if_test); + if (cond == TC_IF) + { + if_test = cdr(code); + if_z = (z_first) ? cdr(if_test) : cddr(if_test); + la = (z_first) ? cdaddr(if_test) : cdadr(if_test); + } + else + { + if_test = cadr(code); + if_z = (z_first) ? cdr(if_test) : cdr(caddr(code)); + la = (z_first) ? cdr(cadr(caddr(code))) : cdadr(if_test); + } laa = cdr(la); la_slot = let_slots(sc->curlet); laa_slot = next_slot(la_slot); @@ -88005,7 +87774,6 @@ static bool op_tc_if_a_z_laa(s7_scheme *sc, s7_pointer code, bool z_first) set_no_bool_opt(code); } #endif - /* can't optimize fx_add_u_car_t here for trec because the list might contain anything */ tf = c_callee(if_test); if_test = car(if_test); if (z_first) @@ -88043,16 +87811,32 @@ static bool op_tc_if_a_z_laa(s7_scheme *sc, s7_pointer code, bool z_first) static s7_pointer fx_tc_if_a_z_laa(s7_scheme *sc, s7_pointer arg) { - tick_tc_rec(sc, OP_TC_IF_A_Z_LAA); - op_tc_if_a_z_laa(sc, arg, true); + tick_tc(sc, OP_TC_IF_A_Z_LAA); + op_tc_if_a_z_laa(sc, arg, true, TC_IF); + sc->rec_p1 = sc->F; + return(sc->value); +} + +static s7_pointer fx_tc_cond_a_z_laa(s7_scheme *sc, s7_pointer arg) +{ + tick_tc(sc, OP_TC_COND_A_Z_LAA); + op_tc_if_a_z_laa(sc, arg, true, TC_COND); sc->rec_p1 = sc->F; return(sc->value); } static s7_pointer fx_tc_if_a_laa_z(s7_scheme *sc, s7_pointer arg) { - tick_tc_rec(sc, OP_TC_IF_A_LAA_Z); - op_tc_if_a_z_laa(sc, arg, false); + tick_tc(sc, OP_TC_IF_A_LAA_Z); + op_tc_if_a_z_laa(sc, arg, false, TC_IF); + sc->rec_p1 = sc->F; + return(sc->value); +} + +static s7_pointer fx_tc_cond_a_laa_z(s7_scheme *sc, s7_pointer arg) +{ + tick_tc(sc, OP_TC_COND_A_LAA_Z); + op_tc_if_a_z_laa(sc, arg, false, TC_COND); sc->rec_p1 = sc->F; return(sc->value); } @@ -88084,7 +87868,7 @@ static bool op_tc_if_a_z_l3a(s7_scheme *sc, s7_pointer code, bool z_first) static s7_pointer fx_tc_if_a_z_l3a(s7_scheme *sc, s7_pointer arg) { - tick_tc_rec(sc, OP_TC_IF_A_Z_L3A); + tick_tc(sc, OP_TC_IF_A_Z_L3A); op_tc_if_a_z_l3a(sc, arg, true); sc->rec_p1 = sc->F; sc->rec_p2 = sc->F; @@ -88093,15 +87877,13 @@ static s7_pointer fx_tc_if_a_z_l3a(s7_scheme *sc, s7_pointer arg) static s7_pointer fx_tc_if_a_l3a_z(s7_scheme *sc, s7_pointer arg) { - tick_tc_rec(sc, OP_TC_IF_A_L3A_Z); + tick_tc(sc, OP_TC_IF_A_L3A_Z); op_tc_if_a_z_l3a(sc, arg, false); sc->rec_p1 = sc->F; sc->rec_p2 = sc->F; return(sc->value); } -typedef enum {TC_IF, TC_COND, TC_AND} tc_choice_t; - static bool op_tc_if_a_z_if_a_z_la(s7_scheme *sc, s7_pointer code, bool z_first, tc_choice_t cond) { s7_pointer if_test, if_true, if_false, f_test, f_z, la, la_slot, endp; @@ -88173,42 +87955,42 @@ static bool op_tc_if_a_z_if_a_z_la(s7_scheme *sc, s7_pointer code, bool z_first, static s7_pointer fx_tc_if_a_z_if_a_z_la(s7_scheme *sc, s7_pointer arg) { - tick_tc_rec(sc, OP_TC_IF_A_Z_IF_A_Z_LA); + tick_tc(sc, OP_TC_IF_A_Z_IF_A_Z_LA); op_tc_if_a_z_if_a_z_la(sc, arg, true, TC_IF); return(sc->value); } static s7_pointer fx_tc_if_a_z_if_a_la_z(s7_scheme *sc, s7_pointer arg) { - tick_tc_rec(sc, OP_TC_IF_A_Z_IF_A_LA_Z); + tick_tc(sc, OP_TC_IF_A_Z_IF_A_LA_Z); op_tc_if_a_z_if_a_z_la(sc, arg, false, TC_IF); return(sc->value); } static s7_pointer fx_tc_cond_a_z_a_z_la(s7_scheme *sc, s7_pointer arg) { - tick_tc_rec(sc, OP_TC_COND_A_Z_A_Z_LA); + tick_tc(sc, OP_TC_COND_A_Z_A_Z_LA); op_tc_if_a_z_if_a_z_la(sc, arg, true, TC_COND); return(sc->value); } static s7_pointer fx_tc_cond_a_z_a_la_z(s7_scheme *sc, s7_pointer arg) { - tick_tc_rec(sc, OP_TC_COND_A_Z_A_LA_Z); + tick_tc(sc, OP_TC_COND_A_Z_A_LA_Z); op_tc_if_a_z_if_a_z_la(sc, arg, false, TC_COND); return(sc->value); } static s7_pointer fx_tc_and_a_if_a_z_la(s7_scheme *sc, s7_pointer arg) { - tick_tc_rec(sc, OP_TC_AND_A_IF_A_Z_LA); + tick_tc(sc, OP_TC_AND_A_IF_A_Z_LA); op_tc_if_a_z_if_a_z_la(sc, arg, true, TC_AND); return(sc->value); } static s7_pointer fx_tc_and_a_if_a_la_z(s7_scheme *sc, s7_pointer arg) { - tick_tc_rec(sc, OP_TC_AND_A_IF_A_LA_Z); + tick_tc(sc, OP_TC_AND_A_IF_A_LA_Z); op_tc_if_a_z_if_a_z_la(sc, arg, false, TC_AND); return(sc->value); } @@ -88264,7 +88046,7 @@ static bool op_tc_if_a_z_if_a_z_laa(s7_scheme *sc, bool cond, s7_pointer code) static s7_pointer fx_tc_if_a_z_if_a_z_laa(s7_scheme *sc, s7_pointer arg) { - tick_tc_rec(sc, OP_TC_IF_A_Z_IF_A_Z_LAA); + tick_tc(sc, OP_TC_IF_A_Z_IF_A_Z_LAA); op_tc_if_a_z_if_a_z_laa(sc, false, arg); sc->rec_p1 = sc->F; return(sc->value); @@ -88272,7 +88054,7 @@ static s7_pointer fx_tc_if_a_z_if_a_z_laa(s7_scheme *sc, s7_pointer arg) static s7_pointer fx_tc_cond_a_z_a_z_laa(s7_scheme *sc, s7_pointer arg) { - tick_tc_rec(sc, OP_TC_COND_A_Z_A_Z_LAA); + tick_tc(sc, OP_TC_COND_A_Z_A_Z_LAA); op_tc_if_a_z_if_a_z_laa(sc, true, arg); sc->rec_p1 = sc->F; return(sc->value); @@ -88304,7 +88086,7 @@ static bool op_tc_if_a_z_if_a_laa_z(s7_scheme *sc, bool cond, s7_pointer code) static s7_pointer fx_tc_if_a_z_if_a_laa_z(s7_scheme *sc, s7_pointer arg) { - tick_tc_rec(sc, OP_TC_IF_A_Z_IF_A_LAA_Z); + tick_tc(sc, OP_TC_IF_A_Z_IF_A_LAA_Z); op_tc_if_a_z_if_a_laa_z(sc, false, arg); sc->rec_p1 = sc->F; return(sc->value); @@ -88312,7 +88094,7 @@ static s7_pointer fx_tc_if_a_z_if_a_laa_z(s7_scheme *sc, s7_pointer arg) static s7_pointer fx_tc_cond_a_z_a_laa_z(s7_scheme *sc, s7_pointer arg) { - tick_tc_rec(sc, OP_TC_COND_A_Z_A_LAA_Z); + tick_tc(sc, OP_TC_COND_A_Z_A_LAA_Z); op_tc_if_a_z_if_a_laa_z(sc, true, arg); sc->rec_p1 = sc->F; return(sc->value); @@ -88360,13 +88142,56 @@ static bool op_tc_if_a_z_if_a_l3a_l3a(s7_scheme *sc, s7_pointer code) static s7_pointer fx_tc_if_a_z_if_a_l3a_l3a(s7_scheme *sc, s7_pointer arg) { - tick_tc_rec(sc, OP_TC_IF_A_Z_IF_A_L3A_L3A); + tick_tc(sc, OP_TC_IF_A_Z_IF_A_L3A_L3A); op_tc_if_a_z_if_a_l3a_l3a(sc, arg); sc->rec_p1 = sc->F; sc->rec_p2 = sc->F; return(sc->value); } +static bool op_tc_let_if_a_z_la(s7_scheme *sc, s7_pointer code) +{ + s7_pointer body, if_test, if_true, if_false, la, la_slot, let_slot, let_var, outer_let, inner_let; + let_var = caadr(code); + body = caddr(code); + outer_let = sc->curlet; + sc->curlet = make_let_with_slot(sc, sc->curlet, car(let_var), fx_call(sc, cdr(let_var))); + inner_let = sc->curlet; + push_stack_no_let_no_code(sc, OP_GC_PROTECT, inner_let); + let_slot = let_slots(sc->curlet); + let_var = cdr(let_var); + + if_test = cdr(body); + if_true = cddr(body); + if_false = cadddr(body); + + la = cdr(if_false); + la_slot = let_slots(outer_let); + + while (fx_call(sc, if_test) == sc->F) + { + slot_set_value(la_slot, fx_call(sc, la)); + sc->curlet = outer_let; + slot_set_value(let_slot, fx_call(sc, let_var)); + sc->curlet = inner_let; + } + unstack(sc); + if (op_tc_z(sc, if_true)) + { + free_cell(sc, let_slots(inner_let)); + free_cell(sc, inner_let); + return(true); + } + return(false); +} + +static s7_pointer fx_tc_let_if_a_z_la(s7_scheme *sc, s7_pointer arg) +{ + tick_tc(sc, OP_TC_LET_IF_A_Z_LA); + op_tc_let_if_a_z_la(sc, arg); + return(sc->value); +} + static bool op_tc_let_if_a_z_laa(s7_scheme *sc, s7_pointer code) { s7_pointer body, if_test, if_true, if_false, la, la_slot, let_slot, laa, laa_slot, let_var, outer_let, inner_let; @@ -88384,7 +88209,7 @@ static bool op_tc_let_if_a_z_laa(s7_scheme *sc, s7_pointer code) if_false = cadddr(body); la = cdr(if_false); - la_slot = let_slots(let_outlet(sc->curlet)); + la_slot = let_slots(outer_let); laa = cddr(if_false); laa_slot = next_slot(la_slot); #if (!WITH_GMP) @@ -88454,7 +88279,7 @@ static bool op_tc_let_if_a_z_laa(s7_scheme *sc, s7_pointer code) static s7_pointer fx_tc_let_if_a_z_laa(s7_scheme *sc, s7_pointer arg) { - tick_tc_rec(sc, OP_TC_LET_IF_A_Z_LAA); + tick_tc(sc, OP_TC_LET_IF_A_Z_LAA); op_tc_let_if_a_z_laa(sc, arg); sc->rec_p1 = sc->F; return(sc->value); @@ -88524,7 +88349,7 @@ static void op_tc_let_when_laa(s7_scheme *sc, bool when, s7_pointer code) else { s7_pointer la_slot, laa_slot; - la_slot = let_slots(let_outlet(sc->curlet)); + la_slot = let_slots(outer_let); laa_slot = next_slot(la_slot); while (true) { @@ -88547,7 +88372,7 @@ static void op_tc_let_when_laa(s7_scheme *sc, bool when, s7_pointer code) static s7_pointer fx_tc_let_when_laa(s7_scheme *sc, s7_pointer arg) { - tick_tc_rec(sc, OP_TC_LET_WHEN_LAA); + tick_tc(sc, OP_TC_LET_WHEN_LAA); op_tc_let_when_laa(sc, true, arg); sc->rec_p1 = sc->F; return(sc->value); @@ -88555,7 +88380,7 @@ static s7_pointer fx_tc_let_when_laa(s7_scheme *sc, s7_pointer arg) static s7_pointer fx_tc_let_unless_laa(s7_scheme *sc, s7_pointer arg) { - tick_tc_rec(sc, OP_TC_LET_WHEN_LAA); + tick_tc(sc, OP_TC_LET_WHEN_LAA); op_tc_let_when_laa(sc, false, arg); sc->rec_p1 = sc->F; return(sc->value); @@ -88583,7 +88408,7 @@ static bool op_tc_if_a_z_let_if_a_z_laa(s7_scheme *sc, s7_pointer code) slot = make_slot(sc, caar(let_vars), sc->F); slot_set_next(slot, slot_end(sc)); let_set_slots(inner_let, slot); - symbol_set_local_slot(caar(let_vars), let_id(inner_let), slot); + symbol_set_local_slot_unincremented(caar(let_vars), let_id(inner_let), slot); for (var = cdr(let_vars); is_pair(var); var = cdr(var)) slot = add_slot_at_end(sc, let_id(inner_let), slot, caar(var), sc->F); @@ -88723,7 +88548,7 @@ static bool op_tc_let_cond(s7_scheme *sc, s7_pointer code) static s7_pointer fx_tc_let_cond(s7_scheme *sc, s7_pointer arg) { - tick_tc_rec(sc, OP_TC_LET_COND); + tick_tc(sc, OP_TC_LET_COND); op_tc_let_cond(sc, arg); return(sc->value); } @@ -88760,7 +88585,7 @@ static bool op_tc_cond_a_z_a_laa_laa(s7_scheme *sc, s7_pointer code) static s7_pointer fx_tc_cond_a_z_a_laa_laa(s7_scheme *sc, s7_pointer arg) { - tick_tc_rec(sc, OP_TC_COND_A_Z_A_LAA_LAA); + tick_tc(sc, OP_TC_COND_A_Z_A_LAA_LAA); op_tc_cond_a_z_a_laa_laa(sc, arg); sc->rec_p1 = sc->F; return(sc->value); @@ -88902,7 +88727,7 @@ static opt_pid_t opinit_if_a_a_opa_laq(s7_scheme *sc, bool a_op, bool la_op, s7_ if ((is_symbol(c_op)) && ((is_global(c_op)) || ((is_slot(global_slot(c_op))) && - (symbol_to_slot(sc, c_op) == global_slot(c_op))))) + (lookup_slot_from(c_op, sc->curlet) == global_slot(c_op))))) { s7_pointer s_func, slot; s_func = slot_value(global_slot(c_op)); @@ -89030,7 +88855,7 @@ static s7_pointer oprec_if_a_opla_aq_a(s7_scheme *sc) static void wrap_recur_if_a_a_opa_laq(s7_scheme *sc, bool a_op, bool la_op) { opt_pid_t choice; - tick_tc_rec(sc, sc->cur_op); + tick_tc(sc, sc->cur_op); choice = opinit_if_a_a_opa_laq(sc, a_op, la_op, sc->code); if (choice == OPT_INT) sc->value = make_integer(sc, (a_op) ? oprec_i_if_a_a_opa_laq(sc) : oprec_i_if_a_opa_laq_a(sc)); @@ -89046,7 +88871,7 @@ static void wrap_recur_if_a_a_opa_laq(s7_scheme *sc, bool a_op, bool la_op) static s7_pointer fx_recur_if_a_a_opa_laq(s7_scheme *sc, s7_pointer arg) { - tick_tc_rec(sc, OP_RECUR_IF_A_A_opA_LAq); + tick_tc(sc, OP_RECUR_IF_A_A_opA_LAq); if (opinit_if_a_a_opa_laq(sc, true, true, arg) == OPT_INT) sc->value = make_integer(sc, oprec_i_if_a_a_opa_laq(sc)); else @@ -89060,7 +88885,7 @@ static s7_pointer fx_recur_if_a_a_opa_laq(s7_scheme *sc, s7_pointer arg) static s7_pointer fx_recur_if_a_opa_laq_a(s7_scheme *sc, s7_pointer arg) { - tick_tc_rec(sc, OP_RECUR_IF_A_opA_LAq_A); + tick_tc(sc, OP_RECUR_IF_A_opA_LAq_A); if (opinit_if_a_a_opa_laq(sc, false, true, arg) == OPT_INT) sc->value = make_integer(sc, oprec_i_if_a_opa_laq_a(sc)); else @@ -89230,7 +89055,7 @@ static opt_pid_t opinit_if_a_a_opla_laq(s7_scheme *sc, bool a_op) if ((is_symbol(c_op)) && ((is_global(c_op)) || ((is_slot(global_slot(c_op))) && - (symbol_to_slot(sc, c_op) == global_slot(c_op))))) + (lookup_slot_from(c_op, sc->curlet) == global_slot(c_op))))) { s7_pointer s_func, slot; s_func = slot_value(global_slot(c_op)); @@ -89426,7 +89251,7 @@ static s7_pointer oprec_if_a_opla_laq_a(s7_scheme *sc) static void wrap_recur_if_a_a_opla_laq(s7_scheme *sc, bool a_op) { opt_pid_t choice; - tick_tc_rec(sc, sc->cur_op); + tick_tc(sc, sc->cur_op); choice = opinit_if_a_a_opla_laq(sc, a_op); if ((choice == OPT_INT) || (choice == OPT_INT_0)) { @@ -89686,7 +89511,7 @@ static s7_pointer op_recur_if_a_a_and_a_laa_laa(s7_scheme *sc) static s7_pointer fx_recur_if_a_a_and_a_laa_laa(s7_scheme *sc, s7_pointer arg) { - tick_tc_rec(sc, OP_RECUR_IF_A_A_AND_A_LAA_LAA); + tick_tc(sc, OP_RECUR_IF_A_A_AND_A_LAA_LAA); /* sc->curlet is set already and will be restored by the caller */ sc->rec_stack = recur_make_stack(sc); opinit_if_a_a_and_a_laa_laa(sc, arg); @@ -89732,7 +89557,7 @@ static s7_pointer op_recur_cond_a_a_a_a_opla_laq(s7_scheme *sc) static s7_pointer fx_recur_cond_a_a_a_a_opla_laq(s7_scheme *sc, s7_pointer arg) { - tick_tc_rec(sc, OP_RECUR_COND_A_A_A_A_opLA_LAq); + tick_tc(sc, OP_RECUR_COND_A_A_A_A_opLA_LAq); sc->rec_stack = recur_make_stack(sc); opinit_cond_a_a_a_a_opla_laq(sc, arg); sc->value = oprec_cond_a_a_a_a_opla_laq(sc); @@ -90062,7 +89887,7 @@ static s7_pointer oprec_cond_a_a_a_laa_lopa_laaq(s7_scheme *sc) static void wrap_recur_cond_a_a_a_laa_lopa_laaq(s7_scheme *sc) { opt_pid_t choice; - tick_tc_rec(sc, sc->cur_op); + tick_tc(sc, sc->cur_op); choice = opinit_cond_a_a_a_laa_lopa_laaq(sc); if (choice != OPT_PTR) sc->value = make_integer(sc, (choice == OPT_INT) ? oprec_i_cond_a_a_a_laa_lopa_laaq(sc) : oprec_i_cond_a_a_a_laa_lopa_laaq_0(sc)); @@ -90074,9 +89899,69 @@ static void wrap_recur_cond_a_a_a_laa_lopa_laaq(s7_scheme *sc) } } + +/* -------- and_a_or_a_laa_laa -------- */ + +static void opinit_and_a_or_a_laa_laa(s7_scheme *sc, s7_pointer code) +{ + s7_pointer orp; + orp = cdr(opt3_pair(code)); + rec_set_test(sc, cdr(code)); + rec_set_res(sc, orp); + rec_set_f1(sc, cdr(cadr(orp))); + rec_set_f2(sc, cddr(cadr(orp))); + rec_set_f3(sc, cdr(caddr(orp))); + rec_set_f4(sc, cddr(caddr(orp))); + sc->rec_slot1 = let_slots(sc->curlet); + sc->rec_slot2 = next_slot(sc->rec_slot1); +} + +static s7_pointer oprec_and_a_or_a_laa_laa(s7_scheme *sc) +{ + s7_pointer p; + if (sc->rec_testf(sc, sc->rec_testp) == sc->F) return(sc->F); + p = sc->rec_resf(sc, sc->rec_resp); + if (p != sc->F) return(p); + + recur_push(sc, slot_value(sc->rec_slot1)); + recur_push(sc, slot_value(sc->rec_slot2)); + recur_push(sc, sc->rec_f1f(sc, sc->rec_f1p)); + slot_set_value(sc->rec_slot2, sc->rec_f2f(sc, sc->rec_f2p)); + slot_set_value(sc->rec_slot1, recur_pop(sc)); + p = oprec_and_a_or_a_laa_laa(sc); + if (p != sc->F) + { + sc->rec_loc -= 2; + return(p); + } + slot_set_value(sc->rec_slot2, recur_pop(sc)); + slot_set_value(sc->rec_slot1, recur_pop(sc)); + recur_push(sc, sc->rec_f3f(sc, sc->rec_f3p)); + slot_set_value(sc->rec_slot2, sc->rec_f4f(sc, sc->rec_f4p)); + slot_set_value(sc->rec_slot1, recur_pop(sc)); + return(oprec_and_a_or_a_laa_laa(sc)); +} + +static s7_pointer op_recur_and_a_or_a_laa_laa(s7_scheme *sc) +{ + opinit_and_a_or_a_laa_laa(sc, sc->code); + return(oprec_and_a_or_a_laa_laa(sc)); +} + +static s7_pointer fx_recur_and_a_or_a_laa_laa(s7_scheme *sc, s7_pointer arg) +{ + tick_tc(sc, OP_RECUR_AND_A_OR_A_LAA_LAA); + sc->rec_stack = recur_make_stack(sc); + opinit_and_a_or_a_laa_laa(sc, arg); + sc->value = oprec_and_a_or_a_laa_laa(sc); + sc->rec_loc = 0; + return(sc->value); +} + + static void wrap_recur(s7_scheme *sc, s7_pointer (*recur)(s7_scheme *sc)) { - tick_tc_rec(sc, sc->cur_op); + tick_tc(sc, sc->cur_op); sc->rec_stack = recur_make_stack(sc); sc->value = recur(sc); sc->rec_loc = 0; @@ -90114,10 +89999,7 @@ static void op_safe_c_ssp_1(s7_scheme *sc) static void op_safe_c_ssp_mv_1(s7_scheme *sc) { - set_car(sc->u2_1, lookup(sc, cadr(sc->code))); - set_car(sc->u1_1, lookup(sc, caddr(sc->code))); - set_cdr(sc->u1_1, sc->value); - sc->args = sc->u2_1; + sc->args = cons_unchecked(sc, lookup(sc, cadr(sc->code)), cons(sc, lookup(sc, caddr(sc->code)), sc->value)); /* not ulist here */ sc->code = c_function_base(opt1_cfunc(sc->code)); } @@ -90164,7 +90046,7 @@ static s7_pointer op_s_c(s7_scheme *sc) sc->code = lookup_checked(sc, car(code)); if (!is_applicable(sc->code)) apply_error(sc, sc->code, cdr(code)); - sc->args = (dont_eval_args(sc->code)) ? copy_proper_list(sc, cdr(code)) : list_1(sc, cadr(code)); + sc->args = list_1(sc, cadr(code)); return(NULL); } @@ -90183,7 +90065,7 @@ static Inline bool op_s_s(s7_scheme *sc) } if (!is_applicable(sc->code)) apply_error(sc, sc->code, cdr(code)); - sc->args = (dont_eval_args(sc->code)) ? copy_proper_list(sc, cdr(code)) : list_1(sc, lookup(sc, cadr(code))); + sc->args = (dont_eval_args(sc->code)) ? list_1(sc, cadr(code)) : list_1(sc, lookup(sc, cadr(code))); return(false); /* goto APPLY; */ } @@ -90194,7 +90076,7 @@ static inline s7_pointer op_s_a(s7_scheme *sc) sc->code = lookup_checked(sc, car(code)); if (!is_applicable(sc->code)) apply_error(sc, sc->code, cdr(code)); - sc->args = (dont_eval_args(sc->code)) ? copy_proper_list(sc, cdr(code)) : list_1(sc, fx_call(sc, cdr(code))); + sc->args = (dont_eval_args(sc->code)) ? list_1(sc, cadr(code)) : list_1(sc, fx_call(sc, cdr(code))); return(NULL); } @@ -90206,10 +90088,10 @@ static s7_pointer op_s_aa(s7_scheme *sc) if (!is_applicable(sc->code)) apply_error(sc, sc->code, cdr(code)); if (dont_eval_args(sc->code)) - sc->args = copy_proper_list(sc, cdr(code)); + sc->args = list_2(sc, cadr(code), caddr(code)); else { - sc->args = cons(sc, fx_call(sc, cddr(code)), sc->nil); + sc->args = list_1(sc, fx_call(sc, cddr(code))); sc->args = cons(sc, fx_call(sc, cdr(code)), sc->args); } return(NULL); @@ -90261,6 +90143,7 @@ static void op_safe_c_function_star_aa(s7_scheme *sc) static bool op_safe_c_ps(s7_scheme *sc) { s7_pointer args; + /* fprintf(stderr, "%s: %s\n", op_names[optimize_op(cadr(sc->code))], display(sc->code)); */ args = cdr(sc->code); if ((has_gx(args)) && (symbol_ctr(caar(args)) == 1)) { @@ -90314,9 +90197,7 @@ static void op_safe_c_sp_1(s7_scheme *sc) static void op_safe_c_sp_mv(s7_scheme *sc) { - set_car(sc->u1_1, sc->args); - set_cdr(sc->u1_1, sc->value); - sc->args = sc->u1_1; + sc->args = cons(sc, sc->args, sc->value); /* not ulist here */ sc->code = c_function_base(opt1_cfunc(sc->code)); } @@ -90466,7 +90347,7 @@ static void op_safe_c_pp_5(s7_scheme *sc) { s7_pointer p; for (p = sc->args; is_pair(cdr(p)); p = cdr(p)); - set_cdr(p, cons(sc, sc->value, sc->nil)); + set_cdr(p, list_1(sc, sc->value)); } sc->code = c_function_base(opt1_cfunc(sc->code)); } @@ -90477,9 +90358,6 @@ static void op_safe_c_pp_6_mv(s7_scheme *sc) /* * c_callee(sc->code) here is g_add_2, but we have any number of args from a values call * the original (unoptimized) function is (hopefully) c_function_base(opt1_cfunc(sc->code))? - * (let () (define (ho a) (+ a 2)) (define (hi) (+ (ho 1) (ho 2))) (hi)) -> 7 - * (let () (define (ho a) (+ a 2)) (define (hi) (+ (ho 1) (values 3 4))) (hi)) -> 10 - * (let () (define (ho a) (+ a 2)) (define (hi) (+ (values 3 4) (ho 1))) (hi)) -> 10 * (let () (define (hi) (+ (values 1 2) (values 3 4))) (hi)) -> 10 */ sc->code = c_function_base(opt1_cfunc(sc->code)); @@ -90490,19 +90368,18 @@ static Inline bool collect_fp_args(s7_scheme *sc, opcode_t op, s7_pointer args) s7_pointer p; sc->args = args; for (p = sc->code; is_pair(p); p = cdr(p)) - { - if (has_fx(p)) - sc->args = cons(sc, fx_call(sc, p), sc->args); /* reversed before apply in OP_ANY_C_FP_1 */ - else - { - if ((has_gx(p)) && (symbol_ctr(caar(p)) == 1)) - sc->args = cons(sc, c_call_unchecked(p)(sc, car(p)), sc->args); - else - { - push_stack(sc, op, sc->args, cdr(p)); - sc->code = T_Pair(car(p)); - return(true); - }}} + if (has_fx(p)) + sc->args = cons(sc, fx_call(sc, p), sc->args); /* reversed before apply in OP_ANY_C_FP_1 */ + else + { + if ((has_gx(p)) && (symbol_ctr(caar(p)) == 1)) + sc->args = cons(sc, c_call_unchecked(p)(sc, car(p)), sc->args); + else + { + push_stack(sc, op, sc->args, cdr(p)); + sc->code = T_Pair(car(p)); + return(true); + }} return(false); } @@ -90511,23 +90388,22 @@ static bool op_any_c_fp(s7_scheme *sc) /* code: (func . args) where at least one s7_pointer p; sc->args = sc->nil; for (p = cdr(sc->code); is_pair(p); p = cdr(p)) - { - if (has_fx(p)) - sc->args = cons(sc, fx_call(sc, p), sc->args); /* reversed before apply in OP_ANY_C_FP_1 */ - else - { - if ((has_gx(p)) && (symbol_ctr(caar(p)) == 1)) - sc->args = cons(sc, c_call_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_FP_1 : OP_ANY_C_FP_2)), sc->args, cdr(p)); - sc->code = T_Pair(car(p)); - return(true); - }}} + if (has_fx(p)) + sc->args = cons(sc, fx_call(sc, p), sc->args); /* reversed before apply in OP_ANY_C_FP_1 */ + else + { + if ((has_gx(p)) && (symbol_ctr(caar(p)) == 1)) + sc->args = cons(sc, c_call_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_FP_1 : OP_ANY_C_FP_2)), sc->args, cdr(p)); + sc->code = T_Pair(car(p)); + return(true); + }} /* here fx/gx got all the args */ sc->args = safe_reverse_in_place(sc, sc->args); sc->value = c_call(sc->code)(sc, sc->args); @@ -90573,7 +90449,7 @@ static void op_any_closure_fp(s7_scheme *sc) p = cdr(sc->code); if (has_fx(p)) { - sc->args = cons(sc, fx_call(sc, p), sc->nil); + sc->args = list_1(sc, fx_call(sc, p)); for (p = cdr(p); (is_pair(p)) && (has_fx(p)); p = cdr(p)) sc->args = cons_unchecked(sc, fx_call(sc, p), sc->args); } @@ -90834,10 +90710,11 @@ static Inline void op_apply_ss(s7_scheme *sc) */ sc->args = lookup(sc, opt2_sym(sc->code)); /* is this right if code=macro? */ sc->code = lookup(sc, cadr(sc->code)); /* global search here was slower (e.g. tauto) */ - if (!s7_is_proper_list(sc, sc->args)) /* (apply + #f) etc */ - apply_list_error(sc, sc->args); if (needs_copied_args(sc->code)) - sc->args = copy_proper_list(sc, sc->args); + sc->args = copy_proper_list_with_arglist_error(sc, sc->args); + else + if (!s7_is_proper_list(sc, sc->args)) /* (apply + #f) etc */ + apply_list_error(sc, sc->args); } static void op_apply_sa(s7_scheme *sc) @@ -90846,10 +90723,11 @@ static void op_apply_sa(s7_scheme *sc) p = cdr(sc->code); sc->args = fx_call(sc, cdr(p)); sc->code = lookup_global(sc, car(p)); - if (!s7_is_proper_list(sc, sc->args)) /* (apply + #f) etc */ - apply_list_error(sc, sc->args); if (needs_copied_args(sc->code)) - sc->args = copy_proper_list(sc, sc->args); + sc->args = copy_proper_list_with_arglist_error(sc, sc->args); + else + if (!s7_is_proper_list(sc, sc->args)) /* (apply + #f) etc */ + apply_list_error(sc, sc->args); } static void op_apply_sl(s7_scheme *sc) @@ -90928,15 +90806,9 @@ static void op_read_internal(s7_scheme *sc) sc->tok = token(sc); switch (sc->tok) { - case TOKEN_EOF: - break; - - case TOKEN_RIGHT_PAREN: - read_error(sc, "unexpected close paren"); - - case TOKEN_COMMA: - read_error(sc, "unexpected comma"); - + case TOKEN_EOF: break; + case TOKEN_RIGHT_PAREN: read_error(sc, "unexpected close paren"); + case TOKEN_COMMA: read_error(sc, "unexpected comma"); default: sc->value = read_expression(sc); sc->current_line = port_line_number(current_input_port(sc)); /* this info is used to track down missing close parens */ @@ -91083,16 +90955,6 @@ static bool op_read_unquote(s7_scheme *sc) * but (immutable? (let-temporarily (((*s7* 'safety) 2)) (eval-string "#(1 2 3)"))) is #t * at run time we just see the vector */ -static void free_vlist(s7_scheme *sc, s7_pointer lst) -{ - if (is_pair(lst)) - { - s7_pointer p, np; - for (p = lst, np = cdr(lst); is_pair(p); p = np, np = unchecked_cdr(np)) - free_cell(sc, p); - } -} - static bool op_read_vector(s7_scheme *sc) { if (is_dotted_pair(sc->value)) /* #(1 . 2) */ @@ -91100,7 +90962,6 @@ static bool op_read_vector(s7_scheme *sc) sc->v = sc->value; sc->value = (sc->args == int_one) ? g_vector(sc, sc->value) : g_multivector(sc, integer(sc->args), sc->value); /* sc->args was sc->w earlier from read_sharp */ /* here and below all of the sc->value list can be freed, but my tests showed no speed up even in large cases */ - free_vlist(sc, sc->v); if (sc->safety > IMMUTABLE_VECTOR_SAFETY) set_immutable(sc->value); return(main_stack_op(sc) != OP_READ_LIST); } @@ -91111,7 +90972,6 @@ static bool op_read_int_vector(s7_scheme *sc) read_error(sc, "int-vector constant data is not a proper list"); sc->v = sc->value; sc->value = (sc->args == int_one) ? g_int_vector(sc, sc->value) : g_int_multivector(sc, integer(sc->args), sc->value); - free_vlist(sc, sc->v); if (sc->safety > IMMUTABLE_VECTOR_SAFETY) set_immutable(sc->value); return(main_stack_op(sc) != OP_READ_LIST); } @@ -91122,7 +90982,6 @@ static bool op_read_float_vector(s7_scheme *sc) read_error(sc, "float-vector constant data is not a proper list"); sc->v = sc->value; sc->value = (sc->args == int_one) ? g_float_vector(sc, sc->value) : g_float_multivector(sc, integer(sc->args), sc->value); - free_vlist(sc, sc->v); if (sc->safety > IMMUTABLE_VECTOR_SAFETY) set_immutable(sc->value); return(main_stack_op(sc) != OP_READ_LIST); } @@ -91133,12 +90992,12 @@ static bool op_read_byte_vector(s7_scheme *sc) read_error(sc, "byte-vector constant data is not a proper list"); sc->v = sc->value; sc->value = (sc->args == int_one) ? g_byte_vector(sc, sc->value) : g_byte_multivector(sc, integer(sc->args), sc->value); - free_vlist(sc, sc->v); if (sc->safety > IMMUTABLE_VECTOR_SAFETY) set_immutable(sc->value); return(main_stack_op(sc) != OP_READ_LIST); } -static void eval_last_arg(s7_scheme *sc, s7_pointer car_code) + +static inline void eval_last_arg(s7_scheme *sc, s7_pointer car_code) { /* here we've reached the last arg (sc->code == nil), it is not a pair */ if (!is_null(cdr(sc->code))) @@ -91148,7 +91007,7 @@ static void eval_last_arg(s7_scheme *sc, s7_pointer car_code) sc->code = pop_op_stack(sc); } -static void eval_args_pair_car(s7_scheme *sc) +static inline void eval_args_pair_car(s7_scheme *sc) { s7_pointer code; if (sc->stack_end >= sc->stack_resize_trigger) @@ -91227,7 +91086,6 @@ static inline bool eval_args_last_arg(s7_scheme *sc) static void op_pair_pair(s7_scheme *sc) { - /* fprintf(stderr, "%s[%d]: %s\n", __func__, __LINE__, display(sc->code)); */ if (sc->stack_end >= sc->stack_resize_trigger) { check_for_cyclic_code(sc, sc->code); @@ -91308,16 +91166,18 @@ static Inline void op_map_gather(s7_scheme *sc) /* -------------------------------------------------------------------------------- */ -#define c_function_is_ok_cadr(Sc, P) ((c_function_is_ok(Sc, P)) && (c_function_is_ok(Sc, cadr(P)))) -#define c_function_is_ok_caddr(Sc, P) ((c_function_is_ok(Sc, P)) && (c_function_is_ok(Sc, caddr(P)))) -#define c_function_is_ok_cadr_caddr(Sc, P) ((c_function_is_ok(Sc, P)) && (c_function_is_ok(Sc, cadr(P))) && (c_function_is_ok(Sc, caddr(P)))) - #if WITH_GCC - #define indirect_c_function_is_ok(Sc, X) ({s7_pointer _X_; _X_ = X; (((optimize_op(_X_) & 0x1) != 0) || (c_function_is_ok(Sc, _X_)));}) +#define h_c_function_is_ok(Sc, P) ({s7_pointer _P_; _P_ = P; ((op_has_hop(_P_)) || (c_function_is_ok(Sc, _P_)));}) #else - #define indirect_c_function_is_ok(Sc, X) (((optimize_op(X) & 0x1) != 0) || (c_function_is_ok(Sc, X))) +#define h_c_function_is_ok(Sc, P) ((op_has_hop(P)) || (c_function_is_ok(Sc, P))) #endif +#define c_function_is_ok_cadr(Sc, P) ((c_function_is_ok(Sc, P)) && (h_c_function_is_ok(Sc, cadr(P)))) +#define c_function_is_ok_caddr(Sc, P) ((c_function_is_ok(Sc, P)) && (h_c_function_is_ok(Sc, caddr(P)))) +#define c_function_is_ok_cadr_caddr(Sc, P) ((c_function_is_ok(Sc, P)) && (h_c_function_is_ok(Sc, cadr(P))) && (h_c_function_is_ok(Sc, caddr(P)))) +#define c_function_is_ok_cadr_cadadr(Sc, P) ((c_function_is_ok(Sc, P)) && (h_c_function_is_ok(Sc, cadr(P))) && (h_c_function_is_ok(Sc, cadadr(P)))) +#define c_function_is_ok_cadr_caddadr(Sc, P) ((c_function_is_ok(Sc, P)) && (h_c_function_is_ok(Sc, cadr(P))) && (h_c_function_is_ok(Sc, caddadr(P)))) +#define c_function_is_ok_caddr_caddaddr(Sc, P) ((c_function_is_ok(Sc, P)) && (h_c_function_is_ok(Sc, caddr(P))) && (h_c_function_is_ok(Sc, caddaddr(P)))) /* closure_is_ok_1 checks the type and the body length indications * closure_is_fine_1 just checks the type (safe or unsafe closure) @@ -91347,7 +91207,6 @@ static inline bool closure_is_fine_1(s7_scheme *sc, s7_pointer code, uint16_t ty #if S7_DEBUGGING if ((type & (T_ONE_FORM | T_MULTIFORM)) != 0) fprintf(stderr, "%s %s: type has body bits\n", __func__, display(code)); #endif - /* fprintf(stderr, "check %s %ld\n", display_80(code), (long int)symbol_ctr(car(code))); */ f = lookup_unexamined(sc, car(code)); if ((f == opt1_lambda_unchecked(code)) || ((f) && @@ -91385,6 +91244,7 @@ static inline bool closure_fp_is_ok_1(s7_scheme *sc, s7_pointer code, int32_t ar * The problem may be that set! does not increment symbol_ctr, and also maybe not (define f1 f2), * but those cases will change the local_slot value. So, the combination as it is now is safe but stupid? * by adding another operator for each closure set, we can skip the symbol_ctr==1 bit once ctr>1, but that only saves about 1%. + * It's also possible to move the ctr stuff into the optimizer code (not runtime), but saves less than .5%. */ #define closure_is_ok(Sc, Code, Type, Args) \ @@ -91464,7 +91324,7 @@ static bool fixup_unknown_op(s7_pointer code, s7_pointer func, opcode_t op) static bool unknown_unknown(s7_scheme *sc, s7_pointer code, opcode_t op) { if ((is_symbol(car(code))) && - (!is_slot(symbol_to_slot(sc, car(code))))) + (!is_slot(lookup_slot_from(car(code), sc->curlet)))) unbound_variable_error(sc, car(code)); set_optimize_op(code, op); return(true); @@ -91480,7 +91340,7 @@ static bool is_immutable_and_stable(s7_scheme *sc, s7_pointer func) for (p = sc->curlet; is_let(p); p = let_outlet(p)) if ((is_funclet(p)) && (funclet_function(p) != func)) return(false); - p = symbol_to_slot(sc, func); + p = lookup_slot_from(func, sc->curlet); return(is_immutable_slot(p)); } @@ -91492,7 +91352,7 @@ static bool op_unknown(s7_scheme *sc) { #if S7_DEBUGGING if ((!is_symbol(car(sc->code))) || - (is_slot(symbol_to_slot(sc, car(sc->code))))) + (is_slot(lookup_slot_from(car(sc->code), sc->curlet)))) fprintf(stderr, "%s[%d]: weird: %s\n", __func__, __LINE__, display(sc->code)); #endif unbound_variable_error(sc, car(sc->code)); @@ -91563,7 +91423,7 @@ static bool op_unknown(s7_scheme *sc) default: if ((is_symbol(car(code))) && - (!is_slot(symbol_to_slot(sc, car(code))))) + (!is_slot(lookup_slot_from(car(code), sc->curlet)))) unbound_variable_error(sc, car(code)); } return(fixup_unknown_op(code, f, OP_S)); @@ -91613,14 +91473,13 @@ static bool op_unknown_g(s7_scheme *sc) code = sc->code; #if S7_DEBUGGING - if (is_pair(cadr(code))) - fprintf(stderr, "%s[%d]: arg is a pair: %s\n", __func__, __LINE__, display(code)); + if (is_pair(cadr(code))) fprintf(stderr, "%s[%d]: arg is a pair: %s\n", __func__, __LINE__, display(code)); #endif sym_case = is_normal_symbol(cadr(code)); if ((sym_case) && (!is_any_macro(f)) && /* if f is a macro, its argument can be unbound legitimately */ - (!is_slot(symbol_to_slot(sc, cadr(code))))) + (!is_slot(lookup_slot_from(cadr(code), sc->curlet)))) return(unknown_unknown(sc, sc->code, (is_normal_symbol(cadr(sc->code))) ? OP_CLEAR_OPTS : OP_S_C)); /* not OP_S_S here! */ if ((is_unknopt(code)) && (!is_closure(f))) @@ -91678,8 +91537,7 @@ static bool op_unknown_g(s7_scheme *sc) * back out: safe_closure_s_* -> safe_closure_s -> closure_s -> op_s_s. Ideally we'd know * this was a parameter or whatever. The tricky case is local letrec(f) calling f which initially * thinks it is not safe, then later is set safe correctly, now outer func is called again, - * this time f is safe, symbol_ctr==2, and if all is well-behaved we're ok from then on. - * (added later): I think this is fixed now, so the symbol_ctr stuff below can be removed. + * this time f is safe, and we're ok from then on. */ if (is_unknopt(code)) { @@ -91688,20 +91546,19 @@ static bool op_unknown_g(s7_scheme *sc) */ switch (op_no_hop(code)) { - case OP_CLOSURE_S: set_optimize_op(code, ((is_safe_closure(f)) && (symbol_ctr(car(code)) == 2)) ? OP_SAFE_CLOSURE_S : OP_S_S); break; + case OP_CLOSURE_S: set_optimize_op(code, (is_safe_closure(f)) ? OP_SAFE_CLOSURE_S : OP_S_S); break; case OP_CLOSURE_S_O: case OP_SAFE_CLOSURE_S: set_optimize_op(code, OP_CLOSURE_S); break; case OP_SAFE_CLOSURE_S_O: case OP_SAFE_CLOSURE_S_A: case OP_SAFE_CLOSURE_S_TO_S: case OP_SAFE_CLOSURE_S_TO_SC: set_optimize_op(code, (is_safe_closure(f)) ? OP_SAFE_CLOSURE_S : OP_CLOSURE_S); break; - case OP_CLOSURE_C: set_optimize_op(code, ((is_safe_procedure(f)) && (symbol_ctr(car(code)) == 2)) ? OP_SAFE_CLOSURE_C : OP_S_C); break; + case OP_CLOSURE_C: set_optimize_op(code, (is_safe_procedure(f)) ? OP_SAFE_CLOSURE_C : OP_S_C); break; case OP_CLOSURE_C_O: case OP_SAFE_CLOSURE_C: set_optimize_op(code, OP_CLOSURE_C); break; case OP_SAFE_CLOSURE_C_O: set_optimize_op(code, (is_safe_closure(f)) ? OP_SAFE_CLOSURE_C : OP_CLOSURE_C); break; default: set_optimize_op(code, (sym_case) ? OP_S_S : OP_S_C); break; } - /* fprintf(stderr, " -> %s\n", op_names[optimize_op(code)]); */ set_opt1_lambda(code, f); return(true); } @@ -91768,7 +91625,7 @@ static bool op_unknown_g(s7_scheme *sc) break; case T_LET: - if (is_normal_symbol(cadr(code))) + if (sym_case) { fx_annotate_arg(sc, cdr(code), sc->curlet); return(fixup_unknown_op(code, f, OP_IMPLICIT_LET_REF_A)); @@ -91791,7 +91648,7 @@ static bool op_unknown_g(s7_scheme *sc) break; } if ((is_symbol(car(code))) && - (!is_slot(symbol_to_slot(sc, car(code))))) + (!is_slot(lookup_slot_from(car(code), sc->curlet)))) unbound_variable_error(sc, car(code)); return(fixup_unknown_op(code, f, (sym_case) ? OP_S_S : OP_S_C)); @@ -91814,7 +91671,6 @@ static bool op_unknown_a(s7_scheme *sc) if ((c_function_required_args(f) > 1) || (c_function_all_args(f) == 0)) break; - case T_C_OPT_ARGS_FUNCTION: case T_C_ANY_ARGS_FUNCTION: set_c_function(code, f); @@ -91890,7 +91746,7 @@ static bool op_unknown_a(s7_scheme *sc) break; } if ((is_symbol(car(code))) && - (!is_slot(symbol_to_slot(sc, car(code))))) + (!is_slot(lookup_slot_from(car(code), sc->curlet)))) unbound_variable_error(sc, car(code)); return(fixup_unknown_op(code, f, OP_S_A)); /* closure with methods etc */ @@ -91941,18 +91797,17 @@ static bool op_unknown_gg(s7_scheme *sc) code = sc->code; #if S7_DEBUGGING - if ((is_pair(cadr(code))) || (is_pair(caddr(code)))) - fprintf(stderr, "%s[%d]: arg is a pair: %s\n", __func__, __LINE__, display(code)); + if ((is_pair(cadr(code))) || (is_pair(caddr(code)))) fprintf(stderr, "%s[%d]: arg is a pair: %s\n", __func__, __LINE__, display(code)); #endif s1 = is_normal_symbol(cadr(code)); s2 = is_normal_symbol(caddr(code)); if ((s1) && - (!is_slot(symbol_to_slot(sc, cadr(code))))) + (!is_slot(lookup_slot_from(cadr(code), sc->curlet)))) return(unknown_unknown(sc, sc->code, OP_CLEAR_OPTS)); if ((s2) && - (!is_slot(symbol_to_slot(sc, caddr(code))))) + (!is_slot(lookup_slot_from(caddr(code), sc->curlet)))) return(unknown_unknown(sc, sc->code, OP_CLEAR_OPTS)); switch (type(f)) @@ -92067,7 +91922,7 @@ static bool op_unknown_gg(s7_scheme *sc) } if ((is_symbol(car(code))) && - (!is_slot(symbol_to_slot(sc, car(code))))) + (!is_slot(lookup_slot_from(car(code), sc->curlet)))) unbound_variable_error(sc, car(code)); fx_annotate_args(sc, cdr(code), sc->curlet); @@ -92089,7 +91944,7 @@ static bool op_unknown_all_s(s7_scheme *sc) code = sc->code; num_args = integer(opt3_arglen(code)); for (arg = cdr(code); is_pair(arg); arg = cdr(arg)) - if (!is_slot(symbol_to_slot(sc, car(arg)))) + if (!is_slot(lookup_slot_from(car(arg), sc->curlet))) unbound_variable_error(sc, car(arg)); switch (type(f)) @@ -92244,12 +92099,23 @@ static bool op_unknown_aa(s7_scheme *sc) } if ((is_symbol(car(code))) && - (!is_slot(symbol_to_slot(sc, car(code))))) + (!is_slot(lookup_slot_from(car(code), sc->curlet)))) unbound_variable_error(sc, car(code)); return(fixup_unknown_op(code, f, OP_S_AA)); } +static bool is_normal_happy_symbol(s7_scheme *sc, s7_pointer sym) +{ + if (is_normal_symbol(sym)) + { + if (!is_slot(lookup_slot_from(sym, sc->curlet))) + unbound_variable_error(sc, sym); + return(true); + } + return(false); +} + static bool op_unknown_fx(s7_scheme *sc) { s7_pointer code, f; @@ -92279,6 +92145,23 @@ static bool op_unknown_fx(s7_scheme *sc) { if (num_args == 3) { + int32_t pairs = 0, symbols = 0, quotes = 0; /* specialize aaa->ssc etc, this makes less difference than I expected */ + s7_pointer p; + for (p = cdr(code); is_pair(p); p = cdr(p)) + { + s7_pointer car_p; + car_p = car(p); + if (is_normal_happy_symbol(sc, car_p)) + symbols++; + else + if (is_pair(car_p)) + { + pairs++; + if (is_proper_quote(sc, car_p)) + quotes++; + }} + if (optimize_safe_c_func_three_args(sc, code, f, 0 /* hop */, pairs, symbols, quotes, sc->curlet) == OPT_T) + return(true); set_opt3_pair(cdr(code), cdddr(code)); set_safe_optimize_op(code, OP_SAFE_C_AAA); } @@ -92300,8 +92183,8 @@ static bool op_unknown_fx(s7_scheme *sc) { if (num_args == 3) { - if (is_symbol(cadr(code))) - set_safe_optimize_op(code, hop + ((is_symbol(caddr(code))) ? OP_SAFE_CLOSURE_SSA : OP_SAFE_CLOSURE_SAA)); + if (is_normal_happy_symbol(sc, cadr(code))) + set_safe_optimize_op(code, hop + ((is_normal_happy_symbol(sc, caddr(code))) ? OP_SAFE_CLOSURE_SSA : OP_SAFE_CLOSURE_SAA)); else { if ((!is_pair(caddr(code))) && (!is_pair(cadddr(code)))) @@ -92315,17 +92198,16 @@ static bool op_unknown_fx(s7_scheme *sc) set_safe_optimize_op(code, hop + OP_CLOSURE_FX); if (num_args == 3) { - if ((is_symbol(caddr(code))) && (is_symbol(cadddr(code)))) + if ((is_normal_happy_symbol(sc, caddr(code))) && (is_normal_happy_symbol(sc, cadddr(code)))) set_safe_optimize_op(code, hop + OP_CLOSURE_ASS); else { - if (is_symbol(cadr(code))) - set_safe_optimize_op(code, hop + ((is_symbol(cadddr(code))) ? OP_CLOSURE_SAS : OP_CLOSURE_SAA)); + if (is_normal_happy_symbol(sc, cadr(code))) + set_safe_optimize_op(code, hop + ((is_normal_happy_symbol(sc, cadddr(code))) ? OP_CLOSURE_SAS : OP_CLOSURE_SAA)); else - { - if (is_symbol(cadddr(code))) - set_safe_optimize_op(code, hop + OP_CLOSURE_AAS); - }}}} + if (is_normal_happy_symbol(sc, cadddr(code))) + set_safe_optimize_op(code, hop + OP_CLOSURE_AAS); + }}} set_opt1_lambda(code, f); return(true); } @@ -92460,7 +92342,6 @@ static bool op_unknown_fp(s7_scheme *sc) set_any_closure_fp(sc, f, code, sc->curlet, num_args, hop + OP_ANY_CLOSURE_FP); break; } - /* fprintf(stderr, "%s[%d]: %s safe: %d, args: %d, %s\n", __func__, __LINE__, display(f), is_safe_closure(f), num_args, display_80(sc->code)); */ /* safe|closure|p*|fp|a*p* */ return(true); } @@ -92657,16 +92538,13 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) case OP_SAFE_C_opSq: if (!c_function_is_ok_cadr(sc, sc->code)) break; case HOP_SAFE_C_opSq: sc->value = fx_c_opsq(sc, sc->code); continue; - case OP_SAFE_C_op_opSqq: if ((!c_function_is_ok(sc, sc->code)) || (!c_function_is_ok(sc, cadr(sc->code))) || (!c_function_is_ok(sc, cadadr(sc->code)))) break; + case OP_SAFE_C_op_opSqq: if (!c_function_is_ok_cadr_cadadr(sc, sc->code)) break; case HOP_SAFE_C_op_opSqq: sc->value = fx_c_op_opsqq(sc, sc->code); continue; - case OP_SAFE_C_op_opSq_Cq: if ((!c_function_is_ok(sc, sc->code)) || (!c_function_is_ok(sc, cadr(sc->code))) || (!c_function_is_ok(sc, cadadr(sc->code)))) break; - case HOP_SAFE_C_op_opSq_Cq: sc->value = fx_c_op_opsq_cq(sc, sc->code); continue; - - case OP_SAFE_C_op_S_opSqq: if ((!c_function_is_ok(sc, sc->code)) || (!c_function_is_ok(sc, cadr(sc->code))) || (!c_function_is_ok(sc, caddadr(sc->code)))) break; + case OP_SAFE_C_op_S_opSqq: if (!c_function_is_ok_cadr_caddadr(sc, sc->code)) break; case HOP_SAFE_C_op_S_opSqq: sc->value = fx_c_op_s_opsqq(sc, sc->code); continue; - case OP_SAFE_C_op_opSq_Sq: if ((!c_function_is_ok(sc, sc->code)) || (!c_function_is_ok(sc, cadr(sc->code))) || (!c_function_is_ok(sc, cadadr(sc->code)))) break; + case OP_SAFE_C_op_opSq_Sq: if (!c_function_is_ok_cadr_cadadr(sc, sc->code)) break; case HOP_SAFE_C_op_opSq_Sq: sc->value = fx_c_op_opsq_sq(sc, sc->code); continue; case OP_SAFE_C_PS: if (!c_function_is_ok(sc, sc->code)) break; @@ -92730,9 +92608,6 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) case OP_SAFE_C_C_opDq: if (!c_function_is_ok_caddr(sc, sc->code)) break; case HOP_SAFE_C_C_opDq: sc->value = fx_c_c_opdq(sc, sc->code); continue; - case OP_SAFE_C_C_opCSq: if (!c_function_is_ok_caddr(sc, sc->code)) break; - case HOP_SAFE_C_C_opCSq: sc->value = fx_c_c_opcsq(sc, sc->code); continue; - case OP_SAFE_C_C_opSSq: if (!c_function_is_ok_caddr(sc, sc->code)) break; case HOP_SAFE_C_C_opSSq: sc->value = fx_c_c_opssq(sc, sc->code); continue; @@ -92745,30 +92620,12 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) case OP_SAFE_C_opSSq_S: if (!c_function_is_ok_cadr(sc, sc->code)) break; case HOP_SAFE_C_opSSq_S: sc->value = fx_c_opssq_s(sc, sc->code); continue; - case OP_SAFE_C_op_opSSqq_C: if ((!c_function_is_ok(sc, sc->code)) || (!c_function_is_ok(sc, cadr(sc->code))) || (!c_function_is_ok(sc, cadadr(sc->code)))) break; - case HOP_SAFE_C_op_opSSqq_C: sc->value = fx_c_op_opssqq_c(sc, sc->code); continue; - - case OP_SAFE_C_op_opSSqq_S: if ((!c_function_is_ok(sc, sc->code)) || (!c_function_is_ok(sc, cadr(sc->code))) || (!c_function_is_ok(sc, cadadr(sc->code)))) break; + case OP_SAFE_C_op_opSSqq_S: if (!c_function_is_ok_cadr_cadadr(sc, sc->code)) break; case HOP_SAFE_C_op_opSSqq_S: sc->value = fx_c_op_opssqq_s(sc, sc->code); continue; - case OP_SAFE_C_op_opSSq_Sq_S: if ((!c_function_is_ok(sc, sc->code)) || (!c_function_is_ok(sc, cadr(sc->code))) || (!c_function_is_ok(sc, cadadr(sc->code)))) break; - case HOP_SAFE_C_op_opSSq_Sq_S: sc->value = fx_c_op_opssq_sq_s(sc, sc->code); continue; - - case OP_SAFE_C_op_opSqq_C: if ((!c_function_is_ok(sc, sc->code)) || (!c_function_is_ok(sc, cadr(sc->code))) || (!c_function_is_ok(sc, cadadr(sc->code)))) break; - case HOP_SAFE_C_op_opSqq_C: sc->value = fx_c_op_opsqq_c(sc, sc->code); continue; - - case OP_SAFE_C_S_op_opSq_Cq: if ((!c_function_is_ok(sc, sc->code)) || (!c_function_is_ok(sc, caddr(sc->code))) || (!c_function_is_ok(sc, cadaddr(sc->code)))) break; - case HOP_SAFE_C_S_op_opSq_Cq: sc->value = fx_c_s_op_opsq_cq(sc, sc->code); continue; - - case OP_SAFE_C_S_op_S_opSqq: if ((!c_function_is_ok(sc, sc->code)) || (!c_function_is_ok(sc, caddr(sc->code))) || (!c_function_is_ok(sc, caddaddr(sc->code)))) break; - case HOP_SAFE_C_S_op_S_opSqq: sc->value = fx_c_s_op_s_opsqq(sc, sc->code); continue; - - case OP_SAFE_C_S_op_S_opSSqq: if ((!c_function_is_ok(sc, sc->code)) || (!c_function_is_ok(sc, caddr(sc->code))) || (!c_function_is_ok(sc, caddaddr(sc->code)))) break; + case OP_SAFE_C_S_op_S_opSSqq: if (!c_function_is_ok_caddr_caddaddr(sc, sc->code)) break; case HOP_SAFE_C_S_op_S_opSSqq: sc->value = fx_c_s_op_s_opssqq(sc, sc->code); continue; - case OP_SAFE_C_S_op_opSSq_opSSqq: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_S_op_opSSq_opSSqq: sc->value = fx_c_s_op_opssq_opssqq(sc, sc->code); continue; - case OP_SAFE_C_opSCq_C: if (!c_function_is_ok_cadr(sc, sc->code)) break; case HOP_SAFE_C_opSCq_C: sc->value = fx_c_opscq_c(sc, sc->code); continue; @@ -92796,9 +92653,6 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) case OP_SAFE_C_opSq_CS: if (!c_function_is_ok_cadr(sc, sc->code)) break; case HOP_SAFE_C_opSq_CS: sc->value = fx_c_opsq_cs(sc, sc->code); continue; - case OP_SAFE_C_opDq_S: if (!c_function_is_ok_cadr(sc, sc->code)) break; - case HOP_SAFE_C_opDq_S: sc->value = fx_c_opdq_s(sc, sc->code); continue; - case OP_SAFE_C_opSq_C: if (!c_function_is_ok_cadr(sc, sc->code)) break; case HOP_SAFE_C_opSq_C: sc->value = fx_c_opsq_c(sc, sc->code); continue; @@ -92848,10 +92702,10 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) case OP_C_AA: if (!c_function_is_ok(sc, sc->code)) break; case HOP_C_AA: op_c_aa(sc); continue; - case OP_C_S_opSq: if ((!c_function_is_ok(sc, sc->code)) || (!indirect_c_function_is_ok(sc, caddr(sc->code)))) break; + case OP_C_S_opSq: if (!c_function_is_ok_caddr(sc, sc->code))break; case HOP_C_S_opSq: sc->value = op_c_s_opsq(sc); continue; - case OP_C_S_opDq: if ((!c_function_is_ok(sc, sc->code)) || (!indirect_c_function_is_ok(sc, caddr(sc->code)))) break; + case OP_C_S_opDq: if (!c_function_is_ok_caddr(sc, sc->code)) break; case HOP_C_S_opDq: sc->value = op_c_s_opdq(sc); continue; case OP_C_SCS: if (!c_function_is_ok(sc, sc->code)) break; @@ -93174,38 +93028,50 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) goto EVAL; - case OP_TC_AND_A_OR_A_LA: tick_tc_rec(sc, sc->cur_op); op_tc_and_a_or_a_la(sc, sc->code); continue; - case OP_TC_OR_A_AND_A_LA: tick_tc_rec(sc, sc->cur_op); op_tc_or_a_and_a_la(sc, sc->code); continue; - case OP_TC_AND_A_OR_A_LAA: tick_tc_rec(sc, sc->cur_op); op_tc_and_a_or_a_laa(sc, sc->code); continue; - case OP_TC_OR_A_AND_A_LAA: tick_tc_rec(sc, sc->cur_op); op_tc_or_a_and_a_laa(sc, sc->code); continue; - case OP_TC_AND_A_OR_A_A_LA: tick_tc_rec(sc, sc->cur_op); op_tc_and_a_or_a_a_la(sc, sc->code); continue; - case OP_TC_OR_A_AND_A_A_LA: tick_tc_rec(sc, sc->cur_op); op_tc_or_a_and_a_a_la(sc, sc->code); continue; - case OP_TC_OR_A_A_AND_A_A_LA: tick_tc_rec(sc, sc->cur_op); op_tc_or_a_a_and_a_a_la(sc, sc->code); continue; - case OP_TC_OR_A_AND_A_A_L3A: tick_tc_rec(sc, sc->cur_op); op_tc_or_a_and_a_a_l3a(sc, sc->code); continue; - case OP_TC_LET_WHEN_LAA: tick_tc_rec(sc, sc->cur_op); op_tc_let_when_laa(sc, true, sc->code); continue; - case OP_TC_LET_UNLESS_LAA: tick_tc_rec(sc, sc->cur_op); op_tc_let_when_laa(sc, false, sc->code); continue; - case OP_TC_COND_A_Z_A_Z_LAA: tick_tc_rec(sc, sc->cur_op); if (op_tc_if_a_z_if_a_z_laa(sc, true, sc->code)) continue; goto EVAL; - case OP_TC_COND_A_Z_A_LAA_Z: tick_tc_rec(sc, sc->cur_op); if (op_tc_if_a_z_if_a_laa_z(sc, true, sc->code)) continue; goto EVAL; - case OP_TC_COND_A_Z_A_LAA_LAA: tick_tc_rec(sc, sc->cur_op); if (op_tc_cond_a_z_a_laa_laa(sc, sc->code)) continue; goto EVAL; - case OP_TC_LET_COND: tick_tc_rec(sc, sc->cur_op); if (op_tc_let_cond(sc, sc->code)) continue; goto EVAL; - case OP_TC_IF_A_Z_LA: tick_tc_rec(sc, sc->cur_op); if (op_tc_if_a_z_la(sc, sc->code)) continue; goto EVAL; - case OP_TC_IF_A_Z_LAA: tick_tc_rec(sc, sc->cur_op); if (op_tc_if_a_z_laa(sc, sc->code, true)) continue; goto EVAL; - case OP_TC_IF_A_Z_L3A: tick_tc_rec(sc, sc->cur_op); if (op_tc_if_a_z_l3a(sc, sc->code, true)) continue; goto EVAL; - case OP_TC_IF_A_L3A_Z: tick_tc_rec(sc, sc->cur_op); if (op_tc_if_a_z_l3a(sc, sc->code, false)) continue; goto EVAL; - case OP_TC_IF_A_LA_Z: tick_tc_rec(sc, sc->cur_op); if (op_tc_if_a_la_z(sc, sc->code)) continue; goto EVAL; - case OP_TC_IF_A_LAA_Z: tick_tc_rec(sc, sc->cur_op); if (op_tc_if_a_z_laa(sc, sc->code, false)) continue; goto EVAL; - case OP_TC_IF_A_Z_IF_A_Z_LA: tick_tc_rec(sc, sc->cur_op); if (op_tc_if_a_z_if_a_z_la(sc, sc->code, true, TC_IF)) continue; goto EVAL; - case OP_TC_COND_A_Z_A_Z_LA: tick_tc_rec(sc, sc->cur_op); if (op_tc_if_a_z_if_a_z_la(sc, sc->code, true, TC_COND)) continue; goto EVAL; - case OP_TC_COND_A_Z_A_LA_Z: tick_tc_rec(sc, sc->cur_op); if (op_tc_if_a_z_if_a_z_la(sc, sc->code, false, TC_COND))continue; goto EVAL; - case OP_TC_IF_A_Z_IF_A_LA_Z: tick_tc_rec(sc, sc->cur_op); if (op_tc_if_a_z_if_a_z_la(sc, sc->code, false, TC_IF)) continue; goto EVAL; - case OP_TC_AND_A_IF_A_LA_Z: tick_tc_rec(sc, sc->cur_op); if (op_tc_if_a_z_if_a_z_la(sc, sc->code, false, TC_AND)) continue; goto EVAL; - case OP_TC_AND_A_IF_A_Z_LA: tick_tc_rec(sc, sc->cur_op); if (op_tc_if_a_z_if_a_z_la(sc, sc->code, true, TC_AND)) continue; goto EVAL; - case OP_TC_IF_A_Z_IF_A_Z_LAA: tick_tc_rec(sc, sc->cur_op); if (op_tc_if_a_z_if_a_z_laa(sc, false, sc->code)) continue; goto EVAL; - case OP_TC_IF_A_Z_IF_A_L3A_L3A: tick_tc_rec(sc, sc->cur_op); if (op_tc_if_a_z_if_a_l3a_l3a(sc, sc->code)) continue; goto EVAL; - case OP_TC_IF_A_Z_IF_A_LAA_Z: tick_tc_rec(sc, sc->cur_op); if (op_tc_if_a_z_if_a_laa_z(sc, false, sc->code)) continue; goto EVAL; - case OP_TC_LET_IF_A_Z_LAA: tick_tc_rec(sc, sc->cur_op); if (op_tc_let_if_a_z_laa(sc, sc->code)) continue; goto EVAL; - case OP_TC_IF_A_Z_LET_IF_A_Z_LAA: tick_tc_rec(sc, sc->cur_op); if (op_tc_if_a_z_let_if_a_z_laa(sc, sc->code)) continue; goto EVAL; - case OP_TC_CASE_LA: tick_tc_rec(sc, sc->cur_op); if (op_tc_case_la(sc, sc->code)) continue; goto BEGIN; + case OP_TC_AND_A_OR_A_LA: tick_tc(sc, sc->cur_op); op_tc_and_a_or_a_la(sc, sc->code); continue; + case OP_TC_OR_A_AND_A_LA: tick_tc(sc, sc->cur_op); op_tc_or_a_and_a_la(sc, sc->code); continue; + case OP_TC_AND_A_OR_A_LAA: tick_tc(sc, sc->cur_op); op_tc_and_a_or_a_laa(sc, sc->code); continue; + case OP_TC_OR_A_AND_A_LAA: tick_tc(sc, sc->cur_op); op_tc_or_a_and_a_laa(sc, sc->code); continue; + case OP_TC_AND_A_OR_A_A_LA: tick_tc(sc, sc->cur_op); op_tc_and_a_or_a_a_la(sc, sc->code); continue; + case OP_TC_OR_A_AND_A_A_LA: tick_tc(sc, sc->cur_op); op_tc_or_a_and_a_a_la(sc, sc->code); continue; + case OP_TC_OR_A_A_AND_A_A_LA: tick_tc(sc, sc->cur_op); op_tc_or_a_a_and_a_a_la(sc, sc->code); continue; + case OP_TC_OR_A_AND_A_A_L3A: tick_tc(sc, sc->cur_op); op_tc_or_a_and_a_a_l3a(sc, sc->code); continue; + + case OP_TC_IF_A_Z_LA: tick_tc(sc, sc->cur_op); if (op_tc_if_a_z_la(sc, sc->code, false)) continue; goto EVAL; + case OP_TC_IF_A_LA_Z: tick_tc(sc, sc->cur_op); if (op_tc_if_a_la_z(sc, sc->code, false)) continue; goto EVAL; + case OP_TC_COND_A_Z_LA: tick_tc(sc, sc->cur_op); if (op_tc_if_a_z_la(sc, sc->code, true)) continue; goto EVAL; + case OP_TC_COND_A_LA_Z: tick_tc(sc, sc->cur_op); if (op_tc_if_a_la_z(sc, sc->code, true)) continue; goto EVAL; + + case OP_TC_IF_A_LAA_Z: tick_tc(sc, sc->cur_op); if (op_tc_if_a_z_laa(sc, sc->code, false, TC_IF)) continue; goto EVAL; + case OP_TC_IF_A_Z_LAA: tick_tc(sc, sc->cur_op); if (op_tc_if_a_z_laa(sc, sc->code, true, TC_IF)) continue; goto EVAL; + case OP_TC_COND_A_Z_LAA: tick_tc(sc, sc->cur_op); if (op_tc_if_a_z_laa(sc, sc->code, true, TC_COND)) continue; goto EVAL; + case OP_TC_COND_A_LAA_Z: tick_tc(sc, sc->cur_op); if (op_tc_if_a_z_laa(sc, sc->code, false, TC_COND)) continue; goto EVAL; + + case OP_TC_IF_A_Z_L3A: tick_tc(sc, sc->cur_op); if (op_tc_if_a_z_l3a(sc, sc->code, true)) continue; goto EVAL; + case OP_TC_IF_A_L3A_Z: tick_tc(sc, sc->cur_op); if (op_tc_if_a_z_l3a(sc, sc->code, false)) continue; goto EVAL; + + case OP_TC_IF_A_Z_IF_A_Z_LA: tick_tc(sc, sc->cur_op); if (op_tc_if_a_z_if_a_z_la(sc, sc->code, true, TC_IF)) continue; goto EVAL; + case OP_TC_IF_A_Z_IF_A_LA_Z: tick_tc(sc, sc->cur_op); if (op_tc_if_a_z_if_a_z_la(sc, sc->code, false, TC_IF)) continue; goto EVAL; + case OP_TC_COND_A_Z_A_Z_LA: tick_tc(sc, sc->cur_op); if (op_tc_if_a_z_if_a_z_la(sc, sc->code, true, TC_COND)) continue; goto EVAL; + case OP_TC_COND_A_Z_A_LA_Z: tick_tc(sc, sc->cur_op); if (op_tc_if_a_z_if_a_z_la(sc, sc->code, false, TC_COND))continue; goto EVAL; + case OP_TC_AND_A_IF_A_LA_Z: tick_tc(sc, sc->cur_op); if (op_tc_if_a_z_if_a_z_la(sc, sc->code, false, TC_AND)) continue; goto EVAL; + case OP_TC_AND_A_IF_A_Z_LA: tick_tc(sc, sc->cur_op); if (op_tc_if_a_z_if_a_z_la(sc, sc->code, true, TC_AND)) continue; goto EVAL; + + case OP_TC_IF_A_Z_IF_A_Z_LAA: tick_tc(sc, sc->cur_op); if (op_tc_if_a_z_if_a_z_laa(sc, false, sc->code)) continue; goto EVAL; + case OP_TC_IF_A_Z_IF_A_LAA_Z: tick_tc(sc, sc->cur_op); if (op_tc_if_a_z_if_a_laa_z(sc, false, sc->code)) continue; goto EVAL; + case OP_TC_COND_A_Z_A_Z_LAA: tick_tc(sc, sc->cur_op); if (op_tc_if_a_z_if_a_z_laa(sc, true, sc->code)) continue; goto EVAL; + case OP_TC_COND_A_Z_A_LAA_Z: tick_tc(sc, sc->cur_op); if (op_tc_if_a_z_if_a_laa_z(sc, true, sc->code)) continue; goto EVAL; + + case OP_TC_LET_IF_A_Z_LA: tick_tc(sc, sc->cur_op); if (op_tc_let_if_a_z_la(sc, sc->code)) continue; goto EVAL; + case OP_TC_LET_IF_A_Z_LAA: tick_tc(sc, sc->cur_op); if (op_tc_let_if_a_z_laa(sc, sc->code)) continue; goto EVAL; + case OP_TC_LET_WHEN_LAA: tick_tc(sc, sc->cur_op); op_tc_let_when_laa(sc, true, sc->code); continue; + case OP_TC_LET_UNLESS_LAA: tick_tc(sc, sc->cur_op); op_tc_let_when_laa(sc, false, sc->code); continue; + + case OP_TC_COND_A_Z_A_LAA_LAA: tick_tc(sc, sc->cur_op); if (op_tc_cond_a_z_a_laa_laa(sc, sc->code)) continue; goto EVAL; + case OP_TC_IF_A_Z_IF_A_L3A_L3A: tick_tc(sc, sc->cur_op); if (op_tc_if_a_z_if_a_l3a_l3a(sc, sc->code)) continue; goto EVAL; + case OP_TC_IF_A_Z_LET_IF_A_Z_LAA: tick_tc(sc, sc->cur_op); if (op_tc_if_a_z_let_if_a_z_laa(sc, sc->code)) continue; goto EVAL; + case OP_TC_CASE_LA: tick_tc(sc, sc->cur_op); if (op_tc_case_la(sc, sc->code)) continue; goto BEGIN; + case OP_TC_LET_COND: tick_tc(sc, sc->cur_op); if (op_tc_let_cond(sc, sc->code)) continue; goto EVAL; case OP_RECUR_IF_A_A_opA_LAq: wrap_recur_if_a_a_opa_laq(sc, true, true); continue; case OP_RECUR_IF_A_A_opLA_Aq: wrap_recur_if_a_a_opa_laq(sc, true, false); continue; @@ -93229,6 +93095,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) case OP_RECUR_COND_A_A_A_A_opLAA_LAAq: wrap_recur(sc, op_recur_cond_a_a_a_a_oplaa_laaq); continue; case OP_RECUR_COND_A_A_A_LAA_opA_LAAq: wrap_recur(sc, op_recur_cond_a_a_a_laa_opa_laaq); continue; case OP_RECUR_COND_A_A_A_LAA_LopA_LAAq: wrap_recur_cond_a_a_a_laa_lopa_laaq(sc); continue; + case OP_RECUR_AND_A_OR_A_LAA_LAA: wrap_recur(sc, op_recur_and_a_or_a_laa_laa); continue; case OP_SAFE_CLOSURE_STAR_A: if (!closure_star_is_fine(sc, sc->code, FINE_SAFE_CLOSURE_STAR, 1)) {if (op_unknown_a(sc)) goto EVAL; continue;} @@ -93302,11 +93169,11 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) case OP_UNOPT: goto UNOPT; - case OP_SYM: sc->value = lookup_checked(sc, sc->code); continue; - case OP_GLOBAL_SYM: sc->value = lookup_global(sc, sc->code); continue; - case OP_CON: sc->value = sc->code; continue; - case OP_PAIR_PAIR: op_pair_pair(sc); goto EVAL; /* car is pair ((if x car cadr) ...) */ - case OP_PAIR_ANY: sc->value = car(sc->code); goto EVAL_ARGS_TOP; + case OP_SYM: sc->value = lookup_checked(sc, sc->code); continue; + case OP_GLOBAL_SYM: sc->value = lookup_global(sc, sc->code); continue; + case OP_CON: sc->value = sc->code; continue; + case OP_PAIR_PAIR: op_pair_pair(sc); goto EVAL; /* car is pair ((if x car cadr) ...) */ + case OP_PAIR_ANY: sc->value = car(sc->code); goto EVAL_ARGS_TOP; case OP_PAIR_SYM: sc->value = lookup_global(sc, car(sc->code)); goto EVAL_ARGS_TOP; case OP_EVAL_ARGS5: op_eval_args5(sc); goto APPLY; @@ -93355,7 +93222,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) sc->value = (is_symbol(car_code)) ? lookup_checked(sc, car_code) : T_Pos(car_code); /* sc->value is the current arg's value, sc->code is pointing to the next */ - /* cdr(sc->code) may not be a pair or nil here! (eq? #f . 1) -> sc->code is 1 */ + /* cdr(sc->code) might not be a pair or nil here! (eq? #f . 1) -> sc->code is 1 */ if (is_null(cdr(sc->code))) { if (eval_args_last_arg(sc)) goto EVAL; @@ -93382,7 +93249,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) /* turning this into a call on an array of functions was not a complete disaster, but tauto.scm was ~1.5% slower. * the array-index overhead is the same as the current switch statement's, but there was also the boolean+jump overhead, - * and the function-local overhead currently otherwise 0. + * and the function-local overhead currently otherwise 0 if inlined. */ APPLY: case OP_APPLY: @@ -93648,13 +93515,13 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) case OP_SET_LET_S: /* (set! (*s7* 'print-length) i) */ sc->code = cdr(sc->code); - if (set_pair_p_3(sc, symbol_to_slot(sc, caar(sc->code)), cadr(cadar(sc->code)), lookup(sc, cadr(sc->code)))) + if (set_pair_p_3(sc, lookup_slot_from(caar(sc->code), sc->curlet), cadr(cadar(sc->code)), lookup(sc, cadr(sc->code)))) goto APPLY; continue; case OP_SET_LET_FX: /* (set! (hook 'result) 123) or (set! (H 'c) 32) */ sc->code = cdr(sc->code); - if (set_pair_p_3(sc, symbol_to_slot(sc, caar(sc->code)), cadr(cadar(sc->code)), fx_call(sc, cdr(sc->code)))) + if (set_pair_p_3(sc, lookup_slot_from(caar(sc->code), sc->curlet), cadr(cadar(sc->code)), fx_call(sc, cdr(sc->code)))) goto APPLY; continue; @@ -93907,13 +93774,13 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) case OP_LET_opaSSq_E_OLD: op_let_opassq_e_old(sc); goto EVAL; case OP_LET_opaSSq_E_NEW: op_let_opassq_e_new(sc); goto EVAL; - case OP_LET_STAR_FX: op_let_star_fx(sc); goto BEGIN; - case OP_LET_STAR_FX_A: op_let_star_fx_a(sc); continue; + case OP_LET_STAR_FX: op_let_star_fx(sc); goto BEGIN; + case OP_LET_STAR_FX_A: op_let_star_fx_a(sc); continue; - case OP_NAMED_LET_STAR: op_named_let_star(sc); goto EVAL; - case OP_LET_STAR2: op_let_star2(sc); goto EVAL; + case OP_NAMED_LET_STAR: op_named_let_star(sc); goto EVAL; + case OP_LET_STAR2: op_let_star2(sc); goto EVAL; case OP_LET_STAR: if (check_let_star(sc)) goto EVAL; goto BEGIN; - case OP_LET_STAR1: if (op_let_star1(sc)) goto EVAL; goto BEGIN; + case OP_LET_STAR1: if (op_let_star1(sc)) goto EVAL; goto BEGIN; case OP_LETREC: check_letrec(sc, true); case OP_LETREC_UNCHECKED: if (op_letrec_unchecked(sc)) goto EVAL; goto BEGIN; @@ -94114,23 +93981,24 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) case OP_ERROR_QUIT: if (sc->stack_end <= sc->stack_start) - stack_reset(sc); /* sets stack_end to stack_start, then pushes op_barrier and op_eval_done */ + stack_reset(sc); /* sets stack_end to stack_start, then pushes op_barrier and op_eval_done */ return(sc->F); case OP_ERROR_HOOK_QUIT: op_error_hook_quit(sc); -#if S7_DEBUGGING - fprintf(stderr, "%d: op_error_hook_quit did not jump, sc->value: %s\n", __LINE__, display(sc->value)); /* actually returns #f (below) */ -#endif - case OP_EVAL_DONE_NO_MV: - case OP_EVAL_DONE: return(sc->F); + case OP_EVAL_DONE: + return(sc->F); + + case OP_SPLICE_VALUES: /* if splice_in_values hits eval_done, it needs to continue the splice after returning, so we get here */ + splice_in_values(sc, sc->args); + continue; case OP_GC_PROTECT: case OP_BARRIER: case OP_CATCH_ALL: case OP_CATCH: case OP_CATCH_1: case OP_CATCH_2: continue; - case OP_GET_OUTPUT_STRING: /* from call-with-output-string and with-output-to-string -- return the port string directly */ + case OP_GET_OUTPUT_STRING: /* from call-with-output-string and with-output-to-string -- return the port string directly */ op_get_output_string(sc); /* fall through */ @@ -94199,7 +94067,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) push_stack_no_let_no_code(sc, OP_READ_LIST, sc->args); check_stack_size(sc); sc->value = port_read_name(pt)(sc, pt); - sc->args = cons(sc, sc->value, sc->nil); + sc->args = list_1(sc, sc->value); pair_set_current_input_location(sc, sc->args); c = port_read_white_space(pt)(sc, pt); goto READ_C; @@ -94356,7 +94224,7 @@ typedef enum {SL_NO_FIELD=0, SL_STACK_TOP, SL_STACK_SIZE, SL_STACKTRACE_DEFAULTS SL_MAX_PORT_DATA_SIZE, SL_MAX_STACK_SIZE, SL_CPU_TIME, SL_CATCHES, SL_STACK, SL_MAX_STRING_LENGTH, SL_MAX_FORMAT_LENGTH, SL_MAX_LIST_LENGTH, SL_MAX_VECTOR_LENGTH, SL_MAX_VECTOR_DIMENSIONS, SL_DEFAULT_HASH_TABLE_LENGTH, SL_INITIAL_STRING_PORT_LENGTH, SL_DEFAULT_RATIONALIZE_ERROR, - SL_DEFAULT_RANDOM_STATE, SL_EQUIVALENT_FLOAT_EPSILON, SL_HASH_TABLE_FLOAT_EPSILON, SL_PRINT_LENGTH, + SL_DEFAULT_RANDOM_STATE, SL_EQUIVALENT_FLOAT_EPSILON, SL_HASH_TABLE_FLOAT_EPSILON, SL_PRINT_LENGTH, SL_BIGNUM_PRECISION, SL_MEMORY_USAGE, SL_FLOAT_FORMAT_PRECISION, SL_HISTORY, SL_HISTORY_ENABLED, SL_HISTORY_SIZE, SL_PROFILE, SL_PROFILE_INFO, SL_AUTOLOADING, SL_ACCEPT_ALL_KEYWORD_ARGUMENTS, SL_MOST_POSITIVE_FIXNUM, SL_MOST_NEGATIVE_FIXNUM, SL_OUTPUT_PORT_DATA_SIZE, SL_DEBUG, SL_VERSION, @@ -95270,7 +95138,6 @@ char *s7_decode_bt(s7_scheme *sc) { s7_pointer p; const char *dname; - p = (s7_pointer)vp; dname = decoded_name(sc, p); if (dname) @@ -95278,7 +95145,6 @@ char *s7_decode_bt(s7_scheme *sc) if (bt[i + 1] == ' ') fputc(' ', stdout); fprintf(stdout, "%s[sc->%s]%s", BOLD_TEXT, dname, UNBOLD_TEXT); } - if ((dname) || (is_decodable(sc, p))) { if (bt[i + 1] == ' ') fputc(' ', stdout); @@ -95331,12 +95197,10 @@ static void init_fx_function(void) fx_function[HOP_SAFE_C_opSq_CS] = fx_c_opsq_cs; fx_function[HOP_SAFE_C_S_opSq] = fx_c_s_opsq; fx_function[HOP_SAFE_C_S_opDq] = fx_c_s_opdq; - fx_function[HOP_SAFE_C_opDq_S] = fx_c_opdq_s; fx_function[HOP_SAFE_C_C_opSq] = fx_c_c_opsq; fx_function[HOP_SAFE_C_C_opDq] = fx_c_c_opdq; fx_function[HOP_SAFE_C_opCSq_C] = fx_c_opcsq_c; fx_function[HOP_SAFE_C_opCSq_S] = fx_c_opcsq_s; - fx_function[HOP_SAFE_C_C_opCSq] = fx_c_c_opcsq; fx_function[HOP_SAFE_C_S_opCSq] = fx_c_s_opcsq; fx_function[HOP_SAFE_C_opSSq_C] = fx_c_opssq_c; fx_function[HOP_SAFE_C_opSCq_C] = fx_c_opscq_c; @@ -95349,18 +95213,11 @@ static void init_fx_function(void) fx_function[HOP_SAFE_C_opSq_opSSq] = fx_c_opsq_opssq; fx_function[HOP_SAFE_C_opSSq_opSq] = fx_c_opssq_opsq; fx_function[HOP_SAFE_C_opSSq_opSSq] = fx_c_opssq_opssq; - fx_function[HOP_SAFE_C_op_opSSqq_C] = fx_c_op_opssqq_c; fx_function[HOP_SAFE_C_op_opSqq] = fx_c_op_opsqq; - fx_function[HOP_SAFE_C_op_opSq_Cq] = fx_c_op_opsq_cq; - fx_function[HOP_SAFE_C_op_opSqq_C] = fx_c_op_opsqq_c; fx_function[HOP_SAFE_C_op_S_opSqq] = fx_c_op_s_opsqq; fx_function[HOP_SAFE_C_op_opSq_Sq] = fx_c_op_opsq_sq; - fx_function[HOP_SAFE_C_S_op_S_opSqq] = fx_c_s_op_s_opsqq; fx_function[HOP_SAFE_C_S_op_S_opSSqq] = fx_c_s_op_s_opssqq; - fx_function[HOP_SAFE_C_S_op_opSq_Cq] = fx_c_s_op_opsq_cq; fx_function[HOP_SAFE_C_op_opSSqq_S] = fx_c_op_opssqq_s; - fx_function[HOP_SAFE_C_op_opSSq_Sq_S] = fx_c_op_opssq_sq_s; - fx_function[HOP_SAFE_C_S_op_opSSq_opSSqq] = fx_c_s_op_opssq_opssqq; fx_function[OP_SAFE_C_TUS] = fx_c_tus; fx_function[HOP_SAFE_C_SSC] = fx_c_ssc; @@ -95446,23 +95303,28 @@ static void init_fx_function(void) fx_function[OP_TC_OR_A_AND_A_A_LA] = fx_tc_or_a_and_a_a_la; fx_function[OP_TC_IF_A_Z_LA] = fx_tc_if_a_z_la; fx_function[OP_TC_IF_A_LA_Z] = fx_tc_if_a_la_z; + fx_function[OP_TC_COND_A_Z_LA] = fx_tc_cond_a_z_la; + fx_function[OP_TC_COND_A_LA_Z] = fx_tc_cond_a_la_z; fx_function[OP_TC_IF_A_Z_LAA] = fx_tc_if_a_z_laa; fx_function[OP_TC_IF_A_LAA_Z] = fx_tc_if_a_laa_z; + fx_function[OP_TC_COND_A_Z_LAA] = fx_tc_cond_a_z_laa; + fx_function[OP_TC_COND_A_LAA_Z] = fx_tc_cond_a_laa_z; fx_function[OP_TC_IF_A_Z_L3A] = fx_tc_if_a_z_l3a; fx_function[OP_TC_IF_A_L3A_Z] = fx_tc_if_a_l3a_z; fx_function[OP_TC_IF_A_Z_IF_A_Z_LA] = fx_tc_if_a_z_if_a_z_la; + fx_function[OP_TC_IF_A_Z_IF_A_LA_Z] = fx_tc_if_a_z_if_a_la_z; fx_function[OP_TC_COND_A_Z_A_Z_LA] = fx_tc_cond_a_z_a_z_la; fx_function[OP_TC_COND_A_Z_A_LA_Z] = fx_tc_cond_a_z_a_la_z; - fx_function[OP_TC_IF_A_Z_IF_A_LA_Z] = fx_tc_if_a_z_if_a_la_z; fx_function[OP_TC_AND_A_IF_A_Z_LA] = fx_tc_and_a_if_a_z_la; fx_function[OP_TC_AND_A_IF_A_LA_Z] = fx_tc_and_a_if_a_la_z; fx_function[OP_TC_IF_A_Z_IF_A_LAA_Z] = fx_tc_if_a_z_if_a_laa_z; fx_function[OP_TC_IF_A_Z_IF_A_Z_LAA] = fx_tc_if_a_z_if_a_z_laa; - fx_function[OP_TC_IF_A_Z_IF_A_L3A_L3A] = fx_tc_if_a_z_if_a_l3a_l3a; fx_function[OP_TC_COND_A_Z_A_Z_LAA] = fx_tc_cond_a_z_a_z_laa; fx_function[OP_TC_COND_A_Z_A_LAA_Z] = fx_tc_cond_a_z_a_laa_z; + fx_function[OP_TC_IF_A_Z_IF_A_L3A_L3A] = fx_tc_if_a_z_if_a_l3a_l3a; fx_function[OP_TC_CASE_LA] = fx_tc_case_la; fx_function[OP_TC_OR_A_AND_A_A_L3A] = fx_tc_or_a_and_a_a_l3a; + fx_function[OP_TC_LET_IF_A_Z_LA] = fx_tc_let_if_a_z_la; fx_function[OP_TC_LET_IF_A_Z_LAA] = fx_tc_let_if_a_z_laa; fx_function[OP_TC_LET_WHEN_LAA] = fx_tc_let_when_laa; fx_function[OP_TC_LET_UNLESS_LAA] = fx_tc_let_unless_laa; @@ -95473,6 +95335,7 @@ static void init_fx_function(void) fx_function[OP_RECUR_IF_A_opA_LAq_A] = fx_recur_if_a_opa_laq_a; fx_function[OP_RECUR_IF_A_A_AND_A_LAA_LAA] = fx_recur_if_a_a_and_a_laa_laa; fx_function[OP_RECUR_COND_A_A_A_A_opLA_LAq] = fx_recur_cond_a_a_a_a_opla_laq; + fx_function[OP_RECUR_AND_A_OR_A_LAA_LAA] = fx_recur_and_a_or_a_laa_laa; } static void init_opt_functions(s7_scheme *sc) @@ -95555,8 +95418,6 @@ static void init_opt_functions(s7_scheme *sc) s7_set_p_pp_function(sc, slot_value(global_slot(sc->hash_table_ref_symbol)), hash_table_ref_p_pp); s7_set_p_ppp_function(sc, slot_value(global_slot(sc->hash_table_set_symbol)), hash_table_set_p_ppp); - s7_set_p_pp_unchecked_function(sc, slot_value(global_slot(sc->hash_table_ref_symbol)), s7_hash_table_ref); - s7_set_p_ppp_unchecked_function(sc, slot_value(global_slot(sc->hash_table_set_symbol)), s7_hash_table_set); s7_set_p_ii_function(sc, slot_value(global_slot(sc->complex_symbol)), complex_p_ii); s7_set_p_dd_function(sc, slot_value(global_slot(sc->complex_symbol)), complex_p_dd); @@ -95601,7 +95462,7 @@ static void init_opt_functions(s7_scheme *sc) s7_set_p_pp_function(sc, slot_value(global_slot(sc->cons_symbol)), cons_p_pp); s7_set_p_function(sc, slot_value(global_slot(sc->open_output_string_symbol)), open_output_string_p); s7_set_p_ppi_function(sc, slot_value(global_slot(sc->char_position_symbol)), char_position_p_ppi); - s7_set_p_pp_function(sc, slot_value(global_slot(sc->append_symbol)), append_p_pp); + s7_set_p_pp_function(sc, slot_value(global_slot(sc->append_symbol)), s7_append); s7_set_p_pp_function(sc, slot_value(global_slot(sc->string_append_symbol)), string_append_p_pp); s7_set_p_ppp_function(sc, slot_value(global_slot(sc->append_symbol)), append_p_ppp); s7_set_p_function(sc, slot_value(global_slot(sc->values_symbol)), values_p); @@ -96088,7 +95949,7 @@ static s7_pointer syntax(s7_scheme *sc, const char *name, opcode_t op, s7_pointe /* set_local_slot(x, global_slot(x)); */ set_type_bit(x, T_SYMBOL | T_SYNTACTIC | T_GLOBAL | T_UNHEAP); symbol_set_local_slot_unchecked(x, 0LL, sc->nil); - symbol_set_ctr(x, 0;) + symbol_clear_ctr(x); return(x); } @@ -96096,7 +95957,7 @@ static s7_pointer definer_syntax(s7_scheme *sc, const char *name, opcode_t op, s { s7_pointer x; x = syntax(sc, name, op, min_args, max_args, doc); - set_is_definer(x); + set_syntax_is_definer(x); return(x); } @@ -96275,7 +96136,8 @@ static void init_syntax(s7_scheme *sc) sc->bacro_symbol = definer_syntax(sc, "bacro", OP_BACRO, int_two, max_arity, H_bacro); sc->bacro_star_symbol = definer_syntax(sc, "bacro*", OP_BACRO_STAR, int_two, max_arity, H_bacro_star); sc->with_let_symbol = binder_syntax(sc, "with-let", OP_WITH_LET, int_one, max_arity, H_with_let); - sc->with_baffle_symbol = binder_syntax(sc, "with-baffle", OP_WITH_BAFFLE, int_zero, max_arity, H_with_baffle); /* (with-baffle) is () */ + sc->with_baffle_symbol = definer_syntax(sc, "with-baffle", OP_WITH_BAFFLE, int_zero, max_arity, H_with_baffle); /* (with-baffle) is () */ + set_is_binder(sc->with_baffle_symbol); /* with-baffle introduces a let: (inlet (symbol "(baffle)") #<baffle: 0>) */ set_local_slot(sc->with_let_symbol, global_slot(sc->with_let_symbol)); /* for set_locals */ set_immutable(sc->with_let_symbol); @@ -96283,8 +96145,7 @@ static void init_syntax(s7_scheme *sc) #if WITH_IMMUTABLE_UNQUOTE /* this code solves the various unquote redefinition troubles - * if "," -> "(unquote...)" in the reader, (let (, (lambda (x) (+ x 1))) ,,,,1) -> 5 - * in s7, this requires a quote: (let (, (lambda (x) (+ x 1))) ,,,,'1) + * if "," -> "(unquote...)" in the reader, (let (, (lambda (x) (+ x 1))) ,,,,'1) -> 5 */ sc->unquote_symbol = make_symbol(sc, ","); set_immutable(sc->unquote_symbol); @@ -96451,7 +96312,7 @@ static void init_rootlet(s7_scheme *sc) sc->outlet_symbol = defun("outlet", outlet, 1, 0, false); sc->rootlet_symbol = defun("rootlet", rootlet, 0, 0, false); sc->curlet_symbol = defun("curlet", curlet, 0, 0, false); - set_is_definer(sc->curlet_symbol); + set_func_is_definer(sc->curlet_symbol); sc->unlet_symbol = defun("unlet", unlet, 0, 0, false); set_local_slot(sc->unlet_symbol, global_slot(sc->unlet_symbol)); /* for set_locals */ set_immutable(sc->unlet_symbol); @@ -96459,9 +96320,9 @@ static void init_rootlet(s7_scheme *sc) sc->is_funclet_symbol = defun("funclet?", is_funclet, 1, 0, false); sc->sublet_symbol = defun("sublet", sublet, 1, 0, true); sc->varlet_symbol = unsafe_defun("varlet", varlet, 1, 0, true); - set_is_definer(sc->varlet_symbol); + set_func_is_definer(sc->varlet_symbol); sc->cutlet_symbol = unsafe_defun("cutlet", cutlet, 1, 0, true); - set_is_definer(sc->cutlet_symbol); + set_func_is_definer(sc->cutlet_symbol); sc->inlet_symbol = defun("inlet", inlet, 0, 0, true); sc->owlet_symbol = defun("owlet", owlet, 0, 0, false); sc->coverlet_symbol = defun("coverlet", coverlet, 1, 0, false); @@ -96480,7 +96341,7 @@ static void init_rootlet(s7_scheme *sc) sc->is_provided_symbol = defun("provided?", is_provided, 1, 0, false); sc->provide_symbol = unsafe_defun("provide", provide, 1, 0, false); /* can add *features* to curlet */ - set_is_definer(sc->provide_symbol); + set_func_is_definer(sc->provide_symbol); sc->is_defined_symbol = defun("defined?", is_defined, 1, 2, false); sc->c_object_type_symbol = defun("c-object-type", c_object_type, 1, 0, false); @@ -96810,13 +96671,13 @@ static void init_rootlet(s7_scheme *sc) sc->load_symbol = unsafe_defun("load", load, 1, 1, false); sc->autoload_symbol = defun("autoload", autoload, 2, 0, false); sc->eval_symbol = unsafe_defun("eval", eval, 1, 1, false); - set_is_definer(sc->eval_symbol); + set_func_is_definer(sc->eval_symbol); sc->eval_string_symbol = unsafe_defun("eval-string", eval_string, 1, 1, false); - set_is_definer(sc->eval_string_symbol); + set_func_is_definer(sc->eval_string_symbol); sc->apply_symbol = unsafe_defun("apply", apply, 1, 0, true); { s7_pointer p; - set_is_definer(sc->apply_symbol); + set_func_is_definer(sc->apply_symbol); /* yow... (apply (inlet) (f)) in do body where (f) returns '(define...) -- see s7test.scm under apply * perhaps better: if closure returns a definer in some way set its name as a definer? even this is not fool-proof */ @@ -96826,17 +96687,16 @@ static void init_rootlet(s7_scheme *sc) } sc->for_each_symbol = unsafe_defun("for-each", for_each, 2, 0, true); sc->map_symbol = unsafe_defun("map", map, 2, 0, true); - sc->dynamic_wind_symbol = unsafe_defun("dynamic-wind", dynamic_wind, 3, 0, false); sc->dynamic_unwind_symbol = unsafe_defun("dynamic-unwind", dynamic_unwind, 2, 0, false); - - /* sc->values_symbol = */ unsafe_defun("values", values, 0, 0, true); /* not safe because it assumes caller is on the stack */ sc->catch_symbol = unsafe_defun("catch", catch, 3, 0, false); sc->throw_symbol = unsafe_defun("throw", throw, 1, 0, true); sc->error_symbol = unsafe_defun("error", error, 0, 0, true); /* it's faster to leave error/throw unsafe than to set needs_copied_args and use s7_define_safe_function because copy_proper_list overwhelms any other savings */ sc->stacktrace_symbol = defun("stacktrace", stacktrace, 0, 5, false); + /* sc->values_symbol = */ unsafe_defun("values", values, 0, 0, true); /* values_symbol set above for signatures */ + sc->values_uncopied = make_unsafe_function_with_class(sc, set_function_chooser(sc, sc->values_symbol, values_chooser), "values", splice_in_values, 0, 0, true); sc->apply_values_symbol = unsafe_defun("apply-values", apply_values, 0, 1, false); set_immutable(sc->apply_values_symbol); sc->list_values_symbol = defun("list-values", list_values, 0, 0, true); /* was unsafe_defun 26-Jul-19 */ @@ -97079,7 +96939,7 @@ s7_scheme *s7_init(void) unique_car(sc->nil) = sc->unspecified; unique_cdr(sc->nil) = sc->unspecified; /* this is mixing two different s7_cell structs, cons and envr, but luckily envr has two initial s7_pointer fields, equivalent to car and cdr, so - * let_id which is the same as opt1 is unaffected. To get the names built-in, I'll append unique_name and unique_name_length fields to the envr struct. + * let_id which is the same as opt1 is unaffected. To get the names built-in, I'll append unique_name and unique_name_length fields to the envr struct. */ let_set_id(sc->nil, -1); unique_cdr(sc->unspecified) = sc->unspecified; @@ -97158,7 +97018,11 @@ s7_scheme *s7_init(void) sc->autoload_names_sizes = NULL; sc->autoloaded_already = NULL; sc->autoload_names_loc = 0; +#if DISABLE_AUTOLOAD + sc->is_autoloading = false; +#else sc->is_autoloading = true; +#endif sc->rec_stack = NULL; sc->heap_size = INITIAL_HEAP_SIZE; @@ -97334,17 +97198,16 @@ s7_scheme *s7_init(void) rootlet_element(sc->rootlet, i) = sc->nil; sc->curlet = sc->nil; sc->shadow_rootlet = sc->nil; + sc->objstr_max_len = S7_INT64_MAX; init_wrappers(sc); init_standard_ports(sc); init_rootlet(sc); init_open_input_function_choices(sc); - sc->objstr_max_len = S7_INT64_MAX; - { s7_pointer p; - new_cell(sc, p, T_RANDOM_STATE); + new_cell(sc, p, T_RANDOM_STATE); /* s7_set_default_random_state might set sc->default_rng, so this shouldn't be permanent */ sc->default_rng = p; sc->bignum_precision = DEFAULT_BIGNUM_PRECISION; @@ -97515,7 +97378,7 @@ s7_scheme *s7_init(void) if (!s7_type_names[0]) {fprintf(stderr, "no type_names\n"); gdb_break();} /* squelch very stupid warnings! */ 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 != 938) 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 != 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)); /* cell size: 48, 120 if debugging, block size: 40, opt: 128 or 280 */ #endif @@ -97776,6 +97639,10 @@ static void dumb_repl(s7_scheme *sc) void s7_repl(s7_scheme *sc) { +#if (!WITH_C_LOADER) + dumb_repl(sc); +#else + s7_pointer old_e, e, val; s7_int gc_loc; /* try to get lib_s7.so from the repl's directory, and set *libc*. @@ -97801,6 +97668,10 @@ void s7_repl(s7_scheme *sc) dumb_repl(sc); else { +#if S7_DEBUGGING + s7_autoload(sc, s7_make_symbol(sc, "compare-calls"), s7_make_string(sc, "compare-calls.scm")); + s7_autoload(sc, s7_make_symbol(sc, "get-overheads"), s7_make_string(sc, "compare-calls.scm")); +#endif s7_provide(sc, "libc.scm"); #if WITH_NREPL s7_load(sc, "nrepl.scm"); @@ -97810,11 +97681,12 @@ void s7_repl(s7_scheme *sc) s7_eval_c_string(sc, "((*repl* 'run))"); #endif } +#endif } #if (WITH_MAIN && (!USE_SND)) -#if (!MS_WINDOWS) +#if (!MS_WINDOWS) && WITH_C_LOADER static char *realdir(const char *filename) /* this code courtesy Lassi Kortela 4-Nov-19 */ { char *path; @@ -97866,7 +97738,7 @@ int main(int argc, char **argv) }} else { -#if (MS_WINDOWS) || ((defined(__linux__)) && (!defined(__GLIBC__))) /* musl? */ +#if (MS_WINDOWS) || (!WITH_C_LOADER) || ((defined(__linux__)) && (!defined(__GLIBC__))) /* musl? */ dumb_repl(sc); #else #ifdef S7_LOAD_PATH @@ -97896,63 +97768,66 @@ int main(int argc, char **argv) #endif #endif -/* -------------------------------------------------------- - * - * new snd version: snd.h configure.ac HISTORY.Snd NEWS barchive diffs s7-YYYYMMDD.tar.gz, /usr/ccrma/web/html/software/snd/index.html, ln -s (see .cshrc) - * tests7 compsnd testsnd autotest - * - * ----------------------------- - * 20.9 gmp - * ----------------------------- - * tpeak 115 128 - * tauto 648 1200 - * tref 691 741 - * tshoot 883 1673 - * index 1026 1087 - * tmock 1177 7733 - * s7test 1873 4525 - * lt 2123 2111 - * tcopy 2256 2313 - * tform 2281 3256 - * tmat 2285 2485 - * tread 2440 2639 - * tvect 2456 2687 - * fbench 2688 3091 - * trclo 2715 4502 - * tb 2735 3554 - * titer 2865 2883 - * tmap 2886 3825 - * tsort 3105 3809 - * tset 3253 3253 - * dup 3334 3548 - * tmac 3317 3430 - * teq 4068 4078 - * tfft 4142 11.5 - * tio 4575 4595 - * tmisc 4626 5077 - * tclo 4787 5119 - * tlet 4925 5863 - * tcase 4960 5010 - * tstr 5281 - * trec 5976 7825 - * tnum 6348 58.3 - * tgen 11.2 12.0 - * thash 11.8 37.5 - * tgc 11.9 - * tall 15.6 27.0 - * calls 36.7 60.6 - * sg 71.9 97.9 - * lg 106.6 106.7 - * tbig 177.4 603.6 - * ----------------------------- +/* ------------------------------------- + * gmp 20.9 21.0 + * ------------------------------------- + * tpeak 128 115 114 + * tauto 778 648 642 + * tref 736 691 687 + * tshoot 1663 883 872 + * index 1074 1026 1016 1014 + * tmock 7697 1177 1165 + * s7test 4546 1873 1831 + * lt 2115 2123 2110 2109 + * tcopy 2290 2256 2230 + * tmat 2412 2285 2258 + * tform 3251 2281 2273 + * tread 2610 2440 2421 2408 + * tvect 2669 2456 2413 + * trclo 4309 2715 2561 + * fbench 2983 2688 2583 + * tb 3474 2735 2681 + * titer 2860 2865 2842 + * tmap 3785 2886 2857 + * tsort 3821 3105 3104 + * tset 3093 3253 3104 + * tmac 3343 3317 3277 3249 + * dup 3589 3334 3332 3319 + * tio 3843 3816 3752 + * teq 4054 4068 4045 + * tfft 11.3 4142 4109 + * tclo 5051 4787 4735 + * tcase 4850 4960 4793 4772 + * tlet 5782 4925 4908 + * tstr 6995 5281 4863 + * trec 7763 5976 5970 + * tnum 59.5 6348 6013 + * tmisc 6490 7389 6210 6170 + * tgc 12.6 11.9 11.1 + * tgen 12.0 11.2 11.4 + * thash 37.4 11.8 11.7 + * tall 26.9 15.6 15.6 + * calls 60.2 36.7 37.5 37.2 + * sg 97.4 71.9 72.3 + * lg 105.5 106.6 105.0 + * tbig 601.8 177.4 175.8 175.6 + * ------------------------------------- * - * map or: safety? - * perhaps substring_uncopied_unchecked, start_and_end with arg offset preset+whether end is passed, substr in opt_p_call_ssf: substr_p_p[p|i][p|i] - * loop at ca 88150 int case split out? (time seems to be in the boolean) - * substring chooser, but needs uncopied choice - * check char_upcase|eq_unchecked for char_position etc - * p_p[p]_unchecked could be installed in p_pp_ok (it's only used if sig and symbol cadr??): currently no p_p_unchecked type - * there is only one p_pp_unchecked case: hash-table-ref! tmp has char_eq_p_pp_unchecked - * cond-a-z-la|a-la-z - * floor/ et al happen a lot -- if ints, avoid ratio + * notcurses 2.1 diffs + * recur_if_a_a_opL3a_L3aq? + * extend fx_funcs by recur/tc cases, let, etc (s7test?) + * unsafe_s is currently "a" + * let_fp et al (using has_gx etc), also can fxable/s7_optimize mark needed ops? if..if..p + * fx_call not fx* in eval? (check tus case too) + * if target func known, why not use direct rather than tn_n? or specialize t3_n callee etc) + * possibly c_op[a|c|s][a|c|s]q + * possibly op_opsq_sq -> not_opsq_s, tu cases in these (see fx_tree_in) + * qq copy-tree (not car if immutable, or set entire thing immutable?) + * t725 functional exprs (args too?) + * fixup ((let () cond|with-let)...) fx flags (t718), but not if! + * with-baffle use baffle flag on empty let, extra let field for id (so baffle is not a definer) [see find_baffle and find_any_baffle, op_with_baffle_unchecked] + * there are many opt3_any -> con cases, check opt*_any [opt1..3, about 65 of each] + * more complex eval_done+mv tests + * need cyclic check in copy_tree + * t718 troubles */ @@ -2,7 +2,9 @@ #define S7_H #define S7_VERSION "9.7" -#define S7_DATE "23-11-2020" +#define S7_DATE "31-12-2020" +#define S7_MAJOR_VERSION 9 +#define S7_MINOR_VERSION 7 #include <stdint.h> /* for int64_t */ @@ -5526,7 +5526,7 @@ rootlet-size the number of globals heap-size total cells currently available max-heap-size maximum heap size free-heap-size the number of currently unused cells -gc-stats 0 (or #f), 1: show GC activity, 2: heap, 4: stack, #t = 1 +gc-stats 0 (or #f), 1: show GC activity, 2: heap, 4: stack, 8: protected_objects, #t = 1 gc-freed number of cells freed by the last GC pass gc-total-freed number of cells freed so far by the GC; the total allocated is probably close to (with-let *s7* (+ (- heap-size free-heap-size) gc-total-freed)) @@ -5193,8 +5193,6 @@ void block_init(s7_scheme *sc) 3.14 3/4 1.0+1.0i #f #t :hi (if #f #f) (lambda (a) (+ a 1))))) (list char-upper-case? char-lower-case? char-upcase char-downcase char-numeric? char-whitespace? char-alphabetic?)) - - (test (let ((unhappy ())) (do ((i 0 (+ i 1))) @@ -9585,6 +9583,11 @@ i" (lambda (p) (eval (read p)))) pi) (list "hi" (integer->char 65) #f 'a-symbol (make-vector 3) abs _ht_ _undef_ _null_ _c_obj_ quasiquote macroexpand 1/0 (log 0) 3.14 3/4 1.0+1.0i #\f #t :hi (if #f #f) (lambda (a) (+ a 1)))) +(test (catch #t + (lambda () (let ((L1 (list 1))) (list-set! L1 3 0))) + (lambda (type info) (apply format #f info))) + "list-set! argument 2, 3, is out of range (it is too large)") + ;;; -------------------------------------------------------------------------------- @@ -11937,6 +11940,15 @@ i" (lambda (p) (eval (read p)))) pi) (list #\a "hi" () (list 1) '(1 . 2) 'a-symbol (make-vector 3) abs _ht_ _undef_ _null_ _c_obj_ quasiquote macroexpand 1/0 (log 0) 3.14 3/4 1.0+1.0i #t :hi (if #f #f) (lambda (a) (+ a 1)))) +(let () ; vector_to_list_p_p + (define (f) + (let ((v (vector 1 2 3))) + (do ((i 0 (+ i 1))) + ((= i 1) v) + (vector-set! v 0 (vector->list #())) + (vector-set! v 1 (vector->list #(4 5 6)))))) + (test (f) #(() (4 5 6) 3))) + ;;; -------------------------------------------------------------------------------- @@ -15095,6 +15107,25 @@ i" (lambda (p) (eval (read p)))) pi) ")) #t))) +;;; #_ stuff +(test ((lambda () (if (#_round pi) #f))) #f) +(test ((lambda () (when (#_round pi) #f))) #f) +(test ((lambda () (#_cond (* 1)))) 1) +(test (let () (define (f1) (abs (#_logand))) (f1)) 1) +(test ((lambda () (abs (#_logand)))) 1) +(test ((lambda () (abs (#_logand 2 3)))) 2) +(test (call-with-exit (lambda (g) (abs (#_logand)))) 1) +(test (let () (define (func) (append (#_begin (tree-cyclic?)))) (func)) 'error) +(test (let () (define (func) (do ((x 0.0 (+ x 0.1)) (i 0 (+ i 1))) ((>= x .1) (#_with-baffle (inlet (values 1 2) (symbol? x)))))) (func)) 'error) +(test (let () (define (func) (do ((i 0 (+ i 1))) ((= i 1)) (#_provide :readable))) (func)) #t) +(test (pair? (let () + (define (func) + (list-values (#_quasiquote (odd?)) (let ((<1> (list 1 #f))) (set! (<1> 1) (let ((<L> (list #f 3))) (set-car! <L> <1>) <L>)) <1>))) + (func))) + #t) +(test (let () (define (hi) (let ((x 0) (i 3)) (do ((i i (+ i 1))) ((= i 6)) (do ((i i (+ i 1))) ((= i 7)) (set! x (+ x i)))) x)) (hi)) 44) + + ;;; -------------------------------------------------------------------------------- ;;; HASH-TABLES @@ -18264,7 +18295,7 @@ i" (lambda (p) (eval (read p)))) pi) (test (with-output-to-string (lambda () (display _undef_))) "#_asdf") (test (with-output-to-string (lambda () (write _undef_))) "#_asdf") -(test (with-output-to-string (lambda () (make-string (+ (s7-max-string-length) 10)))) 'error) +(test (with-output-to-string (lambda () (make-string (+ (*s7* 'max-string-length) 10)))) 'error) (test (open-input-file "tools") 'error) (let () @@ -20855,14 +20886,15 @@ a2" 3) "132") "") (set! (current-output-port) *stdout*)) -(let-temporarily (((current-output-port) #f)) +(let-temporarily (((current-output-port) #f) + ((*s7* 'max-string-length) 32)) (catch #t (lambda () (with-output-to-string (lambda () (display (symbol - (make-string (s7-max-string-length))))))) + (make-string (*s7* 'max-string-length))))))) (lambda args 'error)) (when (current-output-port) @@ -22839,6 +22871,7 @@ c" (require libm.scm) (when (defined? '*libm*) (testlet *libm*)) + (test (load (append "/home/" username "/cl/libm_s7.so") (inlet 'init_func 'libm_s7_init)) #f) ; check full-filename with absolute path (require libgsl.scm) (when (defined? '*libgsl*) (testlet *libgsl*)) @@ -24106,6 +24139,9 @@ c" (test (t1 #f) #<unspecified>) (test (t1 #t) 2)) +(test ((let () when) #t 32) 32) +(test ((let () when) #f 32) #<unspecified>) + ;;; unless (test (unless #t #f) #<unspecified>) @@ -26044,9 +26080,9 @@ in s7: (if (< pos 3) (let ((p pos)) (set! pos (+ pos 1)) - (values p (* p 2))) ; ?? maybe this is inconsistent? + (list p (* p 2))) #<eof>)))))) - (test (map values iter) '(0 0 1 2 2 4))) + (test (map values iter) '((0 0) (1 2) (2 4)))) (let () (define (make-row-iterator v) @@ -26416,6 +26452,15 @@ in s7: (test (let () (define (f lst) (do ((lst lst (cddr lst)) (a () (cons (car lst) a))) ((null? lst) a))) (f '(1 2 3 4))) '(3 1)) (test (let () (define (func) (do ((i 0 (+ i 1))) ((= i 1)) (list func cond (quote (nan? "") (append (lambda*)))))) (func)) 'error) +(let () + (define (strcop str) ; opt_dotimes >= case (coverage) + (let* ((len (length str)) + (new-str (make-string (+ len 3) #\a))) + (do ((i 0 (+ i 1))) + ((>= i len) new-str) + (string-set! new-str i (string-ref str i))))) + (test (strcop "123") "123aaa")) + (let ((dbac (bacro* (c) `(provide 'asdf)))) ; check fx_tree choice in op_dox portion of check_do (define (func) (do ((x #f) (i 0 (+ i 1))) ((= i 1) x) (set! x (dbac)))) (test (func) 'asdf)) @@ -26502,6 +26547,11 @@ in s7: (let () (define (f1) (let ((end 3) (v (vector 0 0 0))) (vector (do ((i 0 (+ i 1))) ((= i end)) (vector-set! v i (abs i))) v))) (test (f1) #(#t #(0 1 2)))) (let () (define (f1) (let ((v (vector 0 0 0))) (do ((i 0 (+ i 1))) ((= i 3) v) (display i #f) (vector-set! v i (abs i))))) (test (f1) #(0 1 2))) +(let () ; op_dox gxable section (coverage) + (define (f2 x) (floor x)) + (define (ftst2) (do ((i 1 (+ i 1)) (j 1.0 (+ j 0.21))) ((= i 10) (f2 j)) (f2 j))) + (test (ftst2) 2)) + (let () (define (f1) (let ((v (vector 0 0 0))) (do ((i 0 (+ i 1))) ((= i 0) v) (vector-set! v i (abs i))))) (test (f1) #(0 0 0))) (let () (define (safe-do-all-x) @@ -26860,6 +26910,69 @@ in s7: (fdo3) (fdo4)) +;; next 7 are probing 2 bugs in opt_cell_do +(let () + (define (ho1) + (let ((x 0) (i 3)) + (do ((i i (+ i 1))) ((= i 6)) + (do ((z 12) (i i (+ i 1))) ((= i 7)) (set! x (+ x i)))) + x)) + (test (ho1) 44)) + +(let () + (define (ho2) + (let ((x 0) (i 3)) + (do ((i i (+ i 1))) ((= i 6)) + (do ((j i (+ j 1))) ((= j 7)) (set! x (+ x j)))) + x)) + (test (ho2) 44)) + +(let () + (define (ho3) + (let ((x 0) (k 3)) + (do ((i k (+ i 1))) ((= i 6)) + (do ((j i (+ j 1))) ((= j 7)) (set! x (+ x j)))) + x)) + (test (ho3) 44)) + +(let () + (define (ho4) + (let ((x (vector 0)) (k 3)) + (do ((i k (+ i 1))) ((= i 6)) + (do ((j i (+ j 1))) ((= j 7)) (vector-set! x 0 (+ (vector-ref x 0) j)))) ; also int-vector, list, but not car! + x)) + (test (ho4) #(44))) + +(let () + (define (ho5) + (let ((x (vector 0)) (k 3)) + (let loop1 ((i k)) + (when (< i 6) (do ((j i (+ j 1))) ((= j 7)) (vector-set! x 0 (+ (vector-ref x 0) j))) + (loop1 (+ i 1)))) + x)) + (test (ho5) #(44))) + +(let () + (define (ho6) + (let ((x (vector 0)) (k 3)) + (let loop1 ((i k)) + (when (< i 6) + (let loop2 ((j i)) + (when (< j 7) + (vector-set! x 0 (+ (vector-ref x 0) j)) + (loop2 (+ j 1)))) + (loop1 (+ i 1)))) + x)) + (test (ho6) #(44))) + +(let () + (define (ho7) + (let ((x (list 0)) (k 3)) + (do ((i k (+ i 1))) ((= i 6)) + (do ((j i (+ j 1))) ((= j 7)) (set-car! x (+ (car x) j)))) + x)) + (test (ho7) '(44))) + (let () (define (f6 x) (let ((j 32)) @@ -28989,6 +29102,15 @@ in s7: (define (tc-if-a-z-l3a-1 x y z) (if (null? x) (begin (vector-set! y 0 (+ z 32)) y) (tc-if-a-z-l3a-1 (cdr x) y (+ z 1)))) (test (tc-if-a-z-l3a-1 '(1 2 3) #(1 2 3) 1) #(36 2 3)) + (define (tc-if-a-z-l3a-2 x y z) (if (null? x) (+ y z) (tc-if-a-z-l3a-2 (cdr x) y (+ z 1)))) + (test (tc-if-a-z-l3a-2 '(1 2 3) 2 3) 8) + + (define (tc-if-a-z-l3a-3 x y z) (if (null? x) (+ y z) (tc-if-a-z-l3a-3 (cdr x) y))) + (test (tc-if-a-z-l3a-3 '(1 2 3) #(1 2 3) 1) 'error) + + (define (tc-if-a-z-l3a-4 x y z) (if (null? x) (+ y z) (tc-if-a-z-l3a-4 (cdr x) y z (+ z 1)))) + (test (tc-if-a-z-l3a-4 '(1 2 3) #(1 2 3) 1) 'error) + ;; -------- OP_TC_IF_A_L3A_Z -------- (define (tc-if-a-l3a-z-1 x y z) (if (pair? x) (tc-if-a-l3a-z-1 (cdr x) y (+ z 1)) (begin (vector-set! y 0 (+ z 32)) y))) (test (tc-if-a-l3a-z-1 '(1 2 3) #(1 2 3) 1) #(36 2 3)) @@ -29029,6 +29151,184 @@ in s7: (define (fx-tc-if-a-la-z x) (if (> x 0) (fx-tc-if-a-la-z (- x 1)) 12)) (test (let ((z 10)) (define (ftc-3 x) (+ x (fx-tc-if-a-la-z 10))) (ftc-3 z)) 22) + ;; -------- OP_TC_COND_A_Z_LA -------- + (define (tc-cond-a-z-la-1 x) (cond ((zero? x) 3) (else (tc-cond-a-z-la-1 (- x 1))))) + (test (tc-cond-a-z-la-1 10) 3) + + (define (tc-cond-a-z-la-2 x) (cond ((zero? x) (let ((z (+ x 1))) z)) (else (tc-cond-a-z-la-2 (- x 1))))) + (test (tc-cond-a-z-la-2 10) 1) + + (define tc-cond-a-z-la-3 (let ((y #(10))) (lambda (x) (cond ((zero? (vector-ref y 0)) y) (else (tc-cond-a-z-la-3 (vector-set! y 0 (- (vector-ref y 0) 1)))))))) + (test (tc-cond-a-z-la-3 10) #(0)) + + (define (tc-cond-a-z-la-4 x) (cond ((zero? x) 3) (else (tc-cond-a-z-la-4)))) + (test (tc-cond-a-z-la-4 10) 'error) + + (define (tc-cond-a-z-la x) (cond ((= x 0) 12) (else (tc-cond-a-z-la (- x 1))))) + (test (let ((z 10)) (define (ftc-2 x) (+ x (tc-cond-a-z-la 10))) (ftc-2 z)) 22) + + ;; -------- OP_TC_COND_A_LA_Z -------- + (define (tc-cond-a-la-z-1 x) (cond ((positive? x) (tc-cond-a-la-z-1 (- x 1))) (else 3))) + (test (tc-cond-a-la-z-1 10) 3) + + (define (tc-cond-a-la-z-2 x) (cond ((positive? x) (tc-cond-a-la-z-2 (- x 1))) (else (let ((z (+ x 1))) z)))) + (test (tc-cond-a-la-z-2 10) 1) + + (define (tc-cond-a-la-z-3 x) (cond ((positive? x) (tc-cond-a-la-z-3 (- x 1) (+ y 1))) (else 3))) + (test (tc-cond-a-la-z-3 10) 'error) + + (define (tc-cond-a-la-z-4 x) (cond ((positive? x) (tc-cond-a-la-z-4)) (else 3))) + (test (tc-cond-a-la-z-4 10) 'error) + + (define (fx-tc-cond-a-la-z x) (cond ((> x 0) (fx-tc-cond-a-la-z (- x 1))) (else 12))) + (test (let ((z 10)) (define (ftc-3 x) (+ x (fx-tc-cond-a-la-z 10))) (ftc-3 z)) 22) + + (let () + (define (if-a-z-la p) + (if (null? (cdr p)) + (car p) + (if-a-z-la (cdr p)))) + + (define (cond-a-z-la p) + (cond ((null? (cdr p)) + (car p)) + (else (cond-a-z-la (cdr p))))) + + (define (if-a-la-z p) + (if (pair? (cdr p)) + (if-a-la-z (cdr p)) + (car p))) + + (define (cond-a-la-z p) + (cond ((pair? (cdr p)) + (cond-a-la-z (cdr p))) + (else (car p)))) + + (define big-list (let ((L (make-list 5 0))) + (set! (list-ref L 4) 1) + L)) + + (define (f1) + (do ((i 0 (+ i 1)) + (sum 0)) + ((= i 2) sum) + (set! sum (+ sum (if-a-z-la big-list))))) + + (define (f2) + (do ((i 0 (+ i 1)) + (sum 0)) + ((= i 2) sum) + (set! sum (+ sum (cond-a-z-la big-list))))) + + (define (f3) + (do ((i 0 (+ i 1)) + (sum 0)) + ((= i 2) sum) + (set! sum (+ sum (if-a-la-z big-list))))) + + (define (f4) + (do ((i 0 (+ i 1)) + (sum 0)) + ((= i 2) sum) + (set! sum (+ sum (cond-a-la-z big-list))))) + + (test (f1) 2) + (test (f3) 2) + (test (f2) 2) + (test (f4) 2)) + + ;; -------- OP_TC_COND_A_Z_LAA -------- + (define (tc-cond-a-z-laa-1 x q) (cond ((zero? x) q) (else (tc-cond-a-z-laa-1 (- x 1) (+ q 1))))) + (test (tc-cond-a-z-laa-1 10 0) 10) + + (define (tc-cond-a-z-laa-2 x q) (cond ((zero? x) (let ((z (+ x q))) z)) (else (tc-cond-a-z-laa-2 (- x 1) (+ q 1))))) + (test (tc-cond-a-z-laa-2 10 0) 10) + + (define tc-cond-a-z-laa-3 (let ((y #(10))) (lambda (x q) (cond ((zero? (vector-ref y 0)) q) (else (tc-cond-a-z-laa-3 (vector-set! y 0 (- (vector-ref y 0) 1)) (+ q 1))))))) + (test (tc-cond-a-z-laa-3 10 0) 10) + + (define (tc-cond-a-z-laa-4 x q) (cond ((zero? x) q) (else (tc-cond-a-z-laa-4 x)))) + (test (tc-cond-a-z-laa-4 10 0) 'error) + + (define (tc-cond-a-z-laa-5 x q) (cond ((zero? x) q) (else (tc-cond-a-z-laa-5 x q q)))) + (test (tc-cond-a-z-laa-5 10 0) 'error) + + (define (tc-cond-a-z-laa-6 x q) (cond ((zero? x) q) (else (tc-cond-a-z-laa-6)))) + (test (tc-cond-a-z-laa-6 10 0) 'error) + + (define (tc-cond-a-z-laa x q) (cond ((= x 0) (+ q 2)) (else (tc-cond-a-z-laa (- x 1) (+ q 1))))) + (test (let ((z 10)) (define (ftc-2 x) (+ x (tc-cond-a-z-laa 10 0))) (ftc-2 z)) 22) + + ;; -------- OP_TC_COND_A_LAA_Z -------- + (define (tc-cond-a-laa-z-1 x q) (cond ((positive? x) (tc-cond-a-laa-z-1 (- x 1) (+ q 1))) (else q))) + (test (tc-cond-a-laa-z-1 10 0) 10) + + (define (tc-cond-a-laa-z-2 x q) (cond ((positive? x) (tc-cond-a-laa-z-2 (- x 1) (+ q 1))) (else (let ((z (+ q x 1))) z)))) + (test (tc-cond-a-laa-z-2 10 0) 11) + + (define (tc-cond-a-laa-z-3 x q) (cond ((positive? x) (tc-cond-a-laa-z-3 (- x 1) (+ y 1) 1)) (else 3))) + (test (tc-cond-a-laa-z-3 10 0) 'error) + + (define (tc-cond-a-laa-z-4 x q) (cond ((positive? x) (tc-cond-a-laa-z-4 x)) (else 3))) + (test (tc-cond-a-laa-z-4 10 0) 'error) + + (define (fx-tc-cond-a-laa-z x q) (cond ((> x 0) (fx-tc-cond-a-laa-z (- x 1) (+ q 1))) (else (+ q 2)))) + (test (let ((z 10)) (define (ftc-3 x) (+ x (fx-tc-cond-a-laa-z 10 0))) (ftc-3 z)) 22) + + (let () + (define (if-a-z-laa p q) + (if (null? p) + q + (if-a-z-laa (cdr p) (+ q (car p))))) + + (define (cond-a-z-laa p q) + (cond ((null? p) + q) + (else (cond-a-z-laa (cdr p) (+ q (car p)))))) + + (define (if-a-laa-z p q) + (if (pair? p) + (if-a-laa-z (cdr p) (+ q (car p))) + q)) + + (define (cond-a-laa-z p q) + (cond ((pair? p) + (cond-a-laa-z (cdr p) (+ q (car p)))) + (else q))) + + (define big-list (let ((L (make-list 10 0))) + (set! (list-ref L 9) 1) + L)) + + (define (f1) + (do ((i 0 (+ i 1)) + (sum 0)) + ((= i 10) sum) + (set! sum (+ sum (if-a-z-laa big-list 0))))) + + (define (f2) + (do ((i 0 (+ i 1)) + (sum 0)) + ((= i 10) sum) + (set! sum (+ sum (cond-a-z-laa big-list 0))))) + + (define (f3) + (do ((i 0 (+ i 1)) + (sum 0)) + ((= i 10) sum) + (set! sum (+ sum (if-a-laa-z big-list 0))))) + + (define (f4) + (do ((i 0 (+ i 1)) + (sum 0)) + ((= i 10) sum) + (set! sum (+ sum (cond-a-laa-z big-list 0))))) + + (test (f1) 10) + (test (f3) 10) + (test (f2) 10) + (test (f4) 10)) + ;; -------- OP_TC_IF_A_Z_IF_A_Z_LA -------- (define (tc-if-a-z-if-a-z-la-1 x) (if (zero? (modulo x 7)) x (if (zero? (modulo x 5)) x (tc-if-a-z-if-a-z-la-1 (+ x 1))))) (test (tc-if-a-z-if-a-z-la-1 22) 25) @@ -29224,6 +29524,23 @@ in s7: (define (tc-if-a-z-if-a-laa-z-6 x y) (if (zero? (modulo x y)) x (if (positive? (modulo x 5)) (tc-if-a-z-if-a-laa-z-6 x y y) x))) (test (tc-if-a-z-if-a-laa-z-6 22 7) 'error) + ;; -------- OP_TC_LET_IF_A_Z_LA -------- + + (define (tc-let-if-a-z-la-1 x) (let ((y (- x 1))) (if (<= y 0) 0 (tc-let-if-a-z-la-1 (- x 1))))) + (test (tc-let-if-a-z-la-1 3) 0) + + (define (tc-let-if-a-z-la-2 x) (let ((y (- x 1))) (if (<= y 1) (let* ((z (* 2 x))) (+ z 1)) (tc-let-if-a-z-la-2 (- x 1))))) + (test (tc-let-if-a-z-la-2 3) 5) + + (define (tc-let-if-a-z-la-3 x) (let ((y (- x 1))) (if (<= y 0) 0 (tc-let-if-a-z-la-3 (- x 1) 2)))) + (test (tc-let-if-a-z-la-3 3) 'error) + + (define (tc-let-if-a-z-la-4 x) (let ((y (- x 1))) (if (<= y 0) 0 (tc-let-if-a-z-la-4)))) + (test (tc-let-if-a-z-la-4 3) 'error) + + (define (tc-let-if-a-z-la-5 x) (let ((y (- x 1))) (if (<= y 0) (* x 12) (tc-let-if-a-z-la-5 (- x 1))))) + (test (tc-let-if-a-z-la-5 3) 12) + ;; -------- OP_TC_LET_IF_A_Z_LAA -------- (define (tc-let-if-a-z-laa-1 x y) (let ((z (+ y 1))) (if (null? x) z (tc-let-if-a-z-laa-1 (cdr x) (+ y 1))))) (test (tc-let-if-a-z-laa-1 '(1 2 3) 0) 4) @@ -29818,6 +30135,37 @@ in s7: (tree-eq-3? (cdr a) (cdr b))))) (test (tree-eq-3? '(1 (b c 2) ((3))) '(1 (b c 2) ((3)))) 'error) + ;; -------- OP_RECUR_AND_A_OR_A_LAA_LAA -------- + (define (tm1 sym tree) + (and (pair? tree) + (or (equal? (car tree) sym) + (tm1 sym (car tree)) + (tm1 sym (cdr tree))))) + (test (tm1 1 '(2 4 (3 1) 2)) #t) + (test (tm1 1 '(2 4 (3 5) 2)) #f) + (test (tm1 '(+ x 2) '(abs (log (+ x 2)))) #t) + + (define (tm2 sym tree) + (and (call-with-exit (lambda (return) (return (pair? tree)))) + (or (equal? (car tree) sym) + (tm2 sym (car tree)) + (tm2 sym (cdr tree))))) + (test (tm2 '(+ x 2) '(abs (log (+ x 2)))) #t) + + (define (tm3 sym tree) + (and (pair? tree) + (or (call-with-exit (lambda (return) (return (equal? (car tree) sym)))) + (tm3 sym (car tree)) + (tm3 sym (cdr tree))))) + (test (tm3 '(+ x 2) '(abs (log (+ x 2)))) #t) + + (define (tm4 sym tree) + (and (pair? tree) + (or (equal? (car tree) sym) + (tm4 sym (car tree)) + (tm4 sym)))) + (test (tm4 1 '(2 4 (3 1) 2)) 'error) + ;; -------- OP_RECUR_COND_A_A_opA_LAq -------- (define (recur-cond-a-a-opa-laq-1 x) (cond ((= x 0) 0) (else (+ 1 (recur-cond-a-a-opa-laq-1 (- x 1)))))) (test (recur-cond-a-a-opa-laq-1 10) 10) @@ -30578,6 +30926,16 @@ in s7: (test (let () (define* (fxyz (a (define xyz 37))) xyz) (fxyz)) 37) ; ! ;;; -------- +(test (let () (define (f1 f1) (f1 1)) (f1 (lambda (x) (+ x 2)))) 3) +(test (let () (define (f2 x f2) (if (= x 0) x (f2 (- x 1) f2))) (f2 2 (lambda (x f) x))) 1) +(let () ; tc optimizer bug + (define (f2 x f2) (if (= x 0) x (f2 (- x 1) x))) + (test (f2 2 (lambda (x f) (+ x 12))) 13) + (define (f3 f3) (if (integer? f3) f3 (f3 32))) + (test (f3 (lambda (x) (+ x 12))) 44) + (define (f4 x f4) (if (= x 0) 10 (if (= x 1) 11 (f4 (- x 1) x)))) + (test (f4 2 (lambda (x f) (+ x 12))) 13)) + (let () (define a#b 3) (define a'b 4) @@ -31590,6 +31948,10 @@ in s7: "too many arguments for vector-set!: (#(1) 0 1 2)") (test (catch #t (lambda () (with-let (values (curlet) 2) 3)) (lambda (type info) (apply format #f info))) 3) +(let () (define (f1) (let ((ints (list 1 2 3))) (apply + (values 5 ints)))) (test (f1) 11)) +(let () (define (f2) (let ((ints (list 1 2 3))) (apply + (values 4 5 ints)))) (test (f2) 15)) +(let () (define (f3) (let ((ints (list 1 2 3))) (apply + (values 4 5 6 ints)))) (test (f3) 21)) + (test (let ((str "hi")) (string-set! (values str 0 #\x)) str) "xi") (test (values if) if) (test (values quote) quote) @@ -47051,7 +47413,8 @@ or better (define-macro (prog vars . body) `(call-with-exit (lambda (return) (ta (set! e p))) (test (object->let e) (inlet :value e :type 'output-port? :port-type 'string :closed #t :immutable? #f))) -(when (zero? (*s7* 'debug)) +(when (and (zero? (*s7* 'debug)) + (not (provided? 'snd))) (let () (define (ff1 x y) (+ x y)) (test (object->let ff1) (inlet 'value ff1 'type 'procedure? 'arity '(2 . 2) :immutable? #f 'file "s7test.scm" 'line (- (port-line-number) 7) 'source '(lambda (x y) (+ x y))))) @@ -47104,7 +47467,8 @@ or better (define-macro (prog vars . body) `(call-with-exit (lambda (return) (ta (test (substring "1234" ((openlet (inlet 'value 1)) 'value) ((openlet (object->let 3)) 'value)) "23") -(when with-block +(when (and with-block + (not (provided? 'snd))) (test (object->string (object->let (block))) "(inlet 'value (block) 'type c-object? 'c-object-type 0 'c-object-let (inlet 'float-vector? #<lambda (p)> 'signature #<lambda (p)> 'type block? 'arity #<lambda (p)> 'aritable? #<lambda (p args)> 'vector-dimensions #<lambda (p)> 'empty #<lambda (p)> 'vector-ref block-ref 'vector-set! block-set! 'subsequence subblock 'append block-append 'reverse! block-reverse!) 'class (inlet 'name \"<block>\" 'setter #<c-object-setter>) 'c-object-length #<c-function> 'c-object-ref #<c-function> 'c-object-set! #<c-function> 'c-object-copy #<c-function> 'c-object-fill! #<c-function> 'c-object-reverse #<c-function> 'c-object->string #<c-function>)")) @@ -63000,6 +63364,12 @@ hi6: (string-app... (test (modulo 3.0+2.3i 3) 'error) ;(test (let () (define (func) (do ((i 0 (+ i 1))) ((= i 1)) (do ((j 0 (+ j 1))) ((= j 1)) (modulo (cosh 128) 1.0)))) (define (hi) (func)) (hi)) 'error) (test (do ((i 0 (+ i __x__))) ((= i __x__)) (modulo (cosh 128) #x123.123)) 'error) +(test (modulo 21010111 10) 1) ; from CL bboard +(test (modulo 21010111 10.0) 1.0) +(test (modulo 8101011121111 10) 1) +(test (modulo 8101011121111 10.0) 1.0) +(test (modulo 21010111211111 10) 1) +(test (modulo 21010111211111 10.0) (if with-bignums 1.0 'error)) (for-each (lambda (arg) @@ -66058,7 +66428,7 @@ hi6: (string-app... (list "hi" () (integer->char 65) #f #t '(1 2) _ht_ _undef_ _null_ _c_obj_ 'a-symbol (cons 1 2) (make-vector 3) abs #<eof> '(1 2 3) #\newline (lambda (a) (+ a 1)) #<unspecified> #<undefined>)) -(test (catch #t (lambda () (min 1 +nan.0 #f)) (lambda (type info) (apply format #f info))) "min argument, #f, is boolean but should be a real") +(test (catch #t (lambda () (min 1 +nan.0 #f)) (lambda (type info) (apply format #f info))) "min argument 2, #f, is boolean but should be a real") ;;; -------------------------------------------------------------------------------- @@ -74184,7 +74554,6 @@ hi6: (string-app... - ;;; -------------------------------------------------------------------------------- ;;; atanh ;;; -------------------------------------------------------------------------------- @@ -74592,6 +74961,12 @@ hi6: (string-app... (list 0.1+0.1i 0.099325449367251+0.10065855418732i) (list 1e+16+1e+16i -1.3183898417424e-15+1.5707963267949i) (list 1e-16+1e-16i 1.1102230246252e-16+1e-16i) )) +;; this abs case is useless: abs symbol_id is not zero +(let () (define (hi) (let ((e (sublet (curlet) :abs (lambda (a) (- a 1))))) (with-let e (abs -1)))) (test (hi) -2)) +(let () (define (hi) (let ((e (openlet (inlet :abs (lambda (a) (- a 1)))))) (with-let e (abs -1)))) (test (hi) -2)) +;; so try atanh +(let () (define (hi) (let ((e (openlet (inlet :atanh (lambda (a) (- a 1)))))) (with-let e (atanh 2)))) (test (hi) 1)) ;0.549+1.570 if with-let ignored + @@ -84186,6 +84561,7 @@ etc.... ;(test (string->number (string #\1 (integer->char 0) #\0)) 1) ; ?? Guile returns #f (test (string->number "1+1 i") #f) (test (string->number "1+ei") #f) +(test (string->number "#b1") 1) (test (string->number " #b1") #f) (test (string->number "#b1 ") #f) (test (string->number "#b1 1") #f) @@ -84196,6 +84572,7 @@ etc.... (test (string->number (string (integer->char 216))) #f) ; slashed 0 (test (string->number (string (integer->char 189))) #f) ; 1/2 as single char (test (string->number (string #\1 (integer->char 127) #\0)) #f) ; backspace +(test (string->number (string #\1)) 1) (test (string->number "1\ 2") 12) @@ -91034,6 +91411,12 @@ etc (set! (f 1) 123) (test (f 1) 123.0))) +(define-macro (_do4_ . args) + `(do ((__var__ #f) + (_i_ 0 (+ _i_ 1))) + ((= _i_ 1) __var__) + (set! __var__ ,@args))) + (let () (define (baser-method func) (lambda largs @@ -91582,6 +91965,10 @@ etc (let ((mock-number (*mock-number* 'mock-number)) (mock-number? (*mock-number* 'mock-number?))) + + (test ((lambda () (gcd (mock-number 1-i) ((lambda (a) (values a (+ a 1))) 2)))) 'error) + (test (let () (define (func) (vector (values (lcm (mock-number 2.0) (values 1 2 3 4 5 6 7 8 9 10))))) (func)) 'error) + (let ((i (mock-number 32)) (x (mock-number pi)) (z (mock-number 1+i)) @@ -91879,7 +92266,7 @@ etc (test (with-let (mock-number 2.0) (integer? #<unspecified>)) #f) (test (let () (define (f) (do ((i 0 (+ i 1))) ((= i 1)) (logxor ((*mock-number* 'mock-number) 4/3)))) (f)) 'error) (test (let () (_do4_ (logxor (mock-number 4/3)))) 'error) - (test (let () (define (func) (let ((x #f) (i 0)) (let () (_do4_ (logior (mock-number 4/3) 1))))) (define (hi) (func) (func)) (hi) (hi)) 'error) + (test (let () (define (func) (_do4_ (logior (mock-number 4/3) 1))) (define (hi) (func) (func)) (hi) (hi)) 'error) (test (let () (define (func) (lcm (mock-number 4/3))) (define (hi) (func) (func)) (hi) (hi)) 4/3) ) @@ -92948,16 +93335,19 @@ etc (test (define *s7* 3) 'error) (let ((old-pl (*s7* 'print-length))) (let-temporarily (((*s7* 'print-length) 32)) - (test (eval-string "print-length" *s7*) 32) - (test (with-let *s7* print-length) 32) + (unless (provided? 'snd) + ;; print-length is a top-level function in Snd, so (with-let *s7* print-length) sees Snd's print-length + ;; if *s7* were a real let, this would not happen + (test (eval-string "print-length" *s7*) 32) + (test (with-let *s7* print-length) 32) + (test (with-let (sublet *s7*) print-length) 32)) (test (let ((s7 *s7*)) (s7 'print-length)) 32) (test (let-set! *s7* 'print-length 8) 8) (test (let-ref *s7* 'print-length) 8) (test ((sublet *s7*) 'print-length) 8) (when full-s7test (test ((inlet *s7*) 'print-length) 8) ; this calls each *s7* field, including memory-usage! - (test (with-let (inlet *s7*) print-length) 8)) - (test (with-let (sublet *s7*) print-length) 8)) + (test (with-let (inlet *s7*) print-length) 8))) (test (*s7* 'print-length) old-pl) (test (coverlet *s7*) 'error) (test (openlet *s7*) *s7*) @@ -93037,6 +93427,8 @@ etc (test (string? (*s7* 'version)) #t) (test (set! (*s7* 'version) "hi") 'error) +(let ((__s7__ *s7*)) (test (__s7__ 'heap-size) (*s7* 'heap-size))) + (let-temporarily (((*s7* 'safety) -1)) (test (*s7* 'safety) -1)) @@ -93091,12 +93483,14 @@ etc (test (defined? 'print-length *s7*) #t) (test (defined? 'asdf *s7*) #f) -(catch #t +#| +(catch #t ; this sometimes sees *s7* rather than the dynamic-wind object (lambda () (let ((dyn (caar (dynamic-wind (lambda () #f) (lambda () (*s7* 'stack)) (lambda () #f))))) (test (object->string dyn :readable) "#<dynamic-wind>") (test (eq? dyn dyn) #t))) (lambda args #f)) +|# (let-temporarily (((*s7* 'default-hash-table-length) 31) ((*s7* 'hash-table-float-epsilon) 1e-4) @@ -93316,6 +93710,7 @@ etc (f5 1/2) ; dox_ex fallback (f5 pi)) + ;;; bizarre optimizer checks (test (let () (define (func x) (if (pair? (cdr /)) 3)) (define (hi) (func (integer->char 255))) (catch #t (lambda () (hi) (func (integer->char 255))) (lambda arg #f))) #f) (test (catch #t (lambda () (define (func x) (cond (case `((1)) (if x y) =>))) (define (hi) (func ())) (hi)) (lambda args 'error)) 'error) @@ -93471,6 +93866,7 @@ etc (test (let () (define (f) (with-input-from-string '(+ x 1) (cdaar))) (f)) 'error) (let ((v (make-vector '(2 2)))) (test (member 1 (list 3 2) (lambda (a b) (immutable? (list v -1/2 (+ 1 2))))) #f)) ; list_3_direct +(test (let ((+ -)) (define (f x) (+ x 1)) (object->string f :readable)) "(let ((+ #_-)) (lambda (x) (+ x 1)))") ; can also be - (test (let () (define (func) (let ((+ -)) (+ (begin (real-part (random 0+i))) 'value "") (string->symbol (case)))) (define (hi) (func)) (hi)) 'error) (test (let () (define (func) (let ((+ -)) (+ (begin (real-part (random 0+i)) 0) 'value "") (string->symbol (case)))) (define (hi) (func)) (hi)) 'error) (test (let ((_f_ (lambda () (>= (cond (immutable! "asdf") (immutable! (hash-table 'a 1))) (caadar(caadr)))))) (_f_) (_f_)) 'error) @@ -93478,6 +93874,15 @@ etc (test (let () (define (!f!) (let ((!x! (map (lambda (!a!) (dynamic-wind lcm gcd *)) '(0)))) (car !x!))) (!f!)) 0) (test (let () (define (func) (cdddr (c-pointer (bignum 1) (vector) (vector 1) (vector 2)) (adjoin (list 1) (list 1 2)))) (define (hi) (func)) (hi)) 'error) +(test (let () (define (func) (let ((+ -)) (let ((cons list)) (cons #o123 +documentation+ 0-i)))) (func) (func)) 'error) +(test (let () (define (func) (let ((+ -)) (+ (bignum 1234.1234) 100 .0-) (string-ci=? (ash (open-input-string (documentation)))))) (func) (func)) 'error) +(test (let () (define (func) (let ((+ -)) (let ((cons list)) (+ 100 0+. #r2d((.1 .2) (.3 .4)))))) (func) (func)) 'error) + +(test (let () (define (func) (let ((x #f) (i 0)) (case x (else (string->number))))) (func)) 'error) +(test (let () (define (func) (apply + (string-ref ((if (> 3 2) abs log) 1) 0))) (func)) 'error) +(test (let () (define (func) (apply char? (list (string-ref ((if (> 3 2) string string) #\a) 0)))) (func)) #t) +(test (let () (define (func) (list (values (string-ref ___lst 0 ) cond (help) (string-upcase 1001 (make-vector 3 :rest keyword?) when (list))))) (func)) 'error) + (when with-block (let () (define (fibf n) (if (< n 2.0) n (+ (fibf (- n 1.0)) (fibf (- n 2.0))))) @@ -93800,7 +94205,7 @@ etc (define (f) (do ((i 0 (+ i 1))) ((= i 1)) (vector-set! vvv (abs x) `(x 1) '(15 26 . 36)))) (f)) 'error) -(test (let () (define (func) (let ((x #f) (i 0)) (let () (_do4_ (float-vector-ref #r2d((.1 .2) (.3 .4)) __var2__ ))))) (define (hi) (func) (func)) (hi) (hi)) 'error) +(test (let () (define (func) (_do4_ (float-vector-ref #r2d((.1 .2) (.3 .4)) __var2__))) (define (hi) (func) (func)) (hi) (hi)) 'error) (test (let () (define (f) (c-pointer pi pi (values 1 2))) (f)) 'error) (num-test (let () (define (f) (+ pi pi (values 1 2))) (f)) (+ 3 (* 2 pi))) @@ -98529,14 +98934,11 @@ etc " let: perhaps (let ((d 4)) (+ a b c d)) -> (+ a b c 4) let: perhaps move 'c into the inner let: (let ((c 3)) (let ((d 4)) (+ a b c d))) -> (let ((c 3) (d 4)) (+ a b c d)) let: perhaps (let ((c 3)) (let ((d 4)) (+ a b c d))) -> (let ((c 3) (d 4)) (+ a b c d)) - let: perhaps move 'b into the inner let: (let ((b 2)) (let ((c 3)) (let ((d 4)) (+ a b c d)))) -> (let ((b 2) (d 4)) (+ a b c d)) let: perhaps (let ((b 2)) (let ((c 3)) (let ((d 4)) (+ a b c d)))) -> (let ((b 2) (c 3) (d 4)) (+ a b c d)) - let: perhaps move 'a into the inner let: (let ((a 1)) (let ((b 2)) (let ((c 3)) (let ((d 4)) (+ a b c d))))) -> (let ((a 1) (d 4)) (+ a b c d)) let: perhaps (let ((a 1)) (let ((b 2)) (let ((c 3)) (let ((d 4)) (+ a b c d))))) -> (let ((a 1) (b 2) (c 3) (d 4)) (+ a b c d))") (lint-test "(let ((a 1)) (let ((b 2)) (let ((c 3) (d 4)) (display a) (+ b c d))))" " let: perhaps move 'b into the inner let: (let ((b 2)) (let ((c 3) (d 4)) (display a) (+ b c d))) -> (let ((b 2) (c 3) (d 4)) (display a) (+ b c d)) - let: perhaps (let ((b 2)) (let ((c 3) (d 4)) (display a) (+ b c d))) -> (let ((b 2) (c 3) (d 4)) (display a) ...) - let: perhaps move 'a into the inner let: (let ((a 1)) (let ((b 2)) (let ((c 3) (d 4)) (display a) (+ b c d)))) -> (let ((a 1) (c 3) (d 4)) (display a) (+ b c d)) + let: perhaps (let ((b 2)) (let ((c 3) (d 4)) (display a) (+ b c d))) -> (let ((b 2) (c 3) (d 4)) (display a) ...) let: perhaps (let ((a 1)) (let ((b 2)) (let ((c 3) (d 4)) (display a) (+ b c d)))) -> (let ((a 1) (b 2) (c 3) (d 4)) (display a) ...)") (lint-test "(let ((a 1) (b 2)) (let ((c 3) (d 4)) (display a) (+ b c d)))" " let: perhaps move 'b into the inner let: (let ((a 1) (b 2)) (let ((c 3) (d 4)) (display a) (+ b c d))) -> (let ((b 2) (c 3) (d 4)) (display a) (+ b c d)) @@ -100008,6 +100410,11 @@ etc (lint-test "(substring x 0)" " substring: perhaps clearer: (substring x 0) -> (copy x)") (lint-test "(substring (substring x 1) 2)" " substring: perhaps (substring (substring x 1) 2) -> (substring x 3)") + (lint-test "(substring (substring x 2 6) 1)" " substring: perhaps (substring (substring x 2 6) 1) -> (substring x 3 6)") + (lint-test "(substring (substring x 2) 1 6)" " substring: perhaps (substring (substring x 2) 1 6) -> (substring x 3 8)") + (lint-test "(substring (substring x 2 6) 1 3)" " substring: perhaps (substring (substring x 2 6) 1 3) -> (substring x 3 5)") + (lint-test "(substring (substring x 2) 1 4)" " substring: perhaps (substring (substring x 2) 1 4) -> (substring x 3 6)") + (lint-test "(substring (substring x x1) x2 y2)" " substring: perhaps (substring (substring x x1) x2 y2) -> (substring x (+ x2 x1) (+ y2 x1))") (lint-test "(substring x (+ y 1) (+ y 1))" " substring: leaving aside errors, (substring x (+ y 1) (+ y 1)) is \"\"") (lint-test "(substring x 0 (length x))" " substring: perhaps (substring x 0 (length x)) -> (substring x 0)") (lint-test "(let ((len (string-length x))) (substring x 1 len))" @@ -103578,6 +103985,17 @@ etc (test (let () (define (f x) (x 12)) (f values)) 12) ;;; quote stuff + +(when full-s7test ; try to call with quote still global + (test (system "./repl -e '(let ((quote 32)) (+ quote 1))'" #t) "33\n") + (test (system "./repl -e '(let ((quote 32)) (define (f) (+ quote 1)) (f)))'" #t) "33\n") + (test (system "./repl -e '(let ((quote 32)) (define (f z) (+ z 1)) (f quote))'" #t) "33\n") + (test (system "./repl -e '(let ((quote (lambda (x) (+ x 1)))) (quote 32))'" #t) "33\n") + (test (system "./repl -e '(let ((quote (lambda (x) (+ x 1)))) (define (f) (quote 32)) (f))'" #t) "33\n") + (test (system "./repl -e '(let () (define (f) (let ((quote 32)) (+ quote 1))) (f))'" #t) "33\n") + (test (system "./repl -e '(let () (define (f) (let ((quote 32)) (+ quote 1))) (define (g) (f)) (g) (g))'" #t) "33\n") + (test (system "./repl -e '((lambda (quote) (+ quote 1)) 32)'" #t) "33\n")) + (test (let ((when -)) (when 32)) -32) ;(test (let ((quote -)) '32) -32) ;(test (let () (define (f) (let ((quote -)) '32)) (f)) -32) @@ -103589,6 +104007,8 @@ etc (test (let ((x #f) (i 0)) (call/cc (lambda* quote `((1) . x)))) 'error) (test (let () (define (func) (let ((x #f) (i 0)) (call/cc (lambda* quote `((1) . x) (begin))))) (define (hi) (func)) (hi)) 'error) (let () (define (func x) (let () (define _x_ (lambda* '((x 1 . 2) . 3) `((x)) (reverse! /))))) (define (hi) (func #f)) (test (hi) 'error)) +(let () (define (func) (with-output-to-string (lambda* (if) ((if (> 3 2) + -) 3 2)))) (test (func) 'error)) ;(if (< 3 2) + -)... within lambda* (if) in with-output-to-string +(let () (define (func) (with-output-to-file "/dev/null" (macro* (if) ((if (> 3 2) + -) 3 2)))) (test (func) 'error)) (test (set! case 3) 'error) (test (begin (let ((case 2)) case) (set! case 4)) 'error) @@ -103634,16 +104054,8 @@ etc (test (catch #t (lambda () ((lambda* 'x (+ 1 '__a__)))) (lambda (type info) type)) 'unbound-variable) (test (catch #t (lambda () ((lambda* 'x (vector '__a__ 1 2)))) (lambda (type info) type)) 'unbound-variable) -(when full-s7test ; try to call with quote still global - (test (system "./repl -e '(let ((quote 32)) (+ quote 1))'" #t) "33\n") - (test (system "./repl -e '(let ((quote 32)) (define (f) (+ quote 1)) (f)))'" #t) "33\n") - (test (system "./repl -e '(let ((quote 32)) (define (f z) (+ z 1)) (f quote))'" #t) "33\n") - (test (system "./repl -e '(let ((quote (lambda (x) (+ x 1)))) (quote 32))'" #t) "33\n") - (test (system "./repl -e '(let ((quote (lambda (x) (+ x 1)))) (define (f) (quote 32)) (f))'" #t) "33\n") - (test (system "./repl -e '(let () (define (f) (let ((quote 32)) (+ quote 1))) (f))'" #t) "33\n") - (test (system "./repl -e '(let () (define (f) (let ((quote 32)) (+ quote 1))) (define (g) (f)) (g) (g))'" #t) "33\n") - (test (system "./repl -e '((lambda (quote) (+ quote 1)) 32)'" #t) "33\n")) - +(test (call-with-exit (lambda* 'value (let ((i 32)) (set! (setter 'i) integer?) (curlet)) 100)) 32) +(let () (define (func) (call-with-exit (lambda* 'value (let ((i 32)) (set! (setter 'i) integer?) (curlet)) 100))) (func) (test (func) 32)) ;;; these 4 lines go together (define-expansion (_mem2_ . args) @@ -103914,6 +104326,15 @@ etc (set! x (/ x 2)) (set! xp (+ x 1))))) +(with-let (unlet) ; 11, not 13 + (set! + -) + (define (sf x) (+ x 1)) + (display (sf 2)) + (define (f) (do ((i 0 (#_+ i 1))) ((= i 1)) (display (sf 2)))) + (f) + (newline)) + + ; (1/1152921504606846976 8.673617379884e-19) smallest positive normalized fp 2-1022 = 2.225 10-308 diff --git a/snd-nogui.c b/snd-nogui.c index 22715af..86d48ad 100644 --- a/snd-nogui.c +++ b/snd-nogui.c @@ -687,7 +687,7 @@ void snd_doit(int argc, char **argv) } snd_load_init_file(noglob, noinit); -#if (!_MSC_VER) && !__MINGW32__ +#if (!_MSC_VER) && !__MINGW32__ signal(SIGTTIN, SIG_IGN); /* disallow terminal read/write if a background job */ signal(SIGTTOU, SIG_IGN); #endif @@ -723,6 +723,7 @@ void snd_doit(int argc, char **argv) #if HAVE_SCHEME && (!defined(__sun)) && (!defined(_MSC_VER)) if (!nostdin) { + if (noinit) goto DUMB_REPL; #if USE_NOTCURSES if (nrepl(s7)) /* nrepl.c -- loads nrepl.scm, 0=success */ #else @@ -731,7 +732,7 @@ void snd_doit(int argc, char **argv) if ((listener_prompt(ss)) && (strcmp(listener_prompt(ss), DEFAULT_LISTENER_PROMPT) != 0)) s7_eval_c_string(s7, "(set! (*repl* 'prompt) \ (lambda (num) \ - (with-let (sublet (*repl* 'repl-let) :num num) \ + (with-let (sublet (*repl* 'repl-let) :num num) \ (set! prompt-string (format #f \"(~D)~A\" num *listener-prompt*)) \ (set! prompt-length (length prompt-string)))))"); s7_eval_c_string(s7, "((*repl* 'run))"); @@ -739,6 +740,7 @@ void snd_doit(int argc, char **argv) else #endif { + DUMB_REPL: while (true) { char buffer[512]; diff --git a/snd-test.fs b/snd-test.fs index 1a34b49..aa31ae3 100644 --- a/snd-test.fs +++ b/snd-test.fs @@ -2,7 +2,7 @@ \ Translator/Author: Michael Scholz <mi-scholz@users.sourceforge.net> \ Created: 2006/08/05 00:09:28 -\ Changed: 2020/09/13 14:23:47 +\ Changed: 2020/11/29 03:22:06 \ Tags: FIXME - something is wrong \ XXX - info marker @@ -88,11 +88,11 @@ :port-name "sndout" :write-line lambda: <{ line -- }> line snd-print ( line ) .stdout ; - make-soft-port set-*stdout* value stdout-io + make-soft-port value stdout-io :port-name "snderr" :write-line lambda: <{ line -- }> line snd-print ( line ) .stderr ; - make-soft-port set-*stderr* value stderr-io + make-soft-port value stderr-io [then] \ Output words: We can't use clm-print here if we want xterm output @@ -1836,12 +1836,14 @@ black-and-white-colormap constant *better-colormap* name-click-hook after-apply-controls-hook enved-hook - mouse-enter-label-hook - mouse-enter-graph-hook - mouse-enter-listener-hook - mouse-leave-label-hook - mouse-leave-graph-hook - mouse-leave-listener-hook + *with-test-motif* if + mouse-enter-label-hook + mouse-enter-graph-hook + mouse-enter-listener-hook + mouse-leave-label-hook + mouse-leave-graph-hook + mouse-leave-listener-hook + then initial-graph-hook after-graph-hook graph-hook ) each { h } @@ -2,15 +2,15 @@ \ Author: Michael Scholz <mi-scholz@users.sourceforge.net> \ Created: 05/12/26 22:36:46 -\ Changed: 20/09/13 13:45:40 +\ Changed: 20/11/29 02:58:28 \ -\ @(#)snd-xm.fs 1.43 9/13/20 +\ @(#)snd-xm.fs 1.44 11/29/20 \ Commentary: \ \ Requires --with-motif \ -\ Tested with Snd 20.x +\ Tested with Snd 21.x \ Fth 1.4.x \ Motif 2.3.3 X11R6 \ @@ -185,18 +185,13 @@ require extensions '( "ArrowButton" "ArrowButtonGadget" "BulletinBoard" - "ButtonBox" "CascadeButton" "CascadeButtonGadget" - "ColorSelector" - "Column" "ComboBox" "Command" "Container" - "DataField" "DrawingArea" "DrawnButton" - "DropDown" "FileSelectionBox" "Form" "Frame" @@ -220,7 +215,6 @@ require extensions "SeparatorGadget" "SimpleSpinBox" "SpinBox" - "TabStack" "Text" "TextField" "ToggleButton" @@ -229,7 +223,8 @@ require extensions "\ : FXmVaCreateManaged%s ( parent name args -- w ) xm-length FXmCreate%s dup FXtManageChild drop -;" '( name dup ) string-format string-eval +;" '( name dup ) string-format <'> string-eval #t nil fth-catch { tag } + tag if stack-reset then end-each ;let @@ -47,11 +47,11 @@ #include "snd-strings.h" -#define SND_DATE "23-Nov-20" +#define SND_DATE "31-Dec-20" #ifndef SND_VERSION -#define SND_VERSION "20.9" +#define SND_VERSION "21.0" #endif -#define SND_MAJOR_VERSION "20" -#define SND_MINOR_VERSION "9" +#define SND_MAJOR_VERSION "21" +#define SND_MINOR_VERSION "0" #endif diff --git a/tools/auto-tester.scm b/tools/auto-tester.scm index 1e57e55..7e79970 100644 --- a/tools/auto-tester.scm +++ b/tools/auto-tester.scm @@ -1,5 +1,6 @@ ;;; this is an extension of tauto.scm, an auto-tester +(define with-methods #t) ;(set! (*s7* 'profile) 1) (for-each (lambda (x) @@ -70,22 +71,23 @@ (object->string (bases (random 6)) :readable)))) -(load "stuff.scm") +(require stuff.scm) ;(load "write.scm") -(load "mockery.scm") -(load "case.scm") +(require case.scm) (define match? ((funclet 'case*) 'case*-match?)) -(define mock-number (*mock-number* 'mock-number)) -(define mock-pair (*mock-pair* 'mock-pair)) -(define mock-string (*mock-string* 'mock-string)) -(define mock-char (*mock-char* 'mock-char)) -(define mock-vector (*mock-vector* 'mock-vector)) -(define mock-symbol (*mock-symbol* 'mock-symbol)) -(define mock-hash-table (*mock-hash-table* 'mock-hash-table)) -(define mock-c-pointer (*mock-c-pointer* 'mock-c-pointer)) -(define mock-port (*mock-port* 'mock-port)) -(define mock-random-state (*mock-random-state* 'mock-random-state)) +(when with-methods + (load "mockery.scm") + (define-constant mock-number (*mock-number* 'mock-number)) + (define-constant mock-pair (*mock-pair* 'mock-pair)) + (define-constant mock-string (*mock-string* 'mock-string)) + (define-constant mock-char (*mock-char* 'mock-char)) + (define-constant mock-vector (*mock-vector* 'mock-vector)) + (define-constant mock-symbol (*mock-symbol* 'mock-symbol)) + (define-constant mock-hash-table (*mock-hash-table* 'mock-hash-table)) + (define-constant mock-c-pointer (*mock-c-pointer* 'mock-c-pointer)) + (define-constant mock-port (*mock-port* 'mock-port)) + (define-constant mock-random-state (*mock-random-state* 'mock-random-state))) (set! (*s7* 'safety) 1) ; protect copy (in define-expansion evaluation) from circular lists @@ -117,12 +119,7 @@ (define __var2__ 3) (set! (setter '__var2__) (lambda (s v) (if (integer? v) v 3))) (define _definee_ #f) - (define x 0) -(define local-func (lambda (x) 0)) -(define (free1) (set! x (- (+ x 1) 1))) -(define (free2) (x i)) -(define (free3) (local-func 0)) (define (_vals_) (values #f 1 2)) (define (_vals1_) (values 1 #f 2)) @@ -289,8 +286,10 @@ ;(define (checked-varlet . args) (apply varlet (sublet (curlet)) args)) ;(define (checked-cutlet . args) (apply cutlet (sublet (curlet)) args)) (define (checked-procedure-source . args) (copy (procedure-source (car args)) :readable)) +;(define (checked-pp obj) (string? (pp obj))) -(load "s7test-block.so" (sublet (curlet) (cons 'init_func 'block_init))) +(when with-methods + (load "s7test-block.so" (sublet (curlet) (cons 'init_func 'block_init)))) (define lint-no-read-error #t) @@ -555,12 +554,13 @@ (define-constant imiv (immutable! (int-vector 0 1 2))) (define-constant imfv (immutable! (float-vector 0 1 2))) (define-constant imi (immutable! (inlet 'a 3 'b 2))) -(define-constant imb (immutable! (block 0.0 1.0 2.0))) (define-constant imh (immutable! (hash-table 'a 1 'b 2))) (define-constant imp (immutable! (cons 0 (immutable! (cons 1 (immutable! (cons 2 ()))))))) -(define-constant imfi (immutable! (mock-port (open-input-string "asdf")))) -(define-constant imfo (immutable! (mock-port (open-output-string)))) -(define-constant imr (immutable! (mock-random-state 123456))) +(when with-methods + (define-constant imb (immutable! (block 0.0 1.0 2.0))) + (define-constant imfi (immutable! (mock-port (open-input-string "asdf")))) + (define-constant imfo (immutable! (mock-port (open-output-string)))) + (define-constant imr (immutable! (mock-random-state 123456)))) (define-constant bigi0 (bignum 0)) (define-constant bigi1 (bignum 1)) @@ -734,8 +734,6 @@ 'require 'else '_mac_ '_mac*_ '_bac_ '_bac*_ '_fnc_ '_fnc*_ '_fnc1_ '_fnc2_ '_fnc3_ '_fnc4_ '_fnc5_ ;'_fnc6_ - 'block 'make-block 'block? 'block-ref 'block-set! - 'blocks 'unsafe-blocks 'blocks1 'unsafe-blocks1 'blocks3 'unsafe-blocks3 'blocks4 'unsafe-blocks3 'blocks5 'constant? 'openlet @@ -761,7 +759,7 @@ 'list-values 'byte-vector? 'openlet? 'iterator? 'string->byte-vector 'byte-vector->string - ;'pp + ;'checked-pp #| 's7-catches 's7-stack-top 's7-stack @@ -804,13 +802,17 @@ ;;'s7-file-names ; one is *stdin* -> infinite loop if read* ;'s7-rootlet-size 's7-heap-size 's7-free-heap-size 's7-gc-freed 's7-stack-size 's7-max-stack-size 's7-gc-stats - 'block-reverse! 'subblock 'unquote 'block-append 'block-let - 'simple-block? 'make-simple-block ;'make-c-tag ; -- uninteresting diffs + (reader-cond + (with-methods + 'block 'make-block 'block? 'block-ref 'block-set! + 'blocks 'unsafe-blocks 'blocks1 'unsafe-blocks1 'blocks3 'unsafe-blocks3 'blocks4 'unsafe-blocks3 'blocks5 + 'block-reverse! 'subblock 'unquote 'block-append 'block-let + 'simple-block? 'make-simple-block)) ;'make-c-tag ; -- uninteresting diffs 'undefined-function ;'subsequence 'empty? 'indexable? ;'first -- why is this acting up? - 'adjoin 'cdr-assoc + ;'adjoin 'cdr-assoc ;'progv ;'value->symbol -- correctly different values sometimes, progv localizes ;'and-let* 'string-case 'concatenate ;'union -- heap overflow if cyclic arg @@ -826,12 +828,13 @@ 'kar '_dilambda_ '_vals_ '_vals1_ '_vals2_ '_vals3_ '_vals4_ '_vals5_ '_vals6_ '_vals3s_ '_vals4s_ '_vals5s_ '_vals6s_ '_svals3_ '_svals4_ '_svals5_ '_svals6_ '_svals3s_ '_svals4s_ '_svals5s_ '_svals6s_ - 'free1 'free2 'free3 ;'match? 'catch 'length 'eq? 'car '< 'assq 'complex? 'vector-ref 'linter ;'*function* ;; '<cycle> 'cycle-set! 'cycle-ref 'make-cycle -- none are protected against randomness + ;; next are place-holders + 'ifa 'ifb )) (args (vector "-123" "1234" "-3/4" "-1" "1/2" "1+i" "1-i" "0+i" "0-i" "(expt 2 32)" "4294967297" "1001" "10001" @@ -880,7 +883,7 @@ "\"ho\"" ":ho" "'ho" "(list 1)" "(list 1 2)" "(cons 1 2)" "'()" "(list (list 1 2))" "(list (list 1))" "(list ())" "=>" "#f" "#t" "()" "#()" "\"\"" "'#()" ; ":write" -- not this because sr2 calls write and this can be an arg to sublet redefining write - ":readable" ":rest" ":allow-other-keys" ":a" + ":readable" ":rest" ":allow-other-keys" ":a" ":frequency" ":scaler" ; for blocks5 s7test.scm "1/0+i" "0+0/0i" "0+1/0i" "1+0/0i" "0/0+0/0i" "0/0+i" "+nan.0-3i" "+inf.0-nan.0i" "cons" "''2" "\"ra\"" "#\\a" "#\\A" "\"str1\"" "\"STR1\"" "#\\0" "0+." ".0-" @@ -926,7 +929,7 @@ "(weak-hash-table 1.0 'a 2.0 'b 3.0 'c)" "(make-iterator (list 11 22 33))" "(make-iterator (int-vector 1 2 3))" "(make-iterator (string #\\1))" "(make-iterator x)" "(make-iterator (make-vector '(2 3) #f))" "(make-iterator #r())" - "(make-iterator (hash-table 'a -1/2 'b 2))" "(make-iterator (block 1 2 3))" + "(make-iterator (hash-table 'a -1/2 'b 2))" "(make-iterator (weak-hash-table 1.0 'a 2.0 'b 3.0 'c))" "(make-iterator (let ((lst '((a . 1) (b . 2) (c . 2))) (+iterator+ #t)) @@ -948,7 +951,7 @@ (lambda (p) (return 'oops))))))" "#<eof>" "#<undefined>" "#<unspecified>" "#unknown" "___lst" "#<bignum: 3>" - "#<>" "#label:>" "#<...>" + "#<>" "#<label:>" "#<...>" "#o123" "#b101" "#\\newline" "#\\alarm" "#\\delete" "#_cons" "#x123.123" "#\\x65" ;"_1234_" "kar" "#_+" "(provide 'pizza)" "(require pizza)" @@ -961,7 +964,7 @@ "(call/cc (lambda (return) (let ((x 1) (y 2)) (return x y))))" "(let ((x 1)) (dynamic-wind (lambda () (set! x 2)) (lambda () (+ x 1)) (lambda () (set! x 1))))" - "(let-temporarily ((x 1)) (free1))" "(let-temporarily ((x #(1)) (i 0)) (free2))" "(let-temporarily ((local-func (lambda (x) x))) (free3))" + "(let-temporarily ((x 1)) x)" "(let-temporarily ((x #(1)) (i 0)) i)" "1+1e10i" "1e15-1e15i" "0+1e18i" "-1e18" "(begin (real-part (random 0+i)))" @@ -969,7 +972,7 @@ "(random 1)" ;;"(else ())" "(else (f x) B)" "(else)" - "else" "x" "(+ x 1)" ;"(+ 1/2 x)" "(abs x)" "(+ x 1 2+i)" "(* 2 x 3.0 4)" "((x 1234))" "((x 1234) (y 1/2))" "'x" "(x 1)" + "else" "x" "(+ x 1)" "(+ 1/2 x)" "(abs x)" "(+ x 1 2+i)" "(* 2 x 3.0 4)" "((x 1234))" "((x 1234) (y 1/2))" "'x" "(x 1)" "_undef_" "(begin |undef1|)" "+signature+" "+documentation+" "+setter+" "+iterator+" @@ -983,35 +986,44 @@ "(call-with-input-file \"s7test.scm\" (lambda (p) p))" "(call-with-output-string (lambda (p) p))" - "ims" "imbv" "imv" "imiv" "imfv" "imi" "imb" "imh" "imfi" "imfo" "imp" "imr" + "ims" "imbv" "imv" "imiv" "imfv" "imi" "imp" "imh" "vvv" "vvvi" "vvvf" ;"typed-hash" "typed-vector" "typed-let" "constant-let" "a1" "a2" "a3" "a4" "a5" "a6" "(make-hash-table 8 eq? (cons symbol? integer?))" "(make-hash-table 8 equivalent? (cons symbol? #t))" "(let ((a 1)) (set! (setter 'a) integer?) (curlet))" - ;"(let () (define-constant a 1) (curlet))" + "(let () (define-constant a 1) (+ a 1))" "bigi0" "bigi1" "bigi2" "bigrat" "bigflt" "bigcmp" "bigf2" "(ims 1)" "(imbv 1)" "(imv 1)" "(imb 1)" "(imh 'a)" - "(mock-number 0)" "(mock-number 1-i)" "(mock-number 4/3)" "(mock-number 2.0)" - "(mock-string #\\h #\\o #\\h #\\o)" - "(mock-pair 2 3 4)" - "(mock-char #\\b)" - "(mock-symbol 'c)" - "(mock-vector 1 2 3 4)" - "(mock-hash-table 'b 2)" - "(mock-c-pointer -1)" - "(mock-random-state 1234)" + (reader-cond + (with-methods + "(make-iterator (block 1 2 3))" + "(vector-dimensions (block))" + "(append (block) (block))" + "(make-vector 3 block?)" + "(make-hash-table 8 #f (cons symbol? block?))" + "(make-block 2)" "(block 1.0 2.0 3.0)" "(block)" + + "imb" "imfi" "imfo" "imr" + "(mock-number 0)" "(mock-number 1-i)" "(mock-number 4/3)" "(mock-number 2.0)" + "(mock-string #\\h #\\o #\\h #\\o)" + "(mock-pair 2 3 4)" + "(mock-char #\\b)" + "(mock-symbol 'c)" + "(mock-vector 1 2 3 4)" + "(mock-hash-table 'b 2)" + "(mock-c-pointer -1)" + "(mock-random-state 1234)")) "'value" " #| a comment |# " "(subvector 0 3 (vector 0 1 2 3 4))" "(substring \"0123\" 2)" - "(vector-dimensions (block))" - "(append (block) (block))" "(let-temporarily ((x 1234)) (+ x 1))" "(error 'oops \"an error!\")" + "(define b2 32)" ;;"(catch #t 1 (lambda (a b) b))" "(catch #t (lambda () (fill! (rootlet) 1)) (lambda (type info) info))" @@ -1020,9 +1032,7 @@ "begin" "cond" "case" "when" "unless" "letrec" "letrec*" "or" "and" "let-temporarily" ;;"lambda*" "lambda" ;-- cyclic body etc ;;"let" "let*" "do" "set!" "with-let" ;"define" "define*" "define-macro" "define-macro*" "define-bacro" "define-bacro*" - ;; "(begin (string? (stacktrace)))" "(and (string? (stacktrace)))" - ;; "(and (pair? (stacktrace)))" "(and (null? (stacktrace)))" "(and (integer? (stacktrace)))" "(let ((<1> (vector #f))) (set! (<1> 0) <1>) <1>)" "(let ((<1> (inlet :a #f))) (set! (<1> :a) <1>) <1>)" @@ -1048,9 +1058,7 @@ "(make-vector 3 :rest keyword?)" "(make-vector '(2 3) boolean?)" "(make-vector '(2 3) symbol?)" - "(make-vector 3 block?)" "(make-hash-table 8 #f (cons symbol? integer?))" - "(make-hash-table 8 #f (cons symbol? block?))" "(let ((i 32)) (set! (setter 'i) integer?) (curlet))" "(make-vector 3 #f bool/int?)" @@ -1064,7 +1072,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))" - ;"(lambda (x) (fill! x 0))" + "(lambda (x) (fill! (copy x) 0))" "(begin (list? (*s7* 'catches)))" "(begin (integer? (*s7* 'stack-top)))" @@ -1077,7 +1085,6 @@ "(let loop ((i 2)) (if (> i 0) (loop (- i 1)) i))" ;"(rootlet)" ;"(curlet)" - "(make-block 2)" "(block 1.0 2.0 3.0)" "(block)" ;"(make-simple-block 3)" ;"*s7*" ; -- gradually fills up with junk @@ -1136,6 +1143,8 @@ (list "(begin (string " "(apply string (list ") (list "(begin (float-vector " "(apply float-vector (list ") (list "(begin (values " "(apply values (list ") + (list "(vector (values " "(apply vector (list ") + (list "(vector 1 (values " "(apply vector (list 1 ") (list "(begin (_tr1_ " "(begin (_tr2_ ") (list "(begin (let ((x 0)) (set! (setter 'x) integer?) " "(begin (let ((x 0)) (set! (setter 'x) (lambda (s v) (if (integer? v) v (error \"setter ~A not integer\" v)))) ") @@ -1170,12 +1179,6 @@ str (cycler (+ 3 (random 3)))))) - ;(for-each (lambda (x) (if (not (symbol? x)) (format *stderr* "~A " x))) functions) - ;(for-each (lambda (x) (if (and x (not (string? x))) (format *stderr* "~A " x))) args) - ;(do ((p (vector->list functions) (cdr p))) ((null? p)) (if (memq (car p) (cdr p)) (format *stderr* "~A repeats~%" (car p)))) - ;(do ((p (vector->list args) (cdr p))) ((null? p)) (if (and (car p) (member (car p) (cdr p))) (format *stderr* "~A repeats~%" (car p)))) - ;;(let ((st (symbol-table))) (for-each (lambda (x) (if (and (procedure? (symbol->value x)) (not (memq x (vector->list functions)))) (format *stderr* "~A~%" x))) st)) - (define (fix-op op) (case op ((set!) "set! _definee_") ;"set!") @@ -1186,6 +1189,8 @@ ((with-output-to-file) "with-output-to-file \"/dev/null\" ") ((define define* define-macro define-macro* define-bacro define-bacro*) (format #f "~A _definee_ " op)) ((eval) "checked-eval") + ((ifa) "(if (integer? _definee_) + -)") + ((ifb) "(if (integer? _definee_) when unless)") (else => symbol->string))) (define make-expr @@ -1284,17 +1289,21 @@ (string-position "set! _definee_" str) (and (iterator? _definee_) (string-position "_definee_" str))) - (when (string-position "_definee_" str) (format *stderr* "_definee_: ~W~%" old-definee)) - (when (string-position "bigrat" str) (format *stderr* "bigrat: ~W" bigrat)) - (when (string-position "-inf.0" str) (format *stderr* "-inf.0: ~W" -inf.0)) - (format *stderr* "~%~%~S~%~S~%~S~%~S~% ~A~% ~A~% ~A~% ~A~%" - str1 str2 str3 str4 - (tp val1) (tp val2) (tp val3) (tp val4)) - (if (or (eq? val1 'error) - (eq? val2 'error) - (eq? val3 'error) - (eq? val4 'error)) - (format *stderr* " ~S: ~S~%" error-type (tp (apply format #f (car error-info) (cdr error-info))))))) + (let ((errstr (and (or (eq? val1 'error) + (eq? val2 'error) + (eq? val3 'error) + (eq? val4 'error)) + (format #f " ~S: ~S~%" error-type (tp (apply format #f (car error-info) (cdr error-info))))))) + (unless (and errstr + (or (string-position "unbound" errstr) + (string-position "circular" errstr))) + (when (string-position "_definee_" str) (format *stderr* "_definee_: ~W~%" old-definee)) + (when (string-position "bigrat" str) (format *stderr* "bigrat: ~W" bigrat)) + (when (string-position "-inf.0" str) (format *stderr* "-inf.0: ~W" -inf.0)) + (format *stderr* "~%~%~S~%~S~%~S~%~S~% ~A~% ~A~% ~A~% ~A~%" + str1 str2 str3 str4 + (tp val1) (tp val2) (tp val3) (tp val4)) + (if (string? errstr) (display errstr *stderr*)))))) ((or (catch #t (lambda () (openlet? val1)) (lambda args #t)) ; (openlet? (openlet (inlet 'openlet? ()))) -> error: attempt to apply nil to (inlet 'openlet? ()) (string-position "(set!" str1) @@ -1390,7 +1399,7 @@ ;(format *stderr* "~S~%" str) (set! estr str) (set! old-definee _definee_) - (get-output-string imfo #t) + (when with-methods (get-output-string imfo #t)) (catch #t (lambda () (car (list (eval-string str)))) @@ -1435,9 +1444,9 @@ (set! last-error-type #f) (let* ((outer (codes (random codes-len))) (str1 (string-append "(let ((x #f) (i 0)) " (car outer) str ")))")) - (str2 (string-append "(let () (define (func) " str1 ") (define (hi) (func)) (hi))")) + (str2 (string-append "(let () (define (func) " str1 ") (define (hi) (func)) (hi) (hi))")) (str3 (string-append "(let ((x #f) (i 0)) " (cadr outer) str ")))")) - (str4 (string-append "(let () (define (func) " str3 ") (define (hi) (func)) (hi))"))) + (str4 (string-append "(let () (define (func) " str3 ") (func) (func))"))) (let ((val1 (eval-it str1)) (val2 (eval-it str2)) (val3 (eval-it str3)) diff --git a/tools/concordance.scm b/tools/concordance.scm index aae275f..44b98fc 100644 --- a/tools/concordance.scm +++ b/tools/concordance.scm @@ -20,29 +20,31 @@ (positive? (length cur-word)))) (set! cur-word (string-append cur-word (string c))) (begin - (if (char=? c #\newline) - (set! cur-line (+ cur-line 1)) - (if (and (char=? c #\*) - (char=? last-c #\/)) - (let ((last-c1 #\null)) - (do ((c1 (read-char ip) (read-char ip))) - ((and (char=? c1 #\/) - (char=? last-c1 #\*))) - (if (char=? c1 #\newline) - (set! cur-line (+ cur-line 1))) - (set! last-c1 c1))) - (if (and (char=? c #\") - (not (char=? last-c #\'))) ; '"' - (let ((last-c1 #\null) - (last-c2 #\null)) - (do ((c1 (read-char ip) (read-char ip))) - ((and (char=? c1 #\") - (or (not (char=? last-c1 #\\)) ; \" - (char=? last-c2 #\\)))) ; \\" - (if (char=? c1 #\newline) - (set! cur-line (+ cur-line 1))) - (set! last-c2 last-c1) - (set! last-c1 c1)))))) + (cond ((char=? c #\newline) + (set! cur-line (+ cur-line 1))) + + ((and (char=? c #\*) + (char=? last-c #\/)) + (let ((last-c1 #\null)) + (do ((c1 (read-char ip) (read-char ip))) + ((and (char=? c1 #\/) + (char=? last-c1 #\*))) + (if (char=? c1 #\newline) + (set! cur-line (+ cur-line 1))) + (set! last-c1 c1)))) + + ((and (char=? c #\") + (not (char=? last-c #\'))) ; '"' + (let ((last-c1 #\null) + (last-c2 #\null)) + (do ((c1 (read-char ip) (read-char ip))) + ((and (char=? c1 #\") + (or (not (char=? last-c1 #\\)) ; \" + (char=? last-c2 #\\)))) ; \\" + (if (char=? c1 #\newline) + (set! cur-line (+ cur-line 1))) + (set! last-c2 last-c1) + (set! last-c1 c1))))) (set! last-c c) (when (positive? (length cur-word)) (hash-table-set! words cur-word @@ -55,22 +57,25 @@ (define (searcher) ;; }\n} (call-with-input-file "s7.c" - (lambda (p) - (let ((last1 "")) - (do ((this (read-line p) (read-line p)) - (line 0 (+ line 1))) - ((eq? this #<eof>)) - (let ((len (length this))) - (unless (or (= len 0) - (char=? (string-ref this 0) #\})) - (do ((i 0 (+ i 1))) - ((or (>= i len) - (not (char-whitespace? (string-ref this i)))) - (set! this (substring this i)))) - (when (and (> (length this) 0) (char=? (string-ref this 0) #\}) - (> (length last1) 0) (char=? (string-ref last1 0) #\})) - (format #f "~D ~S~%" line last1))) - (set! last1 this))))))) + (lambda (p) + (let ((last1 "") + (last-i 0)) + (do ((this (read-line p) (read-line p)) + (line 0 (+ line 1))) + ((eq? this #<eof>)) + (let ((len (length this))) + (unless (or (= len 0) + (char=? (string-ref this 0) #\})) + (do ((i 0 (+ i 1))) + ((or (>= i len) + (not (char-whitespace? (string-ref this i)))) + (when (and (< i len) + (char=? (string-ref this i) #\}) + (> (length last1) 0) + (char=? (string-ref last1 last-i) #\})) + (format #f "~D ~S~%" line last1)) + (set! last-i i) + (set! last1 this)))))))))) ;;; -------------------------------- @@ -170,7 +175,7 @@ (set! str str1) (cond2-cposrev-2 c1 0)))) -(define tc3-cpos ; eval? (there is no op_tc_if_a_z_if_a_z_l3a but the 2 case is slower -- 2 case is not s7_optimized) +(define tc3-cpos ; eval? (there is no op_tc_if_a_z_if_a_z_l3a) (let ((len 0)) (define (cpos-3 c str pos) (if (= pos len) diff --git a/tools/fbench.scm b/tools/fbench.scm index 6107409..1b77ff4 100644 --- a/tools/fbench.scm +++ b/tools/fbench.scm @@ -117,12 +117,12 @@ (define (transit-surface) (let ((iang-sin 0)) (if (= paraxial 1) - (if (= radius-of-curvature 0) + (if (zero? radius-of-curvature) (begin (set! object-distance (* object-distance (/ to-index from-index))) (set! axis-slope-angle (* axis-slope-angle (/ from-index to-index)))) (begin - (if (= object-distance 0) + (if (zero? object-distance) (begin (set! axis-slope-angle 0) (set! iang-sin (/ ray-height radius-of-curvature))) @@ -130,15 +130,15 @@ (let ((rang-sin (* (/ from-index to-index) iang-sin)) (old-axis-slope-angle axis-slope-angle)) (set! axis-slope-angle (- (+ axis-slope-angle iang-sin) rang-sin)) - (if (not (= object-distance 0)) + (if (not (zero? object-distance)) (set! ray-height (* object-distance old-axis-slope-angle))) (set! object-distance (/ ray-height axis-slope-angle))))) - (if (= radius-of-curvature 0) + (if (zero? radius-of-curvature) (let ((rang (- (asin (* (/ from-index to-index) (sin axis-slope-angle)))))) - (set! object-distance (* object-distance (/ (* to-index (cos rang)) (* from-index (cos axis-slope-angle))))) + (set! object-distance (/ (* object-distance to-index (cos rang)) (* from-index (cos axis-slope-angle)))) (set! axis-slope-angle (- rang))) (begin - (if (= object-distance 0) + (if (zero? object-distance) (begin (set! axis-slope-angle 0) (set! iang-sin (/ ray-height radius-of-curvature))) @@ -223,12 +223,11 @@ (line 1 (+ line 1))) ((null? received) (format #t "~D error~A in results.~%" errors (if (> errors 1) "s" ""))) - (if (not (equal? (car expected) (car received))) - (begin - (set! errors (+ errors 1)) - (format () "Error in results in line ~D...~%" line) - (format () "Expected: ~A~%" (car expected)) - (format () "Received: ~A~%" (car received))))))))) + (unless (equal? (car expected) (car received)) + (set! errors (+ errors 1)) + (format () "Error in results in line ~D...~%" line) + (format () "Expected: ~A~%" (car expected)) + (format () "Received: ~A~%" (car received)))))))) (fbench 50000) diff --git a/tools/ffitest.c b/tools/ffitest.c index 6783c9e..17a3c63 100644 --- a/tools/ffitest.c +++ b/tools/ffitest.c @@ -1886,7 +1886,10 @@ int main(int argc, char **argv) { /* iterators */ - s7_pointer iter, x; + s7_pointer iter, hash, x; + s7_int gc1, gc2; + + /* iterate over list */ iter = s7_make_iterator(sc, s7_list(sc, 3, TO_S7_INT(1), TO_S7_INT(2), TO_S7_INT(3))); if (!s7_is_iterator(iter)) fprintf(stderr, "%d: %s is not an iterator\n", __LINE__, TO_STR(iter)); @@ -1904,6 +1907,25 @@ int main(int argc, char **argv) x = s7_iterate(sc, iter); if ((x != s7_eof_object(sc)) || (!s7_iterator_is_at_end(sc, iter))) fprintf(stderr, "%d: %s should be #<eof> and iter should be done\n", __LINE__, TO_STR(x)); + + /* iterate over hash table */ + hash = s7_make_hash_table(sc, 8); + gc1 = s7_gc_protect(sc, hash); + s7_hash_table_set(sc, hash, s7_make_symbol(sc, "a"), s7_make_integer(sc, 1)); + s7_hash_table_set(sc, hash, s7_make_symbol(sc, "b"), s7_make_integer(sc, 2)); + iter = s7_make_iterator(sc, hash); + gc2 = s7_gc_protect(sc, iter); + x = s7_iterate(sc, iter); + if (!s7_is_pair(x)) + fprintf(stderr, "x: %s\n", s7_object_to_c_string(sc, x)); + x = s7_iterate(sc, iter); + if (!s7_is_pair(x)) + fprintf(stderr, "x: %s\n", s7_object_to_c_string(sc, x)); + x = s7_iterate(sc, iter); + if (!s7_is_eq(s7_eof_object(sc), x)) + fprintf(stderr, "x: %s\n", s7_object_to_c_string(sc, x)); + s7_gc_unprotect_at(sc, gc1); + s7_gc_unprotect_at(sc, gc2); } g_block_type = s7_make_c_type(sc, "<block>"); diff --git a/tools/t101.scm b/tools/t101.scm index 9911a96..ec8e320 100644 --- a/tools/t101.scm +++ b/tools/t101.scm @@ -254,6 +254,9 @@ (format *stderr* "~NC tmisc ~NC~%" 20 #\- 20 #\-) (system "./repl tmisc.scm") +(format *stderr* "~NC tcase ~NC~%" 20 #\- 20 #\-) +(system "./repl tcase.scm") + (format *stderr* "~NC index ~NC~%" 20 #\- 20 #\-) (system "./snd make-index.scm") diff --git a/tools/tcase.scm b/tools/tcase.scm new file mode 100644 index 0000000..463214d --- /dev/null +++ b/tools/tcase.scm @@ -0,0 +1,595 @@ +;(set! (*s7* 'profile) 1) + +(define-macro (test expr res) + `(let ((value ,expr)) + (unless (equivalent? value ,res) + (format *stderr* "~S, expected: ~S, got: ~S~%" ',expr ,res value)))) + +(require case.scm) +(define (scase x) + (case* x + ((a b) 'a-or-b) + ((1 2/3 3.0) => (lambda (a) (* a 2))) + ((#_pi) 1 123) + (("string1" "string2")) + ((#<symbol?>) 'symbol!) + (((+ x #<symbol?>)) 'got-list) + ((#(1 x 3)) 'got-vector) + (((+ #<>)) 'empty) + (((* #<x:symbol?> #<x>)) 'got-label) + (((#<> #<x:> #<x>)) 'repeated) + (((#<symbol?> #<symbol?>)) 'two) + (((#<x:> #<x>)) 'pair) + ((#(#<x:> #<x>)) 'vector) + ((#(#<symbol?> #<...> #<number?>)) 'vectsn) + ((#(#<...> #<number?>)) 'vectstart) + ((#(#<string?> #<char-whitespace?> #<...>)) 'vectstr) + (else 'oops))) + +(define (scase5 x) + (case* x + (((#<symbol?> #<...> #<symbol?>)) 'ok))) + +(let ((local-func (lambda (key) (eqv? key 1)))) + (define (scase1 x) + (case* x + ((2 3 a) 'oops) + ((#<local-func>) 'yup)))) + +(define scase2 + (let ((local-func (lambda (key) (eqv? key 1)))) + (lambda (x) + (case* x + ((2 3 a) 'oops) + ((#<local-func>) 'yup))))) + +(define (scase3 x) + (let ((local-func (lambda (key) (eqv? key 1)))) + (case* x + ((2 3 a) 'oops) + ((#<local-func>) 'yup)))) + +(define (ecase x) + (case* x + (((#<symbol?> #<...> #<symbol?>)) 'both-symbol) + (((#<symbol?> #<...>)) 'car-symbol) + (((#<...> #<symbol?> #<symbol?>)) 'two-symbols) + (((#<...> #<symbol?>)) 'end-symbol) + (else #f))) + +(define (scase6 x) + (case* x + (((#<x:> #<x> #<...>)) 'ok) + (else 'oops))) + +(define (scase7 x) + (case* x + (((#<...> #<x:> #<x>)) 'ok) + (else 'oops))) + +(define (scase8 x) + (case* x + (((#<x:> #<...> #<x>)) 'ok) + (else 'oops))) + +(define (scase9 x) + (case* x + ((#<y>) 1) + (else 'oops))) + +(define (scase10 x) + (case* x + ((#<x>) 1) + (else 'oops))) + +(define (scase11 x) + (case* x + ((#<...>) 1) + (else 'oops))) + +(define (scase12 x) + (case* x + (((#<y:> #<zzz>)) 1) + (else 'oops))) + +(define (scase13 x) + (case* x + ((#<>) 'ok) ; matches anything! as does #<label:> + (else 'oops))) + +(define (scase14 x) + (case* x + (((#<y:> #<y:>)) 1) + (else 'oops))) + +(define uniquify + (let () + (define (uniq-1 lst new-lst) + (case* lst + ((()) + (reverse new-lst)) + (((#<>)) + (reverse (cons (car lst) new-lst))) + (((#<x:> #<x> #<...>)) + (uniq-1 (cdr lst) new-lst)) + (else + (uniq-1 (cdr lst) (cons (car lst) new-lst))))) + (lambda (lst) + (uniq-1 lst ())))) + +(define (palindrome? x) ; x can be a list or a vector + (case* x + ((() (#<>) + #() #(#<>)) + #t) + (((#<x:> #<middle:...> #<x>) + #(#<x:> #<middle:...> #<x>)) + (palindrome? #<middle>)) + (else #f))) + +(define (scase15 x) + (case* x + (((+ #<x:> #<x>)) (* 2 #<x>)) + (((#<x:> #<y:>)) (list #<y> #<x>)) + (else 'oops))) + +(define (scase16 x) + (case* x + (((+ (* #<symbol?> 2) 3)) 0) + (else 1))) + +(define (scase17 x) + (let ((a1 3)) + (case* x + (((+ #<add1:symbol?> (* #<mul1:number?> 2))) (+ #<mul1> (* #<add1> 2))) + (else 'oops)))) + +(let ((a1 3)) + (define (scase18 x) + (case* x + (((+ #<add1:symbol?> (* #<mul1:number?> 2))) (quote (+ #<mul1> (* #<add1> 2)))) + (else 'oops)))) + +(define (case-reverse x) ; maybe the least efficient reverse ever + (case* x + (((#<>) ()) x) + (((#<first:> #<rest:...>)) + (append (case-reverse #<rest>) + (list (quote #<first>)))))) + +(define (scase19 x) + (case* x + (((#<integer?> . #<symbol?>)) 'ok) + (else #f))) + +(define (scase20 x) + (case* x + ((#(+ (* #<symbol?> 2) 3)) 0) + (else 1))) + +(define scase21 + (let ((pair2? (lambda (p) + (= (length p) 2)))) + (lambda (x) + (case* x + (((+ #<pair2?> 3)) #t) + (else #f))))) + +(define scase22 + (letrec ((symbols? + (lambda (x) + (or (null? x) + (and (pair? x) + (and (symbol? (car x)) + (symbols? (cdr x)))))))) + (lambda (x) + (case* x + ((#<symbols?>) #t) + (else #f))))) + +(define scase23 + (let ((numeric-op? (lambda (x) + (let ((func (symbol->value x))) + (and (signature func) + (memq (car (signature func)) '(number? complex? real? float? rational? integer? byte?))))))) + (lambda (x) + (case* x + (((#<numeric-op?> #<number?>) + (#<numeric-op?> #<number?> #<number?>)) #t) + (else #f))))) + +(define (scase24 x) + (case* x + (((+ #<rest:...>)) + (+ (apply values #<rest>))) + (else 'oops))) + +(define (scase25 x) + (case* x + (((#<symbol?> #<ellip1:...> (+ #<ellip2:...>))) (append #<ellip1> #<ellip2>)) + (else #f))) + +(define (scase26 x) + (case* x + (((if (not #<test:>) (begin #<body:...>))) (cons 'unless (cons '#<test> #<body>))) + (((if (not #<test:>) #<body:>)) (cons 'unless (list '#<test> '#<body>))) + (((if #<test:> (begin #<body:...>))) (cons 'when (cons '#<test> #<body>))) + (((if #<test:> #<body:>)) (cons 'when (list '#<test> '#<body>))))) + + +(define (scase27 x) + (let ((efunc? (lambda (x) + (and (pair? x) + (number? (car x)))))) + (case* x + (((#<label,efunc?:...>)) #t) + (else #f)))) + +(define (scase29 x) + (let ((match? ((funclet 'case*) 'case*-match?))) + (let ((multiplier? (lambda (x) + (or (match? x '(* 1 #<integer?>)) + (match? x '(* 2 #<integer?>)))))) + (case* x + (((+ #<integer?> #<multiplier?> #<integer?>)) #t) + (else #f))))) + +(define (scase30 x) + (let ((match? ((funclet 'case*) 'case*-match?))) + (match? x '(+ #<symbol?> 1)))) + +(define* (scase31 x (e (curlet))) + (let ((match? ((funclet 'case*) 'case*-match?)) + (labels ((funclet 'case*) 'case*-labels))) + (and (match? x '(#<symbol?> #<ellip1:...> (+ #<ellip2:...>))) + (append (cadr (labels 'ellip1)) (cadr (labels 'ellip2)))))) + +(define (scase32 x) + (let ((match? ((funclet 'case*) 'case*-match?)) + (labels ((funclet 'case*) 'case*-labels))) + (if (match? x '(if #<test:> (begin #<body:...>))) + (cons 'when (cons (labels 'test) (cadr (labels 'body))))))) + +(define (scase33 x) + (case* x + ((#<"a.b">) #t) + (else #f))) + +(define (scase34 x) + (case* x + ((#<reg:"a.b">) #<reg>) + (else #f))) + +(define (scase35 x) + (let ((quotes? (lambda (x) + (char-position #\" x)))) + (case* x + ((#<"^dog">) 'dog0) + ((#<"gray\|grey">) 'graey) ; basic regex so it needs \, apparently doesn't work in OSX? + ((#<"h\(a\|e\)y">) 'haey) + ((#<"p[ae]y">) 'paey) + ((#<"b[aeiou]bble">) 'bxbble) + ((#<"z\{3,6\}">) 'zzz) + ((#<"\d">) 'digit) + ((#<"<>">) 'brackets) + ((#<quotes?>) 'quotes) + ((#<"[^i*&2@]">) 'not-i) + (else #f)))) + + +(test (scase 3.0) 6.0) +(test (scase pi) 123) +(test (scase "string1") "string1") +(test (scase "string3") 'oops) +(test (scase 'a) 'a-or-b) +(test (scase 'abc) 'symbol!) +(test (scase #()) 'oops) +(test (scase '(+ x z)) 'got-list) +(test (scase #(1 x 3)) 'got-vector) +(test (scase '(+ x 3)) 'oops) +(test (scase '(+ x)) 'empty) +(test (scase '(* z z)) 'got-label) +(test (scase '(* z x)) 'oops) +(test (scase '(+ (abs x) (abs x))) 'repeated) +(test (scase '(+ (abs x) (abs y))) 'oops) +(test (scase '(a b)) 'two) +(test (scase '(1 1)) 'pair) +(test (scase '(1 1 2)) 'oops) +(test (scase #(1 1)) 'vector) +(test (scase #(a b c 3)) 'vectsn) +(test (scase #(1 b 2)) 'vectstart) +(test (scase #("asdf" #\space +nan.0 #<eof>)) 'vectstr) +(test (scase #(a 3)) 'vectsn) +(test (scase #(1)) 'vectstart) +(test (scase #("asdf" #\space)) 'vectstr) +(test (scase #("asdf")) 'oops) + +(test (scase5 '(a)) #<unspecified>) + +(test (scase2 2) 'oops) +(test (scase2 32) #<unspecified>) +(test (scase2 1) 'yup) +(test (scase3 2) 'oops) +(test (scase3 32) #<unspecified>) +(test (scase3 1) 'yup) + +(test (scase6 '(a a)) 'ok) +(test (scase7 '(a a)) 'ok) +(test (scase8 '(a a)) 'ok) +(test (catch #t (lambda () (scase9 1)) (lambda (type info) type)) 'oops) +(test (catch #t (lambda () (scase10 1)) (lambda (type info) type)) 'oops) +(test (catch #t (lambda () (scase11 1)) (lambda (type info) type)) 'oops) +(test (catch #t (lambda () (scase12 '(1 2))) (lambda (type info) type)) 'unbound-variable) + +(test (ecase '(a b 1)) 'car-symbol) +(test (ecase '(1 2 c)) 'end-symbol) +(test (ecase '(a 1 2 3 c)) 'both-symbol) +(test (ecase '(1 2 3 b c)) 'two-symbols) +(test (scase13 '(a a)) 'ok) +(test (scase13 1+i) 'ok) +(test (scase13 #(1 2 3)) 'ok) +(test (catch #t (lambda () (scase14 '(1 1))) (lambda (type info) type)) 'syntax-error) ; duplicate identifier currently uses this error type +(test (uniquify '(a a b b b b a a c c)) '(a b a c)) +(test (uniquify '((+ a 1) (+ a 1) (* b 2) (* b 2) c a a)) '((+ a 1) (* b 2) c a)) +(test (uniquify '(a b b c)) '(a b c)) +(test (uniquify '(a)) '(a)) +(test (uniquify ()) ()) + +(let ((x '(+ 2 3))) + (test (case* x + (((+ #<> #<>)) (apply + (cdr x))) + (else (error 'out-of-range "unimplemented"))) + 5)) + +(test (palindrome? '(a b a)) #t) +(test (palindrome? '(a b c a)) #f) +(test (palindrome? '(a b c b a)) #t) +(test (palindrome? '(a)) #t) +(test (palindrome? ()) #t) + +(test (palindrome? #(a b a)) #t) +(test (palindrome? #(a b c a)) #f) +(test (palindrome? #(a b c b a)) #t) +(test (palindrome? #(a)) #t) +(test (palindrome? #()) #t) + +(test (case* '(a b a) (((#<start:...> #<symbol?>)) #<start>)) '(a b)) +(test (case* '(a) (((#<start:...> #<symbol?>)) #<start>)) ()) +(test (case* '(a b) (((#<start:...> #<symbol?>)) #<start>)) '(a)) +(test (case* '(a b a) (((#<symbol?> #<end:...>)) #<end>)) '(b a)) +(test (case* '(a) (((#<symbol?> #<end:...>)) #<end>)) ()) +(test (case* '(a b) (((#<symbol?> #<end:...>)) #<end>)) '(b)) +(test (case* '(a b a) (((#<symbol?> #<middle:...> #<symbol?>)) #<middle>)) '(b)) +(test (case* '(a a) (((#<symbol?> #<middle:...> #<symbol?>)) #<middle>)) ()) +(test (case* '(a b c a) (((#<symbol?> #<middle:...> #<symbol?>)) #<middle>)) '(b c)) + +(test (case* #(a b a) ((#(#<start:...> #<symbol?>)) #<start>)) '(a b)) +(test (case* #(a) ((#(#<start:...> #<symbol?>)) #<start>)) ()) +(test (case* #(a b) ((#(#<start:...> #<symbol?>)) #<start>)) '(a)) +(test (case* #(a b a) ((#(#<symbol?> #<end:...>)) #<end>)) '(b a)) +(test (case* #(a) ((#(#<symbol?> #<end:...>)) #<end>)) ()) +(test (case* #(a b) ((#(#<symbol?> #<end:...>)) #<end>)) '(b)) +(test (case* #(a b a) ((#(#<symbol?> #<middle:...> #<symbol?>)) #<middle>)) '(b)) +(test (case* #(a a) ((#(#<symbol?> #<middle:...> #<symbol?>)) #<middle>)) ()) +(test (case* #(a b c a) ((#(#<symbol?> #<middle:...> #<symbol?>)) #<middle>)) '(b c)) + +(test (scase15 '(1 2)) '(2 1)) +(test (scase15 '(+ 1 1)) 2) +(test (scase15 '(+ (* 2 3) (* 2 3))) 12) +(test (scase16 '(+ (* y 2) 3)) 0) +(test (scase16 '(+ (* y 1) 3)) 1) + +(test (scase17 '(+ a1 (* 5 2))) 11) + +(test (case-reverse '(a b c)) '(c b a)) +(test (case-reverse '(a b)) '(b a)) +(test (scase19 (cons 1 'a)) 'ok) +(test (scase19 (list 1 'a)) #f) +(test (scase20 #(+ (* y 2) 3)) 0) +(test (scase20 #(+ (* y 1) 3)) 1) +(test (scase21 '(+ (abs x) 3)) #t) +(test (scase21 '(+ (* 2 x) 3)) #f) +(test (scase22 '(+ a b c)) #t) +(test (scase22 '(+ a b 3)) #f) +(test (scase23 '(+ 1 2)) #t) +(test (scase23 '(floor 32.1)) #t) +(test (scase23 '(abs)) #f) +(test (scase24 '(+ 1 2 3)) 6) + +(test (scase25 '(a b c d (+ 1 2))) '(b c d 1 2)) +(test (scase26 '(if (not (> i 3)) (display i))) '(unless (> i 3) (display i))) +(test (scase26 '(if (not (> i 3)) (begin (display i) (newline)))) '(unless (> i 3) (display i) (newline))) +(test (scase26 '(if (> i 3) (display i))) '(when (> i 3) (display i))) +(test (scase26 '(if (> i 3) (begin (display i) (newline)))) '(when (> i 3) (display i) (newline))) + +(test (scase27 '(1 2 3)) #t) +(test (scase27 '(a 2 3)) #f) +(test (scase27 '(3)) #t) +(test (scase27 ()) #f) +(test (scase29 '(+ 1 (* 1 2) 3)) #t) +(test (scase29 '(+ 1 (* 3 2) 3)) #f) +(test (scase30 '(+ a 1)) #t) +(test (scase30 '(+ 1 1)) #f) +(test (scase31 '(a b c d (+ 1 2))) '(b c d 1 2)) +(test (scase32 '(if (> i 3) (begin (display i) (newline)))) '(when (> i 3) (display i) (newline))) +(test (scase32 '(if 32/15 (begin (display i) (newline)))) '(when 32/15 (display i) (newline))) +(test (scase33 "a1b") #t) +(test (scase33 "abc") #f) +(test (scase33 "a123b") #f) +(test (scase33 'a1b) #f) +(test (scase34 "a1b") "a1b") +(test (scase35 "dog") 'dog0) +(test (scase35 "i7+") 'not-i) +(test (scase35 "gray") 'graey) +(test (scase35 "hay") 'haey) +(test (scase35 "pay") 'paey) +(test (scase35 "bubble") 'bxbble) +(test (scase35 "ab0d") 'digit) +(test (scase35 "+-<>-+") 'brackets) +(test (scase35 "zzzz") 'zzz) +(test (scase35 (string #\a #\")) 'quotes) + + +(define (tst) + (do ((i 0 (+ i 1))) + ((= i 1000)) + (scase 3.0) + (scase pi) + (scase "string1") + (scase "string3") + (scase 'a) + (scase 'abc) + (scase #()) + (scase '(+ x z)) + (scase #(1 x 3)) + (scase '(+ x 3)) + (scase '(+ x)) + (scase '(* z z)) + (scase '(* z x)) + (scase '(+ (abs x))) + (scase '(+ (abs x))) + (scase '(a b)) + (scase '(1 1)) + (scase '(1 1 2)) + (scase #(1 1)) + (scase #(a b c 3)) + (scase #(1 b 2)) + (scase #("asdf" #\space +nan.0 #<eof>)) + (scase #(a 3)) + (scase #(1)) + (scase #("asdf" #\space)) + (scase #("asdf")) + + (scase5 '(a)) + + (scase2 2) + (scase2 32) + (scase2 1) + (scase3 2) + (scase3 32) + (scase3 1) + + (scase6 '(a a)) + (scase7 '(a a)) + (scase8 '(a a)) + (catch #t (lambda () (scase9 1)) (lambda (type info) type)) + (catch #t (lambda () (scase10 1)) (lambda (type info) type)) + (catch #t (lambda () (scase11 1)) (lambda (type info) type)) + (catch #t (lambda () (scase12 '(1 2))) (lambda (type info) type)) + + (ecase '(a b 1)) + (ecase '(1 2 c)) + (ecase '(a 1 2 3 c)) + (ecase '(1 2 3 b c)) + (scase13 '(a a)) + (scase13 1+i) + (scase13 #(1 2 3)) + (catch #t (lambda () (scase14 '(1 1))) (lambda (type info) type)) + + (uniquify '(a a b b b b a a c c)) + (uniquify '((+ a 1) (+ a 1) (* b 2) (* b 2) c a a)) + (uniquify '(a b b c)) + (uniquify '(a)) + (uniquify ()) + + (let ((x '(+ 2 3))) + (case* x + (((+ #<> #<>)) (apply + (cdr x))) + (else (error 'out-of-range "unimplemented")))) + + (palindrome? '(a b a)) + (palindrome? '(a b c a)) + (palindrome? '(a b c b a)) + (palindrome? '(a)) + (palindrome? ()) + + (palindrome? #(a b a)) + (palindrome? #(a b c a)) + (palindrome? #(a b c b a)) + (palindrome? #(a)) + (palindrome? #()) + + (case* '(a b a) (((#<start:...> #<symbol?>)) #<start>)) + (case* '(a) (((#<start:...> #<symbol?>)) #<start>)) + (case* '(a b) (((#<start:...> #<symbol?>)) #<start>)) + (case* '(a b a) (((#<symbol?> #<end:...>)) #<end>)) + (case* '(a) (((#<symbol?> #<end:...>)) #<end>)) + (case* '(a b) (((#<symbol?> #<end:...>)) #<end>)) + (case* '(a b a) (((#<symbol?> #<middle:...> #<symbol?>)) #<middle>)) + (case* '(a a) (((#<symbol?> #<middle:...> #<symbol?>)) #<middle>)) + (case* '(a b c a) (((#<symbol?> #<middle:...> #<symbol?>)) #<middle>)) + + (case* #(a b a) ((#(#<start:...> #<symbol?>)) #<start>)) + (case* #(a) ((#(#<start:...> #<symbol?>)) #<start>)) + (case* #(a b) ((#(#<start:...> #<symbol?>)) #<start>)) + (case* #(a b a) ((#(#<symbol?> #<end:...>)) #<end>)) + (case* #(a) ((#(#<symbol?> #<end:...>)) #<end>)) + (case* #(a b) ((#(#<symbol?> #<end:...>)) #<end>)) + (case* #(a b a) ((#(#<symbol?> #<middle:...> #<symbol?>)) #<middle>)) + (case* #(a a) ((#(#<symbol?> #<middle:...> #<symbol?>)) #<middle>)) + (case* #(a b c a) ((#(#<symbol?> #<middle:...> #<symbol?>)) #<middle>)) + + (scase15 '(1 2)) + (scase15 '(+ 1 1)) + (scase15 '(+ (* 2 3) (* 2 3))) + (scase16 '(+ (* y 2) 3)) + (scase16 '(+ (* y 1) 3)) + + (scase17 '(+ a1 (* 5 2))) + + (case-reverse '(a b c)) + (case-reverse '(a b)) + (scase19 (cons 1 'a)) + (scase19 (list 1 'a)) + (scase20 #(+ (* y 2) 3)) + (scase20 #(+ (* y 1) 3)) + (scase21 '(+ (abs x) 3)) + (scase21 '(+ (* 2 x) 3)) + (scase22 '(+ a b c)) + (scase22 '(+ a b 3)) + (scase23 '(+ 1 2)) + (scase23 '(floor 32.1)) + (scase23 '(abs)) + (scase24 '(+ 1 2 3)) + + (scase25 '(a b c d (+ 1 2))) + (scase26 '(if (not (> i 3)) (display i))) + (scase26 '(if (not (> i 3)) (begin (display i) (newline)))) + (scase26 '(if (> i 3) (display i))) + (scase26 '(if (> i 3) (begin (display i) (newline)))) + + (scase27 '(1 2 3)) + (scase27 '(a 2 3)) + (scase27 '(3)) + (scase27 ()) + (scase29 '(+ 1 (* 1 2) 3)) + (scase29 '(+ 1 (* 3 2) 3)) + (scase30 '(+ a 1)) + (scase30 '(+ 1 1)) + (scase31 '(a b c d (+ 1 2))) + (scase32 '(if (> i 3) (begin (display i) (newline)))) + (scase32 '(if 32/15 (begin (display i) (newline)))) + (scase33 "a1b") + (scase33 "abc") + (scase33 "a123b") + (scase33 'a1b) + (scase34 "a1b") + (scase35 "dog") + (scase35 "i7+") + (scase35 "gray") + (scase35 "hay") + (scase35 "pay") + (scase35 "bubble") + (scase35 "ab0d") + (scase35 "+-<>-+") + (scase35 "zzzz") + (scase35 (string #\a #\")) + )) + +(tst) + + +; (when (> (*s7* 'profile) 0) (show-profile 500)) + + +(exit) diff --git a/tools/tgc.scm b/tools/tgc.scm index a1d209e..154b582 100644 --- a/tools/tgc.scm +++ b/tools/tgc.scm @@ -102,56 +102,55 @@ (define (tgc tries vsize) - (let ((wait (make-vector vsize #f))) - (do ((i 0 (+ i 1))) - ((= i tries)) - (let ((p1 (cons 1 2)) - (p2 (list 1 1 1 1 1 1 1)) - (p3 (list 1 2))) - (set-cdr! (cdr p3) p3) - (let ((v1 (vector 1 2)) - (v2 (make-vector 7 1)) - (v3 (vector 1 2 3)) - (v4 (make-vector '(3 2)))) - (vector-set! v3 2 v3) - (let ((s1 (string #\a #\s #\d #\f))) - (let ((iv1 (int-vector 1 2)) - (iv2 (make-int-vector 7 1))) - (let ((h1 (hash-table 'a 1)) - (h2 (weak-hash-table 'b p1))) - (let ((i1 (inlet 'a 1 'b 2))) - (let ((in1 (open-output-string))) - (format in1 "asdf\n") - (let ((in2 (open-input-string "asdf\n"))) - (read-line in2) - (let ((c1 (c-pointer 0 integer? "info" (cons h1 h2) (vector p3 p2 p1)))) - (let ((cc (call/cc (lambda (ret) ret)))) - (let ((ex1 (call-with-exit - (lambda (go) - go)))) - (let ((f1 (lambda (a b c) (+ a b c)))) - (let ((u1 #<asdf>)) - (let ((g1 (gensym))) - (let ((it1 (make-iterator '(1 2 3)))) - (let ((b1 (block 1 2 3))) - (for-each - (lambda (a) - (let ((pos (random vsize))) - (if (eqv? (vector-ref wait pos) #\c) ; just check that it hasn't been freed - (format *stderr* "~S?" (vector-ref wait pos))) - (vector-set! wait pos a)) - (dynamic-wind - (lambda () #f) - (lambda () - (catch #t - (lambda () - (call-with-exit - (lambda (r) - (r a)))) - (lambda (type info) - (format *stderr* "~A: ~A~%" type (apply format #f info))))) - (lambda () #f))) - (list p1 p2 p3 v1 v2 v3 v4 s1 iv2 iv2 h1 h2 i1 in1 in2 c1 cc ex1 u1 g1 it1 b1))))))))))))))))))))) + (do ((wait (make-vector vsize #f)) + (i 0 (+ i 1))) + ((= i tries)) + (let ((p1 (cons 1 2)) + (p2 (list 1 1 1 1 1 1 1)) + (p3 (list 1 2)) + (v1 (vector 1 2)) + (v2 (make-vector 7 1)) + (v3 (vector 1 2 3)) + (v4 (make-vector '(3 2))) + (s1 (string #\a #\s #\d #\f)) + (iv2 (make-int-vector 7 1)) + (h1 (hash-table 'a 1)) + (i1 (inlet 'a 1 'b 2)) + (in1 (open-output-string)) + (in2 (open-input-string "asdf\n")) + (cc (call/cc (lambda (ret) ret))) + (ex1 (call-with-exit + (lambda (go) + go))) + (f1 (lambda (a b c) (+ a b c))) + (u1 #<asdf>) + (g1 (gensym)) + (it1 (make-iterator '(1 2 3))) + (b1 (block 1 2 3))) + (set-cdr! (cdr p3) p3) + (vector-set! v3 2 v3) + (format in1 "asdf\n") + (read-line in2) + (let* ((h2 (weak-hash-table 'b p1)) + (c1 (c-pointer 0 integer? "info" (cons h1 h2) (vector p3 p2 p1)))) + (for-each + (lambda (a) + (let ((pos (random vsize))) + (if (eqv? (vector-ref wait pos) #\c) ; just check that it hasn't been freed + (format *stderr* "~S?" (vector-ref wait pos))) + (vector-set! wait pos a)) + (dynamic-wind + (lambda () #f) + (lambda () + (catch #t + (lambda () + (call-with-exit + (lambda (r) + (r a)))) + (lambda (type info) + (format *stderr* "~A: ~A~%" type (apply format #f info))))) + (lambda () #f))) + (list p1 p2 p3 v1 v2 v3 v4 s1 iv2 iv2 h1 h2 i1 in1 in2 c1 cc ex1 u1 g1 it1 b1)))))) (tgc 200000 200) ;(tgc 1000000000 200) diff --git a/tools/tio.scm b/tools/tio.scm index baaa4b3..701a44c 100644 --- a/tools/tio.scm +++ b/tools/tio.scm @@ -16,19 +16,20 @@ ((= i ssize)) (wis))) -(define (cwis) +(define cwis (let ((a (char->integer #\a)) (s (char->integer #\s))) - (call-with-input-string "asdf" - (lambda (p) - (if (port-closed? p) - (format *stderr* "cwis port closed\n")) - (unless (eqv? (read-byte p) a) - (format *stderr* "call read-char trouble\n")) - (unless (eqv? (read-byte p) s) - (format *stderr* "call read-char trouble\n")) - (unless (eqv? (port-position p) 2) - (format *stderr* "cwis position: ~A~%" (port-position p))))))) + (lambda () + (call-with-input-string "asdf" + (lambda (p) + (if (port-closed? p) + (format *stderr* "cwis port closed\n")) + (unless (eqv? (read-byte p) a) + (format *stderr* "call read-char trouble\n")) + (unless (eqv? (read-byte p) s) + (format *stderr* "call read-char trouble\n")) + (unless (= (port-position p) 2) + (format *stderr* "cwis position: ~A~%" (port-position p)))))))) (define (call-cwis) (do ((i 0 (+ i 1))) @@ -99,7 +100,7 @@ (define (call-wof) (do ((i 0 (+ i 1))) - ((= i fsize)) + ((= i 10)) (wof))) (define (cwof) @@ -109,7 +110,7 @@ (define (call-cwof) (do ((i 0 (+ i 1))) - ((= i fsize)) + ((= i 10)) (cwof))) (define (op1) @@ -151,9 +152,9 @@ (format *stderr* "op3 trouble\n")) (unless (string=? (read-line port) "fdsa") (format *stderr* "op3 2 trouble\n")) - (unless (eqv? (port-position port) 10) + (unless (= (port-position port) 10) (format *stderr* "op3 pos: ~S~%" (port-position port))) - (unless (eqv? (port-line-number port) 3) ; 1-based?? + (unless (= (port-line-number port) 3) ; 1-based?? (format *stderr* "op3 line: ~S~%" (port-line-number port))) (close-input-port port))) @@ -169,7 +170,7 @@ (define (call-op4) (do ((i 0 (+ i 1))) - ((= i fsize)) + ((= i 10)) (op4))) #| diff --git a/tools/tlet.scm b/tools/tlet.scm index cbbdf72..396b27e 100644 --- a/tools/tlet.scm +++ b/tools/tlet.scm @@ -46,12 +46,12 @@ (sum2 0.0) (sum3 0.0) (inc 0.0)) - (do ((i 0 (+ i 1))) - ((= i size)) - (set! inc (symbol->value (vector-ref symbols i))) - (set! sum1 (+ sum1 inc)) - (set! sum2 (- sum2 inc)) - (set! sum3 (+ sum3 (symbol->value (vector-ref symbols (random i)))))) + (do ((i 0 (#_+ i 1))) + ((#_= i size)) + (set! inc (#_symbol->value (#_vector-ref symbols i))) + (set! sum1 (#_+ sum1 inc)) + (set! sum2 (#_- sum2 inc)) + (set! sum3 (#_+ sum3 (#_symbol->value (#_vector-ref symbols (#_random i)))))) (format *stderr* "~A ~A ~A ~A~%" (/ (- (* size size) size) 2) sum1 sum2 sum3)))) (in-e) @@ -195,7 +195,7 @@ 'xx (* a 2) 'yy (- a 1) 'zz (lambda () 22)) - (+ x y (z) xx yy (zz)))) + (#_+ x y (z) xx yy (zz)))) (define (test51) (unless (= (f51 5) 84) (format *stderr* "(f51 5): ~S (expected ~S)~%" (f51 5) 84)) (do ((i 0 (+ i 1))) @@ -205,7 +205,7 @@ (define (f52 a) (with-let (inlet 'x (+ a 1)) - (* x 2))) + (#_* x 2))) (define (test52) (unless (= (f52 5) 12) (format *stderr* "(f52 5): ~S (expected ~S)~%" (f52 5) 12)) (do ((i 0 (+ i 1))) diff --git a/tools/tmat.scm b/tools/tmat.scm index 69f40c3..ab5f276 100755 --- a/tools/tmat.scm +++ b/tools/tmat.scm @@ -24,20 +24,18 @@ ((= k n)) (if (= (pivots k) 0) (let ((val (abs (matrix j k)))) - (if (> val biggest) - (begin - (set! col k) - (set! row j) - (set! biggest val)))) + (when (> val biggest) + (set! col k) + (set! row j) + (set! biggest val))) (if (> (pivots k) 1) (return #f)))))) (set! (pivots col) (+ (pivots col) 1)) (if (not (= row col)) (let ((temp (if (sequence? b) (b row) 0.0))) - (if (sequence? b) - (begin - (set! (b row) (b col)) - (set! (b col) temp))) + (when (sequence? b) + (set! (b row) (b col)) + (set! (b col) temp)) (do ((k 0 (+ k 1))) ((= k n)) (set! temp (matrix row k)) diff --git a/tools/tmisc.scm b/tools/tmisc.scm index 491418a..46c33e3 100644 --- a/tools/tmisc.scm +++ b/tools/tmisc.scm @@ -36,30 +36,30 @@ (fe-test 3000000) (define (map-test size) - (let ((str (make-string size #\a))) - (let ((result (apply string (map (lambda (c) #\b) str)))) - (unless (string=? result (make-string size #\b)) - (format *stderr* "map string failed\n")))) - - (let ((str (make-byte-vector size 10))) - (let ((result (apply byte-vector (map (lambda (c) 11) str)))) - (unless (equal? result (make-byte-vector size 11)) - (format *stderr* "map byte-vector failed\n")))) - - (let ((str (make-int-vector size 10))) - (let ((result (apply int-vector (map (lambda (c) 11) str)))) - (unless (equal? result (make-int-vector size 11)) - (format *stderr* "map int-vector failed\n")))) - - (let ((str (make-float-vector size 10))) - (let ((result (apply float-vector (map (lambda (c) 11) str)))) - (unless (equal? result (make-float-vector size 11)) - (format *stderr* "map float-vector failed\n")))) - - (let ((str (make-vector size 10))) - (let ((result (apply vector (map (lambda (c) 11) str)))) - (unless (equal? result (make-vector size 11)) - (format *stderr* "map vector failed\n"))))) + (let* ((str (make-string size #\a)) + (result (apply string (map (lambda (c) #\b) str)))) + (unless (string=? result (make-string size #\b)) + (format *stderr* "map string failed\n"))) + + (let* ((str (make-byte-vector size 10)) + (result (apply byte-vector (map (lambda (c) 11) str)))) + (unless (equal? result (make-byte-vector size 11)) + (format *stderr* "map byte-vector failed\n"))) + + (let* ((str (make-int-vector size 10)) + (result (apply int-vector (map (lambda (c) 11) str)))) + (unless (equal? result (make-int-vector size 11)) + (format *stderr* "map int-vector failed\n"))) + + (let* ((str (make-float-vector size 10)) + (result (apply float-vector (map (lambda (c) 11) str)))) + (unless (equal? result (make-float-vector size 11)) + (format *stderr* "map float-vector failed\n"))) + + (let* ((str (make-vector size 10)) + (result (apply vector (map (lambda (c) 11) str)))) + (unless (equal? result (make-vector size 11)) + (format *stderr* "map vector failed\n")))) (map-test 500000) @@ -230,7 +230,7 @@ ;;; -------- typers -------- (let () (define (10-or-12? val) - (and (integer? val) + (and (integer? val) ; hmmm -- this is faster than (memv val '(10 12)) (or (= val 10) (= val 12)))) @@ -279,6 +279,74 @@ (test 100000)) +;;; -------- built-ins via #_ -------- + +(define (u0) + (do ((i 0 (+ i 1))) + ((= i 100000) (#_list)) + (#_list))) + +(unless (null? (u0)) (format *stderr* "u0: ~S~%" (u0))) + +(define (u1) + (do ((i 0 (+ i 1))) + ((= i 1000000) (#_length "asdfghjklijk")) + (#_length "asdfghjklijk"))) + +(unless (eqv? (u1) 12) (format *stderr* "u1: ~S~%" (u1))) + +(define (u2) + (let ((str "asdfghjklijk")) + (do ((i 0 (+ i 1))) + ((= i 100000) (#_char-position #\h str)) + (#_char-position #\h str)))) + +(unless (eqv? (u2) 5) (format *stderr* "u2: ~S~%" (u2))) + +(define (u3) + (do ((i 0 (+ i 1))) + ((= i 1000000) (#_+ i (* -2 i) i)) + (#_+ i (* -2 i) i))) + +(unless (eqv? (u3) 0) (format *stderr* "u3: ~S~%" (u3))) + + +;;; -------- methods -------- + +(define (m5) + (let ((L (openlet (inlet :length (lambda (str) (+ 2 (#_string-length "asdfghjklijk"))))))) + (do ((i 0 (+ i 1))) + ((= i 1000000) (length L)) + (length L)))) + +(unless (eqv? (m5) 14) (format *stderr* "m5: ~S~%" (m5))) + +(define (m6) + (let ((L (openlet (inlet :length (lambda (str) (+ 2 (#_string-length str))))))) + (do ((i 0 (+ i 1))) + ((= i 1000000) (with-let L (length "asdfghjklijk"))) + (with-let L + (length "asdfghjklijk"))))) + +(unless (eqv? (m6) 14) (format *stderr* "m6: ~S~%" (m6))) + +(define (m7) + (let ((L (openlet (inlet :+ (lambda (x y) (#_+ x y 1)))))) + (do ((i 0 (+ i 1))) + ((= i 500000) ((L :+) 2 3)) + ((L :+) 2 3)))) + +(unless (eqv? (m7) 6) (format *stderr* "m7: ~S~%" (m7))) + +(define (m8) + (let ((L (openlet (inlet :+ (lambda args (apply #_+ 1 args)))))) + (do ((i 0 (+ i 1))) + ((= i 500000) (with-let L (+ 2 3))) + (with-let L (+ 2 3))))) + +(unless (eqv? (m8) 6) (format *stderr* "m8: ~S~%" (m8))) + + ;;; -------- unlet -------- ;;; incrementally set all globals to 42 -- check that unlet exprs return the same results diff --git a/tools/tmock.scm b/tools/tmock.scm index d013301..9740a12 100644 --- a/tools/tmock.scm +++ b/tools/tmock.scm @@ -74,11 +74,10 @@ (let ((temp (data j))) (set! (data j) (data i)) (set! (data i) temp))) - (do ((m (/ n 2))) + (do ((m (/ n 2) (/ m 2))) ((or (< m 2) (< j m)) (set! j (+ j m))) - (set! j (- j m)) - (set! m (/ m 2)))) + (set! j (- j m)))) (let ((ipow (floor (log n 2))) (prev 1)) diff --git a/tools/tnum.scm b/tools/tnum.scm index 503decf..eb076dd 100644 --- a/tools/tnum.scm +++ b/tools/tnum.scm @@ -16,13 +16,14 @@ (set! phase (+ phase freq)))) ;; now take the DFT (let ((pk 0.0) - (w (make-vector N))) + (w (make-vector N)) + (c (* 2.0 0+1.0i pi))) (do ((i 0 (+ i 1)) (sum 0.0 0.0)) ((= i N)) (do ((k 0 (+ k 1))) ((= k N)) - (set! sum (+ sum (* (vals k) (exp (/ (* 2.0 0+1.0i pi k i) N)))))) + (set! sum (+ sum (* (vals k) (exp (/ (* c k i) N)))))) (set! (w i) (magnitude sum)) (set! pk (max pk (w i)))) ;; scale to 1.0 (it's usually pretty close already, that is pk is close to 1.0) diff --git a/tools/tread.scm b/tools/tread.scm index b6ca3c5..24aab9e 100644 --- a/tools/tread.scm +++ b/tools/tread.scm @@ -43,7 +43,7 @@ (set! (b1 loc) b2) (set! sets (cons (list r1 loc r2) sets))) (begin - (set-cdr! (list-tail b1 2) (case loc ((0) b1) ((1) (cdr b1)) (else (cddr b1)))) + (set-cdr! (cddr b1) (case loc ((0) b1) ((1) (cdr b1)) (else (cddr b1)))) (set! sets (cons (list r1 (+ loc 3) r2) sets))))) ((vector?) diff --git a/tools/valcall.scm b/tools/valcall.scm index f91148e..aeeaa89 100644 --- a/tools/valcall.scm +++ b/tools/valcall.scm @@ -79,31 +79,31 @@ (list "repl" "s7test.scm") (list "repl" "lt.scm") (list "repl" "tcopy.scm") - (list "repl" "tform.scm") (list "repl" "tmat.scm") + (list "repl" "tform.scm") (list "repl" "tread.scm") (list "repl" "tvect.scm") - (list "repl" "fbench.scm") (list "repl" "trclo.scm") + (list "repl" "fbench.scm") (list "repl" "titer.scm") (list "repl" "tmap.scm") (list "repl" "tsort.scm") (list "repl" "tset.scm") - (list "repl" "dup.scm") (list "repl" "tmac.scm") + (list "repl" "dup.scm") + (list "repl" "tio.scm") (list "repl" "teq.scm") (list "repl" "tfft.scm") - (list "repl" "tio.scm") - (list "repl" "tmisc.scm") (list "repl" "tclo.scm") - (list "repl" "tlet.scm") (list "repl" "tcase.scm") + (list "repl" "tlet.scm") (list "repl" "concordance.scm") (list "repl" "trec.scm") (list "repl" "tnum.scm") + (list "repl" "tmisc.scm") + (list "repl" "tgc.scm") (list "snd -noinit" "tgen.scm") ; repl here + cload sndlib was slower (list "repl" "thash.scm") - (list "repl" "tgc.scm") (list "snd -noinit" "tall.scm") (list "snd -l" "snd-test.scm") (list "snd -l" "full-snd-test.scm") @@ -89,14 +89,14 @@ return help associated with name (String or Symbol) or false" void xen_initialize(void) { int argc = 4; - char *argv[] = {"xen", "--disable-gems", "-e", ";"}; + const char *argv[] = {"xen", "--disable-gems", "-e", ";"}; #ifdef RUBY_INIT_STACK RUBY_INIT_STACK; #endif ruby_init(); - ruby_options(argc, argv); + ruby_options(argc, (char **)argv); Init_Hook(); } |