Port to Chicken 6

.envrc

@@ -0,0 +1,2 @@
+export NIXPKGS_ALLOW_BROKEN=1
+use nix

README.org

@@ -0,0 +1,3 @@
+* apropos Egg for Chicken 6
+
+This is a port of =apropos= to Chicken 6. It implements minimal changes to make the egg work.

apropos-api.scm

@@ -0,0 +1,942 @@
+;;;; apropos-api.scm  -*- Scheme -*-
+;;;; Kon Lovett, Jul '18
+;;;; Kon Lovett, Oct '17
+;;;; Kon Lovett, Mar '09
+;;;; From the Chicken 4 core, Version 4.0.0x5 - SVN rev. 13662
+
+;; Issues
+;;;
+;; - Use of 'global-symbol' routines is just wrong when an
+;; evaluation-environment (##sys#environment?) is not the
+;; interaction-environment.
+;;
+;; - Doesn't show something similar to procedure-information for macros. And
+;; how could it.
+;;
+;; - Could be re-written to use the "environments" extension. Which in turn would
+;; need to support syntactic environments, at least for lookup opertations.
+;;
+;; - The CHICKEN 'environment' object does not hold the (syntactic) bindings
+;; for any syntactic keywords from the R5RS. The public API of 'apropos'
+;; attempts to hide this fact.
+
+(include-relative "symbol-environment-access")
+(include-relative "symbol-access")
+
+(module apropos-api
+
+(;export
+  ;apropos-toplevel-module-symbol ;needs excluded-modules treatment
+  apropos-excluded-modules
+  apropos-default-base
+  apropos-interning
+  apropos-default-options
+  ;
+  check-apropos-number-base
+  apropos-find-key? check-apropos-find-key error-apropos-find-key
+  apropos-sort-key? check-apropos-sort-key error-apropos-sort-key
+  ;
+  apropos apropos-list apropos-information-list)
+
+(import scheme)
+(import (chicken base))
+(import (chicken fixnum))
+(import (chicken foreign))
+(import (chicken syntax))
+(import (chicken keyword))
+(import (chicken sort))
+(import (chicken type))
+(import (only (chicken irregex)
+  sre->irregex irregex irregex?
+  irregex-num-submatches irregex-search irregex-match irregex-match-data?
+  irregex-match-num-submatches irregex-replace))
+(import (only (srfi 1) reverse! append! last-pair proper-list?))
+(import (only srfi-13
+  string-index string-join string-trim-both
+  string-contains string-concatenate
+  #; ;FIXME isn't CI!
+  string-contains-ci
+  string-downcase))
+(import (only (check-errors basic)
+  define-check+error-type define-error-type
+  error-argument-type))
+(import (only symbol-name-utils
+  symbol->keyword symbol-printname=?
+  symbol-printname<? symbol-printname-length max-symbol-printname-length
+  module-printnames))
+(import symbol-environment-access)
+(import symbol-access)
+
+(define-type irregex (struct regexp))
+
+(define-type argument-name (or string symbol keyword))
+
+(define-type find-key (or false keyword))
+(define-type sort-key (or false keyword))
+(define-type search-pattern (or keyword symbol string pair irregex))
+
+(define-type module-name (or string symbol (list-of symbol) (list symbol integer)))
+
+(: apropos-excluded-modules (#!optional (list-of module-name) -> (list-of string)))
+(: apropos-default-base (#!optional integer -> integer))
+(: apropos-interning (#!optional * -> boolean))
+(: apropos-default-options (#!optional (or boolean list) -> list))
+
+(: check-apropos-number-base (symbol * #!optional argument-name -> integer))
+
+(: apropos-find-key? (* -> boolean : find-key))
+(: check-apropos-find-key (symbol * #!optional argument-name -> find-key))
+(: error-apropos-find-key (symbol * #!optional argument-name -> void))
+
+(: apropos-sort-key? (* -> boolean : sort-key))
+(: check-apropos-sort-key (symbol * #!optional argument-name -> sort-key))
+(: error-apropos-sort-key (symbol * #!optional argument-name -> void))
+
+(: apropos (search-pattern #!rest -> void))
+(: apropos-list (search-pattern #!rest -> (list-of symbol)))
+(: apropos-information-list (search-pattern #!rest -> (list-of list)))
+
+;;from srfi-13
+
+;FIXME actual one isn't CI!
+(define (string-contains-ci str patt)
+  ;this sucks
+  (string-contains (string-downcase str) (string-downcase patt)) )
+
+;;from list-utils
+
+#; ;FIXME macro symbol dups? same name, different module?
+(define (delete-duplicates!/sorted ols #!optional (eql? equal?))
+  ;(assert (sorted? ols eql?))
+  (let loop ((ls ols))
+    (let ((nxt (and (not (null? ls)) (cdr ls))))
+      (if (or (not nxt) (null? nxt))
+          ols
+          (if (eql? ls nxt)
+              (begin
+                (set-cdr! ls (cdr nxt))
+                (loop ls) )
+              (loop nxt) ) ) ) ) )
+
+;; irregex extensions
+
+(define (irregex-submatches? mt #!optional ire)
+  (and (irregex-match-data? mt)
+       (or (not ire)
+           (=  (irregex-match-num-submatches mt)
+               (if (fixnum? ire) ire (irregex-num-submatches ire))) ) ) )
+
+;; String
+
+(define (string-match? str patt) (irregex-search patt str))
+(define (string-exact-match? str patt) (string-contains str patt))
+(define (string-ci-match? str patt) (string-contains-ci str patt))
+
+;; memoized-string
+
+(define (index-key=? a b) (and (= (car a) (car b)) (char=? (cdr a) (cdr b))))
+
+(define make-string+
+  (let ((+strings+ (the list '())))
+    (lambda (len fill) ;optional in original
+      (let ((key `(,len . ,fill)))
+        (or (alist-ref key +strings+ index-key=?)
+            (let ((str (make-string len fill)))
+              (set! +strings+ (alist-update! key str +strings+ index-key=?))
+              str ) ) ) ) ) )
+
+;; Symbols
+
+#|
+(define (symbol-match? sym patt)        (string-match? (symbol->string sym) patt))
+(define (symbol-exact-match? sym patt)  (string-exact-match? (symbol->string sym) patt))
+(define (symbol-ci-match? sym patt)     (string-ci-match? (symbol->string sym) patt))
+|#
+
+;; Constants
+
+;NOTE invalid compile-time value for named constant `KRL-OPTIONS'
+(define KRL-OPTIONS '(#:sort #:module #:case-insensitive? #t #:macros? #t))
+
+(define-constant TAB-WIDTH 2)
+
+;for our purposes
+(define-constant CHICKEN-MAXIMUM-BASE 16)
+
+;; Types
+
+(define (search-pattern? obj)
+  (or (keyword? obj)
+      (symbol? obj)
+      (string? obj)
+      (irregex? obj)
+      (pair? obj)) )
+
+(define (apropos-find-key? obj)
+  (or (not obj)
+      (eq? #:name obj)
+      (eq? #:module obj)) )
+
+(define (apropos-sort-key? obj)
+  (or (not obj)
+      (eq? #:name obj)
+      (eq? #:module obj)
+      (eq? #:type obj)) )
+
+;; Errors
+
+(define (error-argument loc arg)
+  (error-argument-type loc arg
+    (if (keyword? arg) "recognized keyword argument" "recognized argument")) )
+
+;; Argument Checking
+
+(define-check+error-type search-pattern search-pattern?
+  "symbol/keyword/string/irregex/irregex-sre/quoted")
+
+(define-check+error-type apropos-find-key apropos-find-key? "#:name, #:module or #f")
+(define-check+error-type apropos-sort-key apropos-sort-key? "#:name, #:module, #:type or #f")
+
+#; ;UNSUPPORTED
+(define-check+error-type environment system-environment?)
+
+;;
+
+;FIXME prefix matching is not implied by the name!
+
+;NOTE all `##' are excluded. |##| is the ns-prefix.
+(define INTERNAL-MODULE-EXCLUDES '("##" "chicken.internal"))
+
+(define apropos-excluded-modules
+  (make-parameter '()
+    (lambda (obj)
+      (or (module-printnames obj)
+          (error-argument-type 'apropos-excluded-modules obj "list-of module-name")))))
+
+;; Number Base
+
+(define (number-base? obj)
+  (and (exact-integer? obj) (<= 2 obj CHICKEN-MAXIMUM-BASE)) )
+
+(define NUMBER-BASE-ERROR-MESSAGE
+  (string-append "fixnum in 2.." (number->string CHICKEN-MAXIMUM-BASE)))
+
+(define DEFAULT-BASE-ERROR-MESSAGE
+  (string-append "" NUMBER-BASE-ERROR-MESSAGE))
+
+(define apropos-default-base
+  (make-parameter 10
+    (lambda (x)
+      (if (number-base? x) x
+          (error-argument-type 'apropos-default-base x DEFAULT-BASE-ERROR-MESSAGE)))))
+
+(define (check-apropos-number-base loc obj #!optional (var 'base))
+  (unless (number-base? obj)
+    (error-argument-type loc obj NUMBER-BASE-ERROR-MESSAGE var) )
+  obj )
+
+(define (check-find-component loc obj #!optional (var 'find))
+  (case obj
+    ((#f)
+      obj)
+    ((#:module #:name)
+      obj)
+    (else
+      (error-argument-type loc obj "find option - nam, mod, #f" var)) ) )
+
+;;
+
+;
+(define (system-current-symbol? sym)
+  ;must check full identifier name, so cdr
+  (not (null? (search-list-environment-symbols  (cut eq? sym <>)
+                                                (system-current-environment)
+                                                cdr))) )
+
+;; Environment Search
+
+;;
+
+(define (*apropos-list/macro-environment loc match? macenv)
+  #; ;FIXME macro symbol dups? same name, different module?
+  (delete-duplicates!/sorted
+    (sort! (search-macro-environment-symbols match? macenv) symbol-printname<?)
+    (lambda (a b) (eq? (car a) (car b))))
+  (sort! (search-macro-environment-symbols match? macenv) symbol-printname<?) )
+
+(define (*apropos-list/environment loc match? env)
+  (search-system-environment-symbols match? env) )
+
+; => (envsyms . macenvsyms)
+(define (*apropos-list loc match/env? env match/macenv? macenv)
+  (let ((envls (*apropos-list/environment loc match/env? env)))
+    (if (not macenv) envls
+        (append! (*apropos-list/macro-environment loc match/macenv? macenv)
+                 envls)) ) )
+
+;; Argument List Parsing & Matcher Generation
+
+;FIXME separate concerns
+
+(define default-environment system-current-environment)
+(define default-macro-environment system-macro-environment)
+
+(define-constant ANY-SYMBOL '_)
+
+(: make-apropos-matcher (symbol * #!optional * (or false keyword) *  * -> (symbol -> boolean)))
+
+(define (make-apropos-matcher loc patt
+            #!optional
+            case-insensitive?
+            find-split
+            force-regexp?
+            internal?)
+  ;
+  (define (error-patt) (error-argument-type loc patt "apropos pattern form"))
+  ;
+  (define (matcher-for pred? data)
+    ;cache
+    (define topstr (symbol->string (toplevel-module-symbol)))
+    (define excld-mods (apropos-excluded-modules))
+    ;
+    ;match string form of nam or mod or ful
+    ;the match predicate `pred?' will search the entire string
+    (define (check-str? str) (pred? str data))    ;
+    ;
+    ;match string form of mod or ful
+    (define (excluded-mod? str)
+      (and (or internal? (not (*excluded-module-name? str INTERNAL-MODULE-EXCLUDES)))
+           (not (*excluded-module-name? str excld-mods))) )
+    (define (check-mod? str)
+      (and (excluded-mod? str) (check-str? str)) )
+    ;
+    (cond ((not find-split)
+            (lambda (sym)
+              #; ;entire string searched so will include whatever element, nam or
+              ;mod, that matches first so only do one call
+              (let-values (((mod nam) (*split-prefixed-symbol sym topstr)))
+                (or (check-mod? mod) (check-str? nam)) )
+              (check-mod? (symbol->string sym))) )
+          ((eq? #:module find-split)
+            (lambda (sym)
+              (let-values (((mod _) (*split-prefixed-symbol sym topstr)))
+                (check-mod? mod))) )
+          ((eq? #:name find-split)
+            (lambda (sym)
+              (let-values (((mod nam) (*split-prefixed-symbol sym topstr)))
+                (and (excluded-mod? mod)
+                     (check-str? nam)) ) ) )
+          (else
+            (error loc "unknown symbol find" find-split patt)) ) )
+  ;
+  (define (string-matcher str)
+    (let ((pred? (if case-insensitive? string-ci-match? string-exact-match?)))
+      (matcher-for pred? str) ) )
+  ;
+  (define (irregex-options-list)
+    (if case-insensitive? '(case-insensitive) '()) )
+  ;(or proper-list atom) -> regexp
+  (define (sre-n-str-matcher patt)
+    (apply irregex patt (irregex-options-list)) )
+  ;
+  (define (irregex-matcher irx)
+    (matcher-for string-match? irx) )
+  ;
+  (cond ((symbol? patt)
+          (make-apropos-matcher loc (symbol->string patt)
+            case-insensitive? find-split force-regexp? internal?) )
+        ;
+        ((string? patt)
+          (if force-regexp?
+              (irregex-matcher (sre-n-str-matcher patt))
+              (string-matcher patt)) )
+        ;
+        ((irregex? patt)
+          (irregex-matcher patt) )
+        ;
+        ((pair? patt)
+          (if (not (eq? 'quote (car patt)))
+              ;then an irregex acceptable form
+              (if (proper-list? patt)
+                  (irregex-matcher (sre-n-str-matcher patt))
+                  (error-patt))
+              ;else some form of pattern
+              (let ((quoted (cadr patt)))
+                (define (name-matcher)
+                  (make-apropos-matcher loc (cdr quoted)
+                    case-insensitive? #:name force-regexp? internal?) )
+                (define (module-matcher)
+                  (make-apropos-matcher loc (car quoted)
+                    case-insensitive? #:module force-regexp? internal?) )
+                ;'(___ . <atom>)
+                (if (pair? quoted)
+                    ;then could be a find (name|module) pattern
+                          ;elaborate match any
+                    (cond ((and (eq? ANY-SYMBOL (car quoted)) (eq? ANY-SYMBOL (cdr quoted)))
+                            (make-apropos-matcher loc '(: (* any))
+                              #f #f #t internal?) )
+                          ;name find?
+                          ((eq? ANY-SYMBOL (car quoted))
+                            (name-matcher) )
+                          ;module find?
+                          ((eq? ANY-SYMBOL (cdr quoted))
+                            (module-matcher) )
+                          ;both name & module
+                          (else
+                            (let ((mod-match? (module-matcher))
+                                  (nam-match? (name-matcher)) )
+                              (lambda (sym)
+                                (and (mod-match? sym) (nam-match? sym)) ) ) ) )
+                    ;else interpretation of stripped
+                    (make-apropos-matcher loc quoted
+                      case-insensitive? find-split #t internal?) ) ) ) )
+        ;
+        (else
+          (error-patt) ) ) )
+
+;;
+
+; => (values val args)
+(define (keyword-argument args kwd #!optional val)
+  (let loop ((args args) (oargs '()) (val val))
+    (if (null? args)
+        (values val (reverse! oargs))
+        (let ((arg (car args)))
+          (cond ((eq? kwd arg)
+                  (loop (cddr args) oargs (cadr args)) )
+                (else
+                  (loop (cdr args) (cons arg oargs) val) ) ) ) ) ) )
+
+; => (values sort-key args)
+(define (parse-sort-key-argument loc args)
+  (receive (sort-key args) (keyword-argument args #:sort #:type)
+    (values (check-apropos-sort-key loc sort-key #:sort) args) ) )
+
+;;
+
+;=> (values env macenv base raw? find internal?)
+;
+(define (parse-rest-arguments loc iargs)
+  (let ((env #f)        ;(default-environment) ;just the macros but looks ok in repl?
+        (macenv #f)
+        (internal? #f)
+        (raw? #f)
+        (case-insensitive? #f)
+        (find-split #f)
+        (base (apropos-default-base))
+        (imported? #f)
+        (1st-arg? #t) )
+    (let loop ((args iargs))
+      (if (null? args)
+          ;seen 'em all
+          (values env macenv case-insensitive? base raw? find-split internal? imported?)
+          ;process potential arg
+          (let ((arg (car args)))
+            ;keyword argument?
+            (case arg
+              ((#:imported?)
+                (set! imported? (cadr args))
+                (loop (cddr args)) )
+              ;
+              ((#:find #:split)
+                (set! find-split (check-find-component loc (cadr args)))
+                (loop (cddr args)) )
+              ;
+              ((#:internal?)
+                (set! internal? (cadr args))
+                (loop (cddr args)) )
+              ;
+              ((#:raw?)
+                (set! raw? (cadr args))
+                (loop (cddr args)) )
+              ;
+              ((#:base)
+                (when (cadr args) (set! base (check-apropos-number-base loc (cadr args))))
+                (loop (cddr args)) )
+              ;
+              ((#:macros?)
+                ;only flag supported
+                (when (cadr args) (set! macenv (default-macro-environment)))
+                (loop (cddr args)) )
+              ;
+              ((#:case-insensitive?)
+                (set! case-insensitive? (cadr args))
+                (loop (cddr args)) )
+              ;environment argument?
+              ;FIXME need real 'environment?' predicate
+              (else
+                (if (not (and 1st-arg? (list? arg)))
+                    (error-argument loc arg)
+                    (begin
+                      (set! 1st-arg? #f)
+                      (set! env arg)
+                      (loop (cdr args)) ) ) ) ) ) ) ) ) )
+
+(define (fixup-pattern-argument patt #!optional (base (apropos-default-base)))
+      (cond ((boolean? patt)
+              (if patt "#t" "#f"))
+            ((char? patt)
+              (string patt))
+            ((number? patt)
+              (number->string patt base))
+            ;? pair vector ... ->string , struct use tag as patt ?
+            (else
+              patt) ) )
+
+;;
+
+;#!optional (env (default-environment)) macenv #!key macros? internal? base (find #:all)
+;
+;macenv is #t for default macro environment or a macro-environment object.
+;
+;=> (values apropos-ls macenv)
+
+;
+(define (parse-arguments-and-match loc patt iargs)
+  (let-values (((env macenv case-insensitive? base raw? find-split internal? imported?)
+                  (parse-rest-arguments loc iargs) ) )
+    (when (and internal? imported?) (error loc "cannot be both internal & imported"))
+    (let ((include? (if imported? system-current-symbol? global-symbol-bound?)))
+      (let* ((force-regexp? #f)
+             (patt
+              (check-search-pattern loc (fixup-pattern-argument patt base) 'pattern) )
+             (match?
+              (make-apropos-matcher loc patt case-insensitive? find-split force-regexp? internal?) )
+             (als
+              (*apropos-list loc (lambda (sym) (and (include? sym) (match? sym)))
+                                 env match? macenv) ) )
+        (values als macenv raw? case-insensitive?) ) ) ) )
+
+;;
+
+#| ;UNSUPPORTED ;FIXME case-insensitive support
+;;
+
+(define (macro-environment obj)
+  (and (sys::macro-environment? obj)
+       obj) )
+
+;;
+
+; => (values envsyms macenv)
+
+(define (parse-arguments/environment loc patt env)
+  (check-search-pattern loc patt 'pattern)
+  (let ((macenv (macro-environment (check-environment loc env 'environment))))
+    (values (*apropos-list/environment loc (make-apropos-matcher loc patt) env macenv)
+            macenv) ) )
+
+;;
+
+; #!key internal?
+;
+; => (... (macenv . syms) ...)
+
+(define (parse-arguments/environments loc patt args)
+  ;
+  (define (parse-rest-arguments)
+    (let ((internal? #f))
+      (let loop ((args args) (envs '()))
+        (if (null? args)
+            (values (reverse! envs) internal?)
+            (let ((arg (car args)))
+              ;keyword argument?
+              (cond ((eq? #:internal? arg)
+                      (when (cadr args) (set! internal? #t))
+                      (loop (cddr args) envs) )
+                    ;environment argument?
+                    (else
+                      (unless (##sys#environment? arg)
+                        (error-argument loc arg) )
+                      (loop (cdr args) (cons arg envs)) ) ) ) ) ) ) )
+  ;
+  (let ((patt (fixup-pattern-argument patt)))
+    (check-search-pattern loc patt 'pattern)
+    (receive (envs internal?) (parse-rest-arguments)
+      (let ((regexp (make-apropos-matcher loc patt)))
+        (let loop ((envs envs) (envsyms '()))
+          (if (null? envs)
+              (reverse! envsyms)
+              (let* ((env (car envs))
+                     (macenv (macro-environment (check-environment loc env 'environment)))
+                     (make-envsyms
+                       (lambda ()
+                         (cons macenv
+                               (*apropos-list/environment loc regexp env macenv)) ) ) )
+                (loop (cdr envs) (cons (make-envsyms) envsyms)) ) ) ) ) ) ) )
+|#
+
+;; Display
+
+(define apropos-interning (make-parameter #t (lambda (x) (and x #t))))
+
+(define (string->display-symbol str)
+  (let ((str2sym (if (apropos-interning) string->symbol string->uninterned-symbol)))
+    (str2sym str) ) )
+
+;;
+
+#| ;A Work In Progress
+
+; UNDECIDEDABLE - given the data available from `procedure-information',
+; serial nature of `gensym', and serial nature of argument coloring by
+; compiler.
+
+; `pointer+' is an example of a `foreign-lambda*', here all info is lost & the
+; gensym identifiers can just be colored using a base of 1.
+
+;best guess:
+;
+;here `(cs1806 cs2807 . csets808)'        `(cs1 cs2 . csets)'
+;here `(foo a1 b2)'                       `(foo a1 b2)'
+;here `(a380384 a379385)'                 `(arg1 arg2)'
+;here `(=1133 lis11134 . lists1135)'      `(= lis1 . lists)'
+
+(import (only (srfi 1) last-pair))
+
+(define apropos-gensym-suffix-limit 1)
+
+;When > limit need to keep leading digit
+
+(define (scrub-gensym-taste sym #!optional (limit apropos-gensym-suffix-limit))
+  (let* ((str (symbol->string sym))
+         (idx (string-skip-right str char-set:digit))
+         (idx (and idx (fx+ idx 1))) )
+    ;
+    (cond ((not idx)
+            sym )
+          ((< (fx- (string-length str) idx) limit)
+            sym )
+          (else
+            (string->display-symbol (substring str 0 idx)) ) ) ) )
+
+; arg-lst-template is-a pair!
+(define (scrub-gensym-effect arg-lst-template)
+  (let ((heads (butlast arg-lst-template))
+        (tailing (last-pair arg-lst-template)) )
+    ;
+    (append! (map scrub-gensym-taste heads)
+             (if (null? (cdr tailing))
+                 (list (scrub-gensym-taste (car tailing)))
+                 (cons (scrub-gensym-taste (car tailing))
+                       (scrub-gensym-taste (cdr tailing)))) ) ) )
+|#
+
+(define (identifier-components sym raw?)
+  (if raw? (cons (toplevel-module-symbol) sym)
+      (let-values (((mod nam) (split-prefixed-symbol sym)))
+        (cons (string->display-symbol mod) (string->display-symbol nam)) ) ) )
+
+;FIXME make patt a param ?
+(define GENSYM_SRE (sre->irregex '(: bos (>= 2 any) (>= 2 num) eos) 'utf8 'fast))
+(define GENSYM_DEL_SRE (sre->irregex '(: (* num) eos) 'utf8 'fast))
+
+(define (canonical-identifier-name id raw?)
+  (if raw? id
+      (let* ((pname (symbol->string id))
+             (mt (irregex-match GENSYM_SRE pname)) )
+        (if (irregex-submatches? mt GENSYM_SRE)
+            (string->display-symbol (irregex-replace GENSYM_DEL_SRE pname ""))
+            id ) ) ) )
+
+(define (canonicalize-identifier-names form raw?)
+  (cond (raw?
+          form )
+        ((symbol? form)
+          (canonical-identifier-name form raw?) )
+        ((pair? form)
+          (cons
+            (canonicalize-identifier-names (car form) raw?)
+            (canonicalize-identifier-names (cdr form) raw?)) )
+        (else
+          form ) ) )
+
+; => 'procedure | (procedure . <symbol>) | (procedure . <list>) | (procedure . <string>)
+;
+(define (procedure-details proc raw?)
+  (let ((info (procedure-information proc)))
+    (cond ((not info)
+            'procedure )
+          ((pair? info)
+            `(procedure . ,(canonicalize-identifier-names (cdr info) raw?)) )
+          (else
+            ;was ,(symbol->string info) (? why)
+            `(procedure . ,(canonical-identifier-name info raw?)) ) ) ) )
+
+; <symbol>|<keyword> => <identifier>
+; <identifier> => 'macro | 'keyword | 'variable | <procedure-details>
+;
+(define (identifier-type-details sym #!optional macenv raw?)
+  (cond ((keyword? sym)
+          'keyword )
+        ((and macenv (macro-symbol-in-environment? sym macenv))
+          'macro )
+        (else
+          (let ((val (global-symbol-ref sym)))
+            (if (procedure? val)
+                (procedure-details val raw?)
+                'variable ) ) ) ) )
+
+;;
+
+(define (make-information sym macenv raw?)
+  (cons (identifier-components sym raw?)
+        (identifier-type-details sym macenv raw?)) )
+
+(define (*make-information-list syms macenv raw?)
+  (map (cut make-information <> macenv raw?) syms) )
+
+(define (identifier-information-module ident-info)
+  (car ident-info) )
+
+(define (identifier-information-name ident-info)
+  (cdr ident-info) )
+
+(define (detail-information-kind dets-info)
+  (car dets-info) )
+
+(define (detail-information-arguments dets-info)
+  (cdr dets-info) )
+
+(define (information-identifiers info)
+  (car info) )
+
+(define (information-module info)
+  (identifier-information-module (information-identifiers info)) )
+
+(define (information-name info)
+  (identifier-information-name (information-identifiers info)) )
+
+(define (information-details info)
+  (cdr info) )
+
+;FIXME case-insensitive sort but 1) not documented 2) R7RS is case-sensitive
+
+(define (information-identifier<? info1 info2 #!optional (sort-key #:name))
+  (receive  (field-1-ref field-2-ref)
+            (if (eq? #:name sort-key)
+                (values information-name information-module)
+                (values information-module information-name) )
+    (let ((sym-1-1 (field-1-ref info1) )
+          (sym-1-2 (field-1-ref info2) ) )
+      (if (not (symbol-printname=? sym-1-1 sym-1-2))
+          (symbol-printname<? sym-1-1 sym-1-2)
+          (symbol-printname<? (field-2-ref info1) (field-2-ref info2)) ) ) ) )
+
+(define (information-kind info)
+  (let ((d (information-details info)))
+    (if (symbol? d) d (car d)) ) )
+
+(define (information-kind=? info1 info2)
+  (symbol-printname=? (information-kind info1) (information-kind info2)) )
+
+(define (information-kind<? info1 info2)
+  (symbol-printname<? (information-kind info1) (information-kind info2)) )
+
+(define (information<? info1 info2 #!optional (sort-key #:name))
+  (if (information-kind=? info1 info2)
+      (information-identifier<? info1 info2 sort-key)
+      (information-kind<? info1 info2) ) )
+
+;;
+
+(define (make-sorted-information-list syms macenv sort-key raw?)
+  (let ((lessp
+          (case sort-key
+            ((#:name #:module)  (cut information-identifier<? <> <> sort-key))
+            ((#:type)           information<?)
+            (else               #f )) )
+        (ails
+          (*make-information-list syms macenv raw?) ) )
+    ;
+    (if lessp
+        (sort! ails lessp)
+        ails ) ) )
+
+(define (symbol-pad-length sym maxsymlen #!optional (bias 0))
+  (let* ((len (symbol-printname-length sym))
+         (maxlen (min maxsymlen len)) )
+    (fx+ bias (fx- maxsymlen maxlen)) ) )
+
+#; ;
+(define (display/cols vals wids #!key (tab-width TAB-WIDTH))
+  )
+
+;FIXME need to know if ANY mods, then no mod pad needed (has +2)
+(define (display-apropos isyms macenv sort-key raw?)
+  ;
+  (let* ((ails (make-sorted-information-list isyms macenv sort-key raw?))
+         (mods (map information-module ails))
+         (syms (map information-name ails))
+         (maxmodlen (max-symbol-printname-length mods))
+         (maxsymlen (max-symbol-printname-length syms)) )
+    ;
+    (define (display-symbol-information info)
+      ;<sym><tab>
+      (let* ((dets (information-details info))
+             (kwd? (eq? 'keyword dets))
+             (sym (information-name info) )
+             (sym-padlen (symbol-pad-length sym maxsymlen)) )  ;(if kwd? -1 0)
+        (display (if kwd? (symbol->keyword sym) sym))
+        (display (make-string+ (fx+ TAB-WIDTH sym-padlen) #\space)) )
+      ;<mod><tab>
+      (let* ((mod (information-module info))
+             (mod-padlen (symbol-pad-length mod maxmodlen))
+             (mod-padstr (make-string+ (fx+ TAB-WIDTH mod-padlen) #\space)) )
+        (if (eq? (toplevel-module-symbol) mod)
+            (display mod-padstr)
+            (begin
+              (display mod)
+              (display mod-padstr) ) ) )
+      ;<details>
+      (let ((dets (information-details info)))
+        (cond ((symbol? dets)
+                (display dets) )
+              (else
+                (display (detail-information-kind dets))
+                (display #\space)
+                (write (detail-information-arguments dets)) ) ) )
+      ;d'oy
+      (newline) )
+    ;
+    (for-each display-symbol-information ails) ) )
+
+;; API
+
+(define apropos-default-options
+  (make-parameter '()
+    (lambda (x)
+      ;FIXME actually check for proper options
+      (cond ((boolean? x)
+              (if x KRL-OPTIONS '()) )
+            ((list? x)
+              x )
+            (else
+              (error-argument-type 'apropos-default-options x "list-of options"))))))
+
+;; Original
+
+(define (apropos patt . args)
+  (let ((args (if (null? args) (apropos-default-options) args)))
+    (let*-values (((sort-key args)
+                    (parse-sort-key-argument 'apropos args) )
+                  ((syms macenv raw? case-insensitive?)
+                    (parse-arguments-and-match 'apropos patt args) ) )
+      (display-apropos syms macenv sort-key raw?) ) ) )
+
+(define (apropos-list patt . args)
+  (let ((args (if (null? args) (apropos-default-options) args)))
+    (let*-values (((sort-key args)
+                    (parse-sort-key-argument 'apropos-list args) )
+                  ((syms macenv raw? case-insensitive?)
+                    (parse-arguments-and-match 'apropos-list patt args) ) )
+      syms ) ) )
+
+(define (apropos-information-list patt . args)
+  (let ((args (if (null? args) (apropos-default-options) args)))
+    (let*-values (((sort-key args)
+                    (parse-sort-key-argument 'apropos-information-list args) )
+                  ((syms macenv raw? case-insensitive?)
+                    (parse-arguments-and-match 'apropos-information-list patt args) ) )
+      (make-sorted-information-list syms macenv sort-key raw?) ) ) )
+
+) ;module apropos-api
+
+#| ;UNSUPPORTED ;FIXME case-insensitive support
+(export
+  ;Crispy
+  apropos/environment apropos-list/environment apropos-information-list/environment
+  ;Extra Crispy
+  apropos/environments apropos-list/environments apropos-information-list/environments)
+
+;; Crispy
+
+==== apropos/environment
+
+<procedure>(apropos/environment PATTERN ENVIRONMENT (#:internal? INTERNAL?) (#:sort SORT))</procedure>
+
+Displays information about identifiers matching {{PATTERN}} in the
+{{ENVIRONMENT}}.
+
+Like {{apropos}}.
+
+; {{ENVIRONMENT}} : An {{environment}} or a {{macro-environment}}.
+
+==== apropos-list/environment
+
+<procedure>(apropos-list/environment PATTERN ENVIRONMENT (#:internal? INTERNAL?))</procedure>
+
+Like {{apropos-list}}.
+
+==== apropos-information-list/environment
+
+<procedure>(apropos-information-list/environment PATTERN ENVIRONMENT (#:internal? INTERNAL?))</procedure>
+
+Like {{apropos-information-list}}.
+
+(define (apropos/environment patt env #!key internal? (sort #:name))
+  (check-sort-key 'apropos/environment sort #:sort)
+  (receive
+    (syms macenv)
+      (parse-arguments/environment 'apropos/environment patt env internal?)
+    ;
+    (newline)
+    (display-apropos syms macenv sort-key) ) )
+
+(define (apropos-list/environment patt env #!key internal?)
+  (receive
+    (syms macenv)
+      (parse-arguments/environment 'apropos/environment patt env internal?)
+    ;
+    syms ) )
+
+(define (apropos-information-list/environment patt env #!key internal?)
+  (receive
+    (syms macenv)
+      (parse-arguments/environment 'apropos/environment patt env internal?)
+    ;
+    (*make-information-list syms macenv) ) )
+
+;; Extra Crispy
+
+==== apropos/environments
+
+<procedure>(apropos/environments PATTERN (#:internal? INTERNAL?) (#:sort SORT) ENVIRONMENT...)</procedure>
+
+Displays information about identifiers matching {{PATTERN}} in each
+{{ENVIRONMENT}}.
+
+Like {{apropos}}.
+
+; {{PATTERN}} : A {{symbol}}, {{string}} or {{regexp}}. When symbol or string substring matching is performed.
+
+==== apropos-list/environments
+
+<procedure>(apropos-list/environments PATTERN (#:internal? INTERNAL?) ENVIRONMENT...)</procedure>
+
+Like {{apropos-list}}.
+
+==== apropos-information-list/environments
+
+<procedure>(apropos-information-list/environments PATTERN (#:internal? INTERNAL?) ENVIRONMENT...)</procedure>
+
+Like {{apropos-information-list}}.
+
+(define (apropos/environments patt . args)
+  (let-values (((sort-key args) (parse-sort-key-argument 'apropos/environments args)))
+    (let ((i 0))
+      (for-each
+        (lambda (macenv+syms)
+          (set! i (fx+ i 1))
+          (newline) (display "** Environment " i " **") (newline) (newline)
+          (display-apropos (cdr macenv+syms) (car macenv+syms) sort-key) )
+        (parse-arguments/environments 'apropos/environments patt args)) ) ) )
+
+(define (apropos-list/environments patt . args)
+  (map cdr (parse-arguments/environments 'apropos-list/environments patt args)) )
+
+(define (apropos-information-list/environments patt . args)
+  (map
+    (lambda (macenv+syms) (*make-information-list (cdr macenv+syms) (car macenv+syms)))
+    (parse-arguments/environments 'apropos-information-list/environments patt args)) )
+|#

apropos-csi.scm

@@ -0,0 +1,196 @@
+;;;; apropos-csi.scm  -*- Scheme -*-
+;;;; Kon Lovett, Jul '18
+;;;; Kon Lovett, Oct '17
+;;;; Kon Lovett, Mar '09
+;;;; From the Chicken 4 core, Version 4.0.0x5 - SVN rev. 13662
+
+;; Issues
+;;
+;; - old csi option
+;; ; {{search|mode pre[fix]|suff[ix]|#t}} : {{#:search-mode (or #:prefix #:suffix #t)}}
+;; ; {{SEARCH-MODE}} : {{(or #:prefix #:suffix #t)}} for contains. The default is {{#t}}.
+
+(module apropos-csi ()
+
+(import scheme)
+(import (chicken base))
+(import (chicken fixnum))
+(import (chicken platform))
+(import (chicken io))
+(import (chicken port))
+(import apropos-api)
+
+
+;;(srfi 1)
+
+(import (only (srfi 1) cons*))
+#; ;UNUSED until no (srfi 1)
+(define (cons* first . rest)
+  (let recur ((x first) (rest rest))
+    (if (pair? rest)
+        (cons x (recur (car rest) (cdr rest)))
+        x) ) )
+
+;; Constants
+
+;Some options only in full help. ex: "raw", "base [#]", "internal"
+;Pad out to CSI-HELP-HEAD-WIDTH 18, No tabs
+(define CSI-HELP #<<EOS
+,a PATT OPT...    Apropos of PATT with OPT from help, mac, ci, imp, sort nam|mod|typ|#f, find nam|mod|#f
+EOS
+)
+
+(define HELP-TEXT #<<EOS
+Pattern:
+
+ The pattern PATT is a symbol, string, sre (see irregex), or quoted.
+ Symbols & strings are interpreted as a substring match.
+
+ The quoted PATT (no sort order is implied):
+
+  '(PATT . PATT)  performs as if `PATT+PATT find module+name` worked.
+  '(PATT . _)     synonym for `PATT find module`.
+  '(_ . PATT)     synonym for `PATT find name`.
+  '(_ . _)        synonym for '.* | '".*" | (: (* any)) ;match any.
+
+  '<atom>         interpret `<atom>` as an irregex.
+
+  Best to present REGEX-style patterns as a string.
+  Ex: '"^[a-zA-Z]$" vs. '^\[a-zA-Z\]$
+
+Arguments:
+
+ help              This message
+ mac | macros      Include macro bound symbols
+ ci | case-insensitive
+                   Pattern has no capitals
+ imp | imported    Only imported identifiers, otherwise global symbols
+ sort name | module | type | #f
+                   Order items; optional when last argument
+ find name | module | #f
+                   Pattern match component; optional when last argument
+                   (also see the '(_ . _) pattern)
+ all               Means `ci mac`
+ krl               Means `all sort mod`
+ base              For number valued pattern
+ raw               No listing symbol interpretation (i.e. x123 ~> x)
+ internal          Include internal modules
+EOS
+)
+
+;;
+;; REPL Integeration
+;;
+
+(define (interp-find-arg loc arg)
+  (case arg
+    ((n nam name)   #:name)
+    ((m mod module) #:module)
+    (else
+      (and arg
+           (error-apropos-find-key loc "unknown find key" arg)) ) ) )
+
+(define (interp-sort-arg loc arg)
+  (case arg
+    ((n nam name)   #:name)
+    ((m mod module) #:module)
+    ((t typ type)   #:type)
+    (else
+      (and arg
+           (error-apropos-sort-key loc "unknown sort key" arg)) ) ) )
+
+(define (display-apropos-help)
+  (print CSI-HELP)
+  (print)
+  (print HELP-TEXT) )
+
+(define (parse-csi-apropos-arguments iargs)
+  (let* ((patt (and (not (null? iargs)) (car iargs)))
+         (args (if patt (cdr iargs) '())) )
+    (let loop ((args args) (oargs `(,patt)))
+      ;
+      (define (restargs next optarg?)
+        (cond ((null? next)
+                '())
+              (optarg?
+                (cdr next))
+              (else
+                next) ) )
+      ;
+      (define (arg-next kwd init #!optional optarg?)
+        (define (thisargs next kwd init optarg?)
+          (cond ((null? next)
+                  (cons* init kwd oargs))
+                (optarg?
+                  (cons* (optarg? (car next)) kwd oargs))
+                (else
+                  (cons* init kwd oargs)) ) )
+        (let* ((next (cdr args))
+               (args (restargs next optarg?))
+               (oargs (thisargs next kwd init optarg?)) )
+          (loop args oargs) ) )
+      ;
+      (if (null? args)
+          ;original ordering
+          (reverse oargs)
+          ;csi-apropos-syntax => keyword-apropos-syntax
+          (let ((arg (car args)))
+            (case arg
+              ;
+              ((krl)
+                (loop (restargs (cons* 'all (cdr args)) #f)
+                      (cons* #:module #:sort oargs)) )
+              ;
+              ((all)
+                (loop (restargs (cdr args) #f)
+                      (cons* #t #:case-insensitive? #t #:macros? oargs)) )
+              ;
+              ((imp imported)
+                (arg-next #:imported? #t) )
+              ;
+              ((mac macros)
+                (arg-next #:macros? #t) )
+              ;
+              ((ci case-insensitive)
+                (arg-next #:case-insensitive? #t) )
+              ;
+              ((internal)
+                (arg-next #:internal? #t) )
+              ;
+              ((raw)
+                (arg-next #:raw? #t) )
+              ;
+              ((base)
+                (arg-next #:base (apropos-default-base) (cute check-apropos-number-base '|,a| <>)) )
+              ;
+              ((sort)
+                (arg-next #:sort #:type (cute interp-sort-arg '|,a| <>)) )
+              ;
+              ((find split)
+                (arg-next #:find #f (cute interp-find-arg '|,a| <>)) )
+              ;
+              ((help)
+                (loop '() '()) )
+              ;
+              (else
+                (loop (cdr args) (cons arg oargs)) ) ) ) ) ) ) )
+
+(define (csi-apropos-command)
+  (let* ((cmdlin (read-line))
+         (csi-args (with-input-from-string cmdlin read-list))
+         (apropos-args (parse-csi-apropos-arguments csi-args)) )
+    ;NOTE will not dump the symbol-table unless explicit
+    ;use '(: (* any)) | '(_ . _)
+    (if (null? apropos-args)
+        (display-apropos-help)
+        (apply apropos apropos-args) ) ) )
+
+;; Main
+
+(when (feature? #:csi)
+  ;; Load csi library at runtime here in Chicken 6 only after we confirm
+  ;; csi is running. Otherwise chicken.csi load fails.
+  (import (only (chicken csi) toplevel-command))
+  (toplevel-command 'a csi-apropos-command CSI-HELP) )
+
+) ;module apropos-csi

apropos.egg

@@ -0,0 +1,35 @@
+;;;; apropos.egg  -*- Scheme -*-
+;;;; Kon Lovett, Jul '18
+
+((synopsis "CHICKEN apropos")
+ (version "3.11.2")
+ (category misc)
+ (author "Kon Lovett")
+ (license "BSD")
+ (dependencies srfi-1 srfi-13 (symbol-utils "2.6.1") (check-errors "3.8.3"))
+ (test-dependencies test test-utils)
+ (components
+  #; ;included
+  (extension symbol-table-access
+    (types-file)
+    (csc-options "-O3" "-d0" "-strict-types" "-no-procedure-checks" "-no-bound-checks") )
+  #; ;included
+  (extension symbol-access
+    (types-file)
+    (csc-options "-O3" "-d0" "-strict-types" "-no-procedure-checks" "-no-bound-checks") )
+  #; ;included
+  (extension symbol-environment-access
+    (types-file)
+    #; ;included
+    (component-dependencies symbol-table-access)
+    (csc-options "-O3" "-d0" "-strict-types" "-no-procedure-checks" "-no-bound-checks") )
+  (extension apropos-api
+    (types-file)
+    #; ;included
+    (component-dependencies symbol-access symbol-environment-access)
+    (csc-options "-O3" "-d1" "-strict-types" "-no-procedure-checks" "-no-bound-checks") )
+  (extension apropos-csi
+    (component-dependencies apropos-api)
+    (csc-options "-O3" "-d1" "-strict-types" "-no-procedure-checks" "-no-bound-checks") )
+  (extension apropos
+    (component-dependencies apropos-csi apropos-api) ) ) )

apropos.release-info

@@ -0,0 +1,4 @@
+;; -*- Scheme -*-
+(repo git "https://gitea.lyrion.ch/Chicken/apropos")
+(uri targz "https://gitea.lyrion.ch/Chicken/apropos/archive/{egg-release}.tar.gz")
+(release "3.11.2") ;; Port to Chicken 6

apropos.scm

@@ -0,0 +1,34 @@
+;;;; apropos.scm	-*- Scheme -*-
+;;;; Kon Lovett, Jul '18
+;;;; Kon Lovett, Oct '17
+;;;; Kon Lovett, Mar '09
+;;;; From the Chicken 4 core, Version 4.0.0x5 - SVN rev. 13662
+
+;; Issues
+;;
+;; - Use of 'global-symbol' routines is just wrong when an
+;; evaluation-environment (##sys#environment?) is not the
+;; interaction-environment.
+;;
+;; - Doesn't show something similar to procedure-information for macros. And
+;; how could it.
+;;
+;; - Could be re-written to use the "environments" extension. Which in turn would
+;; need to support syntactic environments, at least for lookup opertations.
+;;
+;; - The Chicken 'environment' object does not hold the (syntactic) bindings
+;; for any syntactic keywords from the R5RS. The public API of 'apropos'
+;; attempts to hide this fact.
+;;
+;; - old csi option
+;; ; {{search|mode pre[fix]|suff[ix]|#t}} : {{#:search-mode #:prefix|#:suffix|#t}}
+;; ; {{SEARCH-MODE}} : Either {{#:prefix}}, {{#:suffix}}, or {{#t}} for contains. The default is {{#t}}.
+
+(module apropos ()
+
+(import scheme (chicken module))
+
+(import apropos-api apropos-csi)
+(reexport apropos-api apropos-csi)
+
+) ;module apropos

nix/chicken.nix

@@ -0,0 +1,126 @@
+{
+  pkgs,
+  lib,
+  stdenv,
+  fetchgit,
+  fetchurl,
+  makeWrapper,
+  darwin,
+  tcc-mob,
+  version ? "git",
+  testers
+}:
+let
+  platform = with stdenv;
+    if isDarwin then "macosx"
+    else if isCygwin then "cygwin"
+    else if (isFreeBSD || isOpenBSD) then "bsd"
+    else if isSunOS then "solaris"
+    else "linux"; # Should be a sane default
+in
+stdenv.mkDerivation (finalAttrs: {
+  pname = "chicken";
+  inherit version;
+
+  binaryVersion = 12;
+  
+  srcs = [
+    (fetchgit {
+      url = "git://code.call-cc.org/chicken-core";
+      rev = "dbffda19e57c3be092e5a9174f1829632f5fa5a7";
+      sha256 = "sha256-zWjf9JS4H1buBlkmUhIv+odCQzXaOPtI7VfIaQUhe6Q=";
+    })
+    (fetchurl {
+      url = "https://code.call-cc.org/dev-snapshots/2024/07/01/chicken-6.0.0-bootstrap.tar.gz";
+      sha256 = "sha256-qkcyWzsaN9+HbMBolmv7zeaPrtbaCTGa9HoF2g/3//o=";
+    })
+  ];
+
+  unpackPhase = ''
+    cp -r `echo $srcs | awk '{print $1}'`/* .
+    cp -r `echo $srcs | awk '{print $1}'`/.* .
+    chmod -R 777 .
+    mkdir -p boot/snapshot
+    cd boot
+    tar xzf `echo $srcs | awk '{print $2}'`
+    cd ..
+    echo ${version} > buildid
+
+    cd boot/chicken-6.0.0
+    case "${platform}" in
+        bsd)
+            mkcmd=gmake;;
+        *)
+            mkcmd=make;;
+    esac
+    export CC="${tcc-mob}/bin/tcc"
+    $mkcmd C_COMPILER=$CC PREFIX="$(pwd)"/../snapshot
+    $mkcmd C_COMPILER=$CC PREFIX="$(pwd)"/../snapshot install
+    cd ../..
+    ./configure --chicken "$(pwd)"/boot/snapshot/bin/chicken --c-compiler "${tcc-mob}/bin/tcc"
+    $mkcmd boot-chicken
+  '';
+
+ # Disable two broken tests: "static link" and "linking tests"
+  postPatch = ''
+    sed -i tests/runtests.sh -e "/static link/,+4 { s/^/# / }"
+    sed -i tests/runtests.sh -e "/linking tests/,+11 { s/^/# / }"
+  '';
+
+  # -fno-strict-overflow is not a supported argument in clang
+  hardeningDisable = lib.optionals stdenv.cc.isClang [ "strictoverflow" ];
+
+ makeFlags = [
+    "PLATFORM=${platform}"
+    "PREFIX=$(out)"
+    "C_COMPILER=${tcc-mob}/bin/tcc"
+    "CXX_COMPILER=$(CXX)"
+  ] ++ (lib.optionals stdenv.isDarwin [
+    "XCODE_TOOL_PATH=${darwin.binutils.bintools}/bin"
+    "LINKER_OPTIONS=-headerpad_max_install_names"
+    "POSTINSTALL_PROGRAM=install_name_tool"
+  ]) ++ (lib.optionals (stdenv.hostPlatform != stdenv.buildPlatform) [
+    "HOSTSYSTEM=${stdenv.hostPlatform.config}"
+    "TARGET_C_COMPILER=${tcc-mob}/bin/${stdenv.cc.targetPrefix}tcc"
+    "TARGET_CXX_COMPILER=${stdenv.cc}/bin/${stdenv.cc.targetPrefix}c++"
+  ]);
+
+  nativeBuildInputs = [
+    makeWrapper
+    pkgs.hostname
+    tcc-mob
+  ] ++ lib.optionals (stdenv.isDarwin && stdenv.isAarch64) [
+    darwin.autoSignDarwinBinariesHook
+  ];
+
+  configurePhase = ''
+    ./configure --chicken ./chicken-boot --prefix $PREFIX  --platform=$PLATFORM --c-compiler "${tcc-mob}/bin/tcc"
+  '';
+  
+  doCheck = !stdenv.isDarwin;
+  postCheck = ''
+    ./csi -R chicken.pathname -R chicken.platform \
+       -p "(assert (equal? \"${toString finalAttrs.binaryVersion}\" (pathname-file (car (repository-path)))))"
+  '';
+
+  passthru.tests.version = testers.testVersion {
+    package = finalAttrs.finalPackage;
+    command = "csi -version";
+  };
+
+  meta = {
+    homepage = "https://call-cc.org/";
+    license = lib.licenses.bsd3;
+    maintainers = with lib.maintainers; [ corngood nagy konst-aa ];
+    platforms = lib.platforms.unix;
+    description = "Portable compiler for the Scheme programming language";
+    longDescription = ''
+      CHICKEN is a compiler for the Scheme programming language.
+      CHICKEN produces portable and efficient C, supports almost all
+      of the R5RS Scheme language standard, and includes many
+      enhancements and extensions. CHICKEN runs on Linux, macOS,
+      Windows, and many Unix flavours.
+    '';
+  }; 
+  
+})

nix/tinycc.nix

@@ -0,0 +1,129 @@
+{ lib
+, copyPkgconfigItems
+, fetchFromRepoOrCz
+, makePkgconfigItem
+, perl
+, stdenv
+, texinfo
+, which
+}:
+
+stdenv.mkDerivation (finalAttrs: {
+  pname = "tcc-mob";
+  version = "0.9.29-unstable-2024-09-16";
+
+  src = fetchFromRepoOrCz {
+    repo = "tinycc";
+    rev = "b8b6a5fd7b4e8cab8e5a5d01064cf5bf2b5eed95";
+    hash = "sha256-jY0P2GErmo//YBaz6u4/jj/voOE3C2JaIDRmo0orXN8=";
+  };
+
+  outputs = [ "out" "info" "man" ];
+
+  nativeBuildInputs = [
+    copyPkgconfigItems
+    perl
+    texinfo
+    which
+  ];
+
+  strictDeps = true;
+
+  pkgconfigItems = let
+    libtcc-pcitem = {
+      name = "libtcc";
+      inherit (finalAttrs) version;
+      cflags = [ "-I${libtcc-pcitem.variables.includedir}" ];
+      libs = [
+        "-L${libtcc-pcitem.variables.libdir}"
+        "-Wl,--rpath ${libtcc-pcitem.variables.libdir}"
+        "-ltcc"
+      ];
+      variables = {
+        prefix = "${placeholder "out"}";
+        includedir = "${placeholder "dev"}/include";
+        libdir = "${placeholder "lib"}/lib";
+      };
+      description = "Tiny C compiler backend";
+    };
+  in [
+    (makePkgconfigItem libtcc-pcitem)
+  ];
+
+  postPatch = ''
+    patchShebangs texi2pod.pl
+  '';
+
+  configureFlags = [
+    "--cc=$CC"
+    "--ar=$AR"
+    "--crtprefix=${lib.getLib stdenv.cc.libc}/lib"
+    "--sysincludepaths=${lib.getDev stdenv.cc.libc}/include:{B}/include"
+    "--libpaths=${lib.getLib stdenv.cc.libc}/lib"
+    # build cross compilers
+    "--enable-cross"
+  ] ++ lib.optionals stdenv.hostPlatform.isMusl [
+    "--config-musl"
+  ];
+
+  preConfigure = let
+    # To avoid "malformed 32-bit x.y.z" error on mac when using clang
+    versionIsClean = version:
+      builtins.match "^[0-9]\\.+[0-9]+\\.[0-9]+" version != null;
+  in ''
+    ${
+      if stdenv.isDarwin && ! versionIsClean finalAttrs.version
+      then "echo 'not overwriting VERSION since it would upset ld'"
+      else "echo ${finalAttrs.version} > VERSION"
+    }
+    configureFlagsArray+=("--elfinterp=$(< $NIX_CC/nix-support/dynamic-linker)")
+  '';
+
+  env.NIX_CFLAGS_COMPILE = toString (lib.optionals stdenv.cc.isClang [
+    "-Wno-error=implicit-int"
+    "-Wno-error=int-conversion"
+  ]);
+
+  # Test segfault for static build
+  doCheck = !stdenv.hostPlatform.isStatic;
+
+  checkTarget = "test";
+  # https://www.mail-archive.com/tinycc-devel@nongnu.org/msg10142.html
+  preCheck = lib.optionalString (stdenv.isDarwin && stdenv.isx86_64) ''
+    rm tests/tests2/{108,114}*
+  '';
+
+  meta = {
+    homepage = "https://repo.or.cz/tinycc.git";
+    description = "Small, fast, and embeddable C compiler and interpreter";
+    longDescription = ''
+      TinyCC (aka TCC) is a small but hyper fast C compiler.  Unlike other C
+      compilers, it is meant to be self-sufficient: you do not need an external
+      assembler or linker because TCC does that for you.
+
+      TCC compiles so fast that even for big projects Makefiles may not be
+      necessary.
+
+      TCC not only supports ANSI C, but also most of the new ISO C99 standard
+      and many GNU C extensions.
+
+      TCC can also be used to make C scripts, i.e. pieces of C source that you
+      run as a Perl or Python script.  Compilation is so fast that your script
+      will be as fast as if it was an executable.
+
+      TCC can also automatically generate memory and bound checks while allowing
+      all C pointers operations.  TCC can do these checks even if non patched
+      libraries are used.
+
+      With libtcc, you can use TCC as a backend for dynamic code generation.
+    '';
+    license = with lib.licenses; [ lgpl21Only ];
+    mainProgram = "tcc";
+    maintainers = with lib.maintainers; [ joachifm AndersonTorres ];
+    platforms = lib.platforms.unix;
+    # https://www.mail-archive.com/tinycc-devel@nongnu.org/msg10199.html
+    broken = stdenv.isDarwin && stdenv.isAarch64;
+  };
+})
+# TODO: more multiple outputs
+# TODO: self-compilation

shell.nix

@@ -0,0 +1,32 @@
+with import <nixpkgs> {
+  overlays = [
+    (final: prev: {
+      tcc-mob = final.callPackage ./nix/tinycc.nix { stdenv = final.gcc13Stdenv; };
+      chicken = final.callPackage ./nix/chicken.nix { stdenv = final.gcc13Stdenv; };
+    })
+  ];
+};
+mkShell {
+  packages = with pkgs; [
+    tcc-mob
+    chicken
+    rlwrap
+  ]
+  # ++ (with pkgs.chickenPackages_5.chickenEggs; [
+  #   apropos
+  #   chicken-doc
+  #   srfi-1
+  #   srfi-18
+  #   lsp-server
+  #   srfi-152
+  # ])
+  ;
+  shellHook = ''
+    export CC="${pkgs.tcc-mob}/bin/tcc"
+    export CHICKEN_PREFIX="$HOME/.chicken"
+    export CHICKEN_INSTALL_REPOSITORY="$HOME/.chicken/eggs"
+    export CHICKEN_REPOSITORY_PATH="${pkgs.chicken}/lib/chicken/12:$HOME/.chicken/eggs"
+    export PATH="$PATH:$CHICKEN_PREFIX"
+    export CHICKEN_PREFIX="${pkgs.chicken}"
+  '';
+}

symbol-access.scm

@@ -0,0 +1,133 @@
+;;;; symbol-access.scm  -*- Scheme -*-
+;;;; Kon Lovett, Jul '18
+
+;; Issues
+;;
+;; - "variable" rather than parameter since only 1 symbol-table? seems
+;; slightly faster.
+
+(declare
+  (bound-to-procedure
+    ##sys#symbol-has-toplevel-binding?))
+
+(module symbol-access
+
+(;export
+  ;
+  toplevel-module-symbol
+  ;
+  global-symbol-bound?
+  global-symbol-ref
+  ;
+  excluded-module-name? *excluded-module-name?
+  ;
+  split-prefixed-symbol *split-prefixed-symbol)
+
+(import scheme)
+(import (scheme case-lambda))
+(import (chicken base))
+(import (chicken type))
+(import (chicken syntax))
+(import (chicken fixnum))
+(import (only srfi-13 string-prefix? string-skip string-drop
+              string-take string-index))
+
+(define-type module-names (list-of string))
+
+(: toplevel-module-symbol (#!optional symbol -> symbol))
+
+(: *excluded-module-name? (string module-names --> boolean))
+(: *split-prefixed-symbol (symbol string --> string string))
+
+;these depend on a parameter, so cannot be --> but are #:clean
+(: excluded-module-name? (string #!optional module-names -> boolean))
+(: global-symbol-bound? (symbol -> boolean))
+(: global-symbol-ref (symbol -> *))
+(: split-prefixed-symbol (symbol #!optional string -> string string))
+
+;;(srfi 1)
+
+(import (only (srfi 1) any))
+#; ;UNUSED until no (srfi 1)
+(define (any pred lis1)
+  (and (not (null? lis1))
+       (let lp ((head (car lis1)) (tail (cdr lis1)))
+         (if (null? tail)
+             (pred head)    ; Last PRED app is tail call.
+             (or (pred head) (lp (car tail) (cdr tail)))))) )
+
+;;moremacros
+
+;NOTE see Issues above
+(define-syntax define-variable
+  (syntax-rules ()
+    ((define-variable ?name ?value ?guard)
+     (define ?name
+       (let* ((guard ?guard)
+              (val (guard ?value)))
+         (case-lambda
+           (() val)
+           ((obj)
+             (set! val (guard obj))
+             val ) ) ) ) )
+    ((define-variable ?name ?value)
+     (define-variable ?name ?value identity))
+    ((define-variable ?name)
+     (define-variable ?name (void)))))
+
+;;
+
+(define TOPLEVEL-MODULE-SYMBOL '||)
+
+;;
+
+(define-inline (namespace-tag-length str)
+  ;namespaced identifier begins w/ '##'
+  (or (string-skip str #\#)
+      0) )
+
+(define (global-symbol-name-start str)
+  ;modulename & namespace identifier has no '#' (?)
+  (string-index str #\# (namespace-tag-length str)) )
+
+;; Toplevel Symbols
+
+(define-variable toplevel-module-symbol #f
+  (lambda (obj)
+    (cond ((not obj) TOPLEVEL-MODULE-SYMBOL)
+          ((symbol? obj) obj)
+          (else
+            (error 'toplevel-module-symbol "bad argument type - not a symbol or #f" obj)))))
+
+;; Raw Access Renames
+
+(define (global-symbol-bound? sym) (##sys#symbol-has-toplevel-binding? sym))
+
+(define (global-symbol-ref sym) (##sys#slot sym 0))
+
+;;
+
+(define (*excluded-module-name? str excld)
+  (any (cut string-prefix? <> str) excld) )
+
+(define (excluded-module-name? str #!optional (excld '()))
+  (*excluded-module-name? str excld) )
+
+;=> module-name identifier-name
+;
+(define (*split-prefixed-symbol sym topstr)
+  (let* (;symbol name (keyword w/o print-mark)
+         (str (symbol->string sym))
+         ;module break char index
+         (idx (global-symbol-name-start str)) )
+    ;module?
+    (if idx
+        (values (string-take str idx) (string-drop str (fx+ idx 1)))
+        (values topstr str) ) ) )
+
+;=> module-name identifier-name
+;
+(define (split-prefixed-symbol sym #!optional (topstr (symbol->string (toplevel-module-symbol))))
+  (*split-prefixed-symbol sym topstr) )
+
+) ;module symbol-access

symbol-environment-access.scm

@@ -0,0 +1,100 @@
+;;;; symbol-environment-access.scm  -*- Scheme -*-
+;;;; Kon Lovett, Jul '18
+
+(declare
+  (bound-to-procedure
+    ##sys#macro-environment
+    ##sys#current-environment
+    ##sys#macro?))
+
+#|
+##sys namespace
+
+;alist
+module-table (list-of (pair module-identifier module))
+module-name (module --> symbol)
+
+(for-each (lambda (e) (assert (eq? (car e) (##sys#module-name (cdr e)))))
+          ##sys#module-table)
+
+module-alias-environment ???
+module-exports ???
+|#
+
+(include-relative "symbol-table-access")
+
+(module symbol-environment-access
+
+(;export
+  ;
+  system-current-environment
+  system-macro-environment
+  ;
+  macro-symbol-in-environment?
+  ;
+  search-macro-environment-symbols
+  search-system-environment-symbols
+  #; ;UNUSED
+  search-environments-symbols
+  ;
+  search-interaction-environment-symbols
+  search-list-environment-symbols)
+
+(import scheme)
+(import (chicken base))
+(import (chicken type))
+#; ;UNUSED
+(import (only (srfi 1) append!))
+(import (prefix symbol-table-access symbol-table-))
+
+;opaque
+(define-type macro-environment list)
+
+(: system-current-environment (-> list))
+(: system-macro-environment (-> list))
+(: macro-symbol-in-environment? (symbol macro-environment -> boolean))
+(: search-list-environment-symbols ((* -> boolean) (list-of (pair symbol *)) #!optional (pair -> *) --> list))
+(: search-interaction-environment-symbols ((* -> boolean) -> list))
+(: search-macro-environment-symbols ((* -> boolean) (list-of (pair symbol *)) --> list))
+(: search-system-environment-symbols ((* -> boolean) #!optional (or (list-of (pair symbol *)) boolean) -> list))
+(: search-environments-symbols ((* -> boolean) -> list))
+
+;;
+
+(define-inline (cons-if test? x xs) (if (test? x) (cons x xs) xs))
+
+;;
+
+(define system-current-environment ##sys#current-environment)
+(define system-macro-environment ##sys#macro-environment)
+
+(define macro-symbol-in-environment? ##sys#macro?)
+
+;;
+
+(define (search-list-environment-symbols test? env #!optional (elmref car))
+  (define (cons-if-symbol syms cell) (cons-if test? (elmref cell) syms))
+  (foldl cons-if-symbol '() env) )
+
+(define (search-interaction-environment-symbols test?)
+  (symbol-table-cursor-foldl (lambda (syms sym) (cons-if test? sym syms)) '()) )
+
+;;
+
+(define (search-macro-environment-symbols test? env)
+  (search-list-environment-symbols test? env) )
+
+(define (search-system-environment-symbols test? #!optional env)
+  (if (list? env)
+      (search-list-environment-symbols test? env)
+      (search-interaction-environment-symbols test?) ) )
+
+;;
+
+#; ;UNUSED
+(define (search-environments-symbols test?)
+  (append! (search-macro-environment-symbols test? (system-macro-environment))
+           (search-system-environment-symbols test? (system-current-environment))
+           (search-system-environment-symbols test?)) )
+
+) ;module symbol-environment-access

symbol-table-access.scm

@@ -0,0 +1,197 @@
+;;;; symbol-table-access.scm  -*- Scheme -*-
+;;;; Kon Lovett, Jul '18
+
+#>
+/*special stuff from the runtime & scheme API*/
+#define ROOT_SYMBOL_TABLE_NAME  "."
+
+#define raw_symbol_table_size( stable )       ((stable)->size)
+#define raw_symbol_table_chain( stable, i )   ((stable)->table[ (i) ])
+
+#define raw_bucket_symbol( bucket )   (C_block_item( (bucket), 0 ))
+#define raw_bucket_link( bucket )     (C_block_item( (bucket), 1 ))
+
+static C_regparm C_SYMBOL_TABLE *
+find_root_symbol_table()
+{
+  return C_find_symbol_table( ROOT_SYMBOL_TABLE_NAME );
+}
+
+static C_regparm C_SYMBOL_TABLE *
+remember_root_symbol_table()
+{
+  static C_SYMBOL_TABLE *root_symbol_table = NULL;
+  if(!root_symbol_table) {
+    root_symbol_table = find_root_symbol_table();
+  }
+
+  return root_symbol_table;
+}
+
+/* FIXME root_symbol_table re-allocated?
+#define use_root_symbol_table   find_root_symbol_table
+*/
+#define use_root_symbol_table   remember_root_symbol_table
+<#
+
+(module symbol-table-access
+
+(;export
+  ;
+  #; ;UNUSED
+  cursor-current
+  #; ;UNUSED
+  cursor-first
+  #; ;UNUSED
+  cursor-next
+  ;
+  cursor-foldl)
+
+(import scheme)
+(import (chicken base))
+(import (chicken fixnum))
+(import (chicken foreign))
+(import (chicken type))
+(import (chicken syntax))
+
+;internal
+(define-inline (%immediate? obj) (not (##core#inline "C_blockp" obj)))
+
+(define-type symbol-table-cursor (pair fixnum list))
+(define-type symbol-table-cursor* (or false symbol-table-cursor))
+
+#; ;UNUSED
+(: cursor-current (symbol-table-cursor* --> (or false symbol)))
+#; ;UNUSED
+(: cursor-first (--> symbol-table-cursor*))
+#; ;UNUSED
+(: cursor-next (symbol-table-cursor* --> symbol-table-cursor*))
+
+(: cursor-foldl (('a symbol -> 'a) 'a #!optional symbol-table-cursor --> 'a))
+
+#; ;closer than fold ;=)
+(: cursor-unfold (('a -> booleam) ('a symbol -> 'a) 'a #!optional symbol-table-cursor --> 'a))
+
+;;
+
+(: root-symbol-table-size (-> fixnum))
+(: root-symbol-table-element (fixnum -> pair))
+(: bucket-symbol (pair -> symbol))
+(: bucket-link (pair -> list))
+
+(: bucket-last? (list --> boolean))
+#; ;UNUSED
+(: bucket-symbol-ref (list -> (or false symbol)))
+#; ;UNUSED
+(: bucket-link-ref (list -> (or false list)))
+(: make-symbol-table-cursor (* * -> symbol-table-cursor))
+(: cursor-active? (* -> boolean))
+(: symbol-table-cursor? (* -> boolean))
+(: cursor-index (symbol-table-cursor -> *))
+#; ;UNUSED
+(: set-cursor-index! (symbol-table-cursor * -> void))
+(: cursor-bucket (symbol-table-cursor -> *))
+#; ;UNUSED
+(: set-cursor-bucket! (symbol-table-cursor * -> void))
+(: symbol-table-cursor (-> symbol-table-cursor))
+
+;; Symbol Table
+
+(define root-symbol-table-size
+  (foreign-lambda* int ()
+    "return( raw_symbol_table_size( use_root_symbol_table() ) );") )
+
+(define root-symbol-table-element
+  (foreign-lambda* scheme-object ((unsigned-integer i))
+    "return( raw_symbol_table_chain( use_root_symbol_table(), i ) );") )
+
+(define bucket-symbol
+  (foreign-lambda* scheme-object ((scheme-object bkt))
+    "return( raw_bucket_symbol( bkt ) );"))
+
+(define bucket-link
+  (foreign-lambda* scheme-object ((scheme-object bkt))
+    "return( raw_bucket_link( bkt ) );"))
+
+(define-inline (bucket-last? bkt) (null? bkt))
+
+#; ;UNUSED
+(define-inline (bucket-symbol-ref bkt)
+  (and (not (bucket-last? bkt))
+       (bucket-symbol bkt) ) )
+
+#; ;UNUSED
+(define-inline (bucket-link-ref bkt)
+  (and (not (bucket-last? bkt))
+       (bucket-link bkt)) )
+
+(define-inline (bucket-active? bkt)
+  (and bkt
+       (not (bucket-last? bkt))
+       (not (%immediate? (bucket-symbol bkt)))) )
+
+;; Symbol Table Cursor
+
+(define-inline (make-symbol-table-cursor a b) (cons a b))
+(define-inline (cursor-active? x) (pair? x))
+(define-inline (cursor-index x) (car x))
+#; ;UNUSED
+(define-inline (set-cursor-index! a b) (set-car! a b))
+(define-inline (cursor-bucket x) (cdr x))
+#; ;UNUSED
+(define-inline (set-cursor-bucket! a b) (set-cdr! a b))
+
+(define-inline (symbol-table-cursor) (make-symbol-table-cursor -1 '()))
+
+(define-inline (symbol-table-cursor? obj) (or (not obj) (cursor-active? obj)))
+
+;;
+
+#; ;UNUSED
+(define (cursor-current cursor)
+  (and (cursor-active? cursor)
+       (bucket-symbol-ref (cursor-bucket cursor)) ) )
+
+#; ;UNUSED
+(define (cursor-first) (cursor-next (symbol-table-cursor)))
+
+#; ;UNUSED
+(define (cursor-next cursor)
+  (and (cursor-active? cursor)
+       ;cache table size since assuming no shape-shifting
+       (let ((siz (root-symbol-table-size)))
+                    ;starting from the "next" bucket!
+         (let loop ((bkt (bucket-link-ref (cursor-bucket cursor)))
+                    (idx (cursor-index cursor)) )
+           ;gotta bucket ?
+           (if (bucket-active? bkt)
+               ;then found something => where we are
+               (make-symbol-table-cursor idx bkt)
+               ;else try next hash-root slot
+               (let ((idx (fx+ idx 1)))
+                 (and ;more to go ?
+                      (fx< idx siz)
+                      ;this slot
+                      (loop (root-symbol-table-element idx) idx) ) ) ) ) ) ) )
+
+;;
+
+(define (cursor-foldl g seed #!optional (cursor (symbol-table-cursor)))
+  ;cache table size since assuming no shape-shifting
+  (let ((siz (root-symbol-table-size)))
+    (if (or (fx= 0 siz) (not (cursor-active? cursor))) seed
+                   ;starting at the current bucket!
+        (let loop ((bkt (cursor-bucket cursor))
+                   (idx (cursor-index cursor))
+                   (seed seed) )
+          (if (bucket-active? bkt)
+              ;then continue to walk the bucket chain
+              (loop (bucket-link bkt) idx (g seed (bucket-symbol bkt)))
+              ;else walk the next bucket chain
+              (let ((idx (fx+ idx 1)))
+                ;exit when no more buckets
+                (if (fx>= idx siz) seed
+                    ;else continue w/ next bucket chain
+                    (loop (root-symbol-table-element idx) idx seed) ) ) ) ) ) ) )
+
+) ;module symbol-table-access

tests/apropos-test.scm

@@ -0,0 +1,272 @@
+;;;; apropos-test.scm  -*- Scheme -*-
+;;;; Kon Lovett, Jul '18
+
+;FIXME need better internal (system) symbol tests
+
+(import test)
+
+(cond-expand
+  (compiling
+    (print)
+    (print #<<EOS
+*****
+* Expect compiler wornings for type errors
+*****
+EOS
+    ) )
+  (else) )
+
+(test-begin "Apropos")
+
+;;;
+
+(import (chicken syntax))
+(import (chicken sort))
+(import apropos-api)
+
+;;
+
+(test-group "Parameters"
+
+  (test 10 (apropos-default-base))
+  ;NOTE difficult test since a warning, not an error
+  ;(test-error (apropos-default-base 27))
+
+  (test-assert (apropos-interning))
+
+  (test '() (apropos-default-options))
+
+  ;what it isn't
+  (test-error (apropos-excluded-modules #f))
+  (test-error (apropos-excluded-modules "abc"))
+  (test-error (apropos-excluded-modules '(a 23 "c")))
+  (test-error (apropos-excluded-modules '(a (b "c") "d")))
+  (test-error (apropos-excluded-modules '(a (srfi -8) "d")))
+  ;what it is
+  (test-assert (list? (apropos-excluded-modules)))
+  ;invertable
+  (test (apropos-excluded-modules)
+        (apropos-excluded-modules (apropos-excluded-modules)))
+  (parameterize ((apropos-excluded-modules
+                    (append '((foo bar baz) foo (srfi 0))
+                            (apropos-excluded-modules))))
+    (test "foo.bar.baz" (car (apropos-excluded-modules)))
+    (test "foo" (cadr (apropos-excluded-modules)))
+    (test "srfi-0" (caddr (apropos-excluded-modules))) )
+
+  ;not exposed
+  ;(test '|| (toplevel-module-symbol))
+)
+
+;;
+
+(define (symbol<? a b) (string<? (symbol->string a) (symbol->string b)))
+(define (car-symbol<? a b) (symbol<? (car a) (car b)))
+(define (cdar-symbol<? a b) (symbol<? (cdar a) (cdar b)))
+
+(define-syntax *apropos-list-test
+  (syntax-rules ()
+    ((*apropos-list-test ?msg ?exp ?val ?less?)
+      (test ?msg (sort ?exp ?less?) (sort ?val ?less?)) ) ) )
+
+(define-syntax apropos-list-test
+  (syntax-rules ()
+    ;
+    ((apropos-list-test ?exp ?val)
+      (apropos-list-test "apropos-list" ?exp ?val) )
+    ;
+    ((apropos-list-test ?msg ?exp ?val)
+      (*apropos-list-test ?msg ?exp ?val symbol<?) ) ) )
+
+(define-syntax apropos-information-list-test
+  (syntax-rules ()
+    ;
+    ((apropos-information-list-test ?exp ?val)
+      (apropos-information-list-test "apropos-information-list" ?exp ?val) )
+    ;
+    ((apropos-information-list-test ?msg ?exp ?val)
+      (*apropos-list-test ?msg ?exp ?val cdar-symbol<?) ) ) )
+
+;;
+
+(test-group "Imported"
+  (cond-expand
+    (csi
+      ;tests wildcard module but restricts to just imported
+      (apropos-list-test "test w/ imported?: #t"
+        '(test#current-test-group test#test-exit test#test-run
+        test#current-test-applier test#current-test-handler
+        test#current-test-verbosity test#test-total-count test#test-group-inc!
+        test#current-test-epsilon test#current-test-group-reporter
+        test#test-failure-count test#test-end test#current-test-skipper
+        test#test-begin test#current-test-comparator)
+        ;NOTE module+identifier pattern syntax has ' as lead tag so an evaluated arg
+        ;must be quoted
+        (apropos-list ''(_ . test) #:imported? #t)) )
+    (else
+      ;(almost) nothing imported so specify module & check the oblist
+      (apropos-list-test "test w/ specific module"
+        '(test#current-test-group test#test-exit test#test-run
+        test#current-test-applier test#current-test-handler
+        test#current-test-verbosity test#test-total-count test#test-group-inc!
+        test#current-test-epsilon test#current-test-group-reporter
+        test#test-failure-count test#test-end test#current-test-skipper
+        test#test-begin test#current-test-comparator)
+        ;NOTE module+identifier pattern syntax has ' as lead tag so an evaluated arg
+        ;must be quoted
+        (apropos-list ''(test . test))) ) )
+)
+
+;; build test symbols
+
+(define (foobarproc0) 'foobarproc0)
+(define (foobarproc1 a) 'foobarproc1)
+(define (foobarproc2 a b) 'foobarproc2)
+(define (foobarprocn a b . r) 'foobarprocn)
+
+(define foobarprocx (lambda (a b c) 'foobarprocx))
+
+;RQRD due to use of macro identifiers
+(declare (compile-syntax))
+
+(define-syntax foobarmacro1
+  (er-macro-transformer
+    (lambda (f r c)
+      'foobarmacro1 ) ) )
+
+(define-syntax foobarmacro2
+  (syntax-rules ()
+    ((_) 'foobarmacro1 ) ) )
+
+(define foobarvar1 'foobarvar1)
+(define foobarvar2 'foobarvar2)
+
+(define Foobarvar1 'Foobarvar1)
+(define Foobarvar2 'Foobarvar2)
+
+#;(define (foocoreinline flag) (##core#inline "C_set_gc_report" flag))
+#;(define fooprimitive (##core#primitive "C_get_memory_info"))
+
+(define ##foo#bar1 '##foo#bar1)
+(define ##foo#bar2 (lambda () '##foo#bar2))
+
+(define ##bar#foo1 '##bar#foo1)
+(define ##bar#foo2 (lambda () '##bar#foo2))
+
+;; test for symbols
+
+(test-group "Symbol List"
+
+  (apropos-list-test
+    '(foobarvar2 foobarvar1 foobarprocx foobarprocn foobarproc2 foobarproc1 foobarproc0)
+    (apropos-list 'foobar))
+
+  (apropos-list-test
+    '(foobarvar2 foobarvar1 foobarprocx foobarprocn foobarproc2 foobarproc1 foobarproc0)
+    (apropos-list "foobar"))
+
+  (apropos-list-test
+    '(##bar#foo1 ##bar#foo2 foobarmacro1 foobarmacro2 foobarproc0 foobarproc1 foobarproc2 foobarprocn foobarprocx foobarvar1 foobarvar2)
+    (apropos-list 'foo #:macros? #t #:internal? #t #:find #:name))
+
+  ;NOTE #:split still works!
+  (apropos-list-test
+    '(##foo#bar1 ##foo#bar2)
+    (apropos-list 'foo #:macros? #t #:internal? #t #:split #:module))
+
+  (apropos-list-test
+    '(foobarvar2 foobarvar1 foobarprocx foobarprocn foobarproc2 foobarproc1 foobarproc0 foobarmacro1 foobarmacro2)
+    (apropos-list 'foobar #:macros? #t))
+
+  (apropos-list-test
+    '(foobarvar2 foobarvar1 foobarprocx foobarprocn foobarproc2 foobarproc1 foobarproc0 Foobarvar2 Foobarvar1)
+    (apropos-list 'foobar #:case-insensitive? #t))
+
+  (apropos-list-test
+    '(foobarvar2 foobarvar1 Foobarvar1 Foobarvar2)
+    (apropos-list ''".+barvar[12]"))
+)
+
+#; ;CHICKEN version dependent! Can fail so must be run manually
+(test-group "Internal (hidden symbols)"
+  (apropos-list-test "internal check"
+    '(##sys#peek-and-free-c-string-list
+      ##sys#peek-c-string-list
+      chicken.internal.syntax-rules#drop-right
+      chicken.internal.syntax-rules#syntax-rules-mismatch
+      chicken.internal.syntax-rules#take-right)
+    (apropos-list '(or "syntax-rules" "c-string-list") #:internal? #t))
+)
+
+;;
+
+#|
+#;14> (define foobarprocx (lambda (a b c) 'foobarprocx))
+#;15> '(((|| . foobarmacro1) . macro))
+(((||: . foobarmacro1) . macro))
+#;16> '(((||: . foobarmacro1) . macro))
+(((: . foobarmacro1) . macro))
+#;17> ||
+||:
+#;18> ||:
+
+Error: unbound variable: :
+#;19> #:||
+||:
+#;20> (eq? #:|| #:||)
+#t
+#;21> (caaar (apropos-information-list 'foobarproc))
+||:
+#;22> (eq? #:|| (caaar (apropos-information-list 'foobarproc)))
+#f
+|#
+
+;oh , my - #:|| from reader is not eq? #:|| from symbol-table
+
+(test-group "Information List"
+  (apropos-information-list-test
+    '(((|| . foobarmacro1) . macro)
+      ((|| . foobarmacro2) . macro)
+      ((|| . foobarproc0) procedure)
+      ((|| . foobarproc1) procedure a)
+      ((|| . foobarproc2) procedure a b)
+      ((|| . foobarprocn) procedure a b . r)
+      ((|| . foobarprocx) procedure a b c)
+      ((|| . foobarvar1) . variable)
+      ((|| . foobarvar2) . variable))
+    (apropos-information-list 'foobar #:macros? #t #:internal? #t))
+
+  (test "apropos-information-list"
+    '(((|| . foobarproc0) procedure)
+      ((|| . foobarproc1) procedure a)
+      ((|| . foobarproc2) procedure a b)
+      ((|| . foobarprocn) procedure a b . r)
+      ((|| . foobarprocx) procedure a b c))
+    (apropos-information-list 'foobarproc #:macros? #t #:internal? #t #:sort #:module))
+)
+
+#| ;UNSUPPORTED
+;;
+
+(use environments)
+
+(define tstenv1 (make-environment #t))
+
+(environment-extend! tstenv1 'foobarprocx (lambda (a b c) 'foobarprocx))
+(environment-extend! tstenv1 'foobarvar1 'foobarvar1)
+(environment-extend! tstenv1 'foobarvar2 'foobarvar2)
+(environment-extend! tstenv1 '##bar#foo1 '##bar#foo1)
+(environment-extend! tstenv1 '##bar#foo1 (lambda () '##bar#foo1))
+
+;make-environment cannot create a syntax-environment
+;apropos always uses the ##sys#macro-environment for macro lookup
+
+(test '(foobarprocx foobarvar2 foobarvar1 ##bar#foo1)
+      (apropos-list 'foo tstenv1 #:internal? #t))
+|#
+
+;;;
+
+(test-end "Apropos")
+
+(test-exit)

tests/run.scm

@@ -0,0 +1,5 @@
+;;;; run.scm  -*- Scheme -*-
+
+(import (test-utils run))
+(runid '*csc-excl-options* '("-no-lambda-info"))
+(run-tests-for "apropos")