Chicken/apropos
SHA256
1
0
Fork 0
Code Issues Pull requests Projects Releases 2 Packages Wiki Activity Actions

Port to Chicken 6

Browse source
This commit is contained in:
Daniel Ziltener 2024-09-25 18:28:37 +02:00
commit 8d8e3b4850
Signed by: zilti
GPG key ID: B38976E82C9DAE42
15 changed files with 2210 additions and 0 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
.envrc Normal file
View file

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

3
README.org Normal file
View file

@ -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.

942
apropos-api.scm Normal file
View file

@ -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)) )
|#

196
apropos-csi.scm Normal file
View file

@ -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

35
apropos.egg Normal file
View file

@ -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) ) ) )

4
apropos.release-info Normal file
View file

@ -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

34
apropos.scm Normal file
View file

@ -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

126
nix/chicken.nix Normal file
View file

@ -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.
'';
};
})

129
nix/tinycc.nix Normal file
View file

@ -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

32
shell.nix Normal file
View file

@ -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}"
'';
}

133
symbol-access.scm Normal file
View file

@ -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

100
symbol-environment-access.scm Normal file
View file

@ -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

197
symbol-table-access.scm Normal file
View file

@ -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

272
tests/apropos-test.scm Normal file
View file

@ -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)

5
tests/run.scm Normal file
View file

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