mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-05-19 13:49:17 +02:00
Adding assoc-get-list analog of conf-get-list.
Making assoc-get[-list] permissively ignore of non-pair entries. Updating conf-specialize with the new record type.
This commit is contained in:
parent
c558f19743
commit
24d22644d0
2 changed files with 30 additions and 17 deletions
|
@ -122,12 +122,26 @@
|
|||
;;> unspecified.
|
||||
|
||||
(define (assoc-get alist key . o)
|
||||
(let ((equal (or (and (pair? o) (car o)) equal?)))
|
||||
(let lp ((ls alist))
|
||||
(cond
|
||||
((assoc key alist (or (and (pair? o) (car o)) equal?))
|
||||
=> (lambda (x)
|
||||
(if (and (pair? (cdr x)) (null? (cddr x))) (cadr x) (cdr x))))
|
||||
(else
|
||||
(and (pair? o) (pair? (cdr o)) (cadr o)))))
|
||||
((not (pair? ls)) (and (pair? o) (pair? (cdr o)) (cadr o)))
|
||||
((and (pair? (car ls)) (equal key (caar ls)))
|
||||
(if (and (pair? (cdar ls)) (null? (cdr (cdar ls))))
|
||||
(car (cdar ls))
|
||||
(cdar ls)))
|
||||
(else (lp (cdr ls)))))))
|
||||
|
||||
;;> \procedure{(assoc-get-list alist key [default])}
|
||||
|
||||
;;> Equivalent to \scheme{assoc-get} but coerces its result to a list
|
||||
;;> as described in the syntax section.
|
||||
|
||||
(define (assoc-get-list alist key . o)
|
||||
(let ((res (assoc-get alist key)))
|
||||
(if res
|
||||
(if (or (pair? res) (null? res)) res (list res))
|
||||
(if (pair? o) (car o) '()))))
|
||||
|
||||
;;> Returns just the base of \var{config} without any parent.
|
||||
|
||||
|
@ -325,16 +339,15 @@
|
|||
;;> Lift specialized sections to the top-level of a config.
|
||||
|
||||
(define (conf-specialize config key name)
|
||||
(let lp ((ls config) (res '()))
|
||||
(cond
|
||||
((null? ls) (reverse res))
|
||||
((assq key (car ls))
|
||||
=> (lambda (specialized)
|
||||
(let ((named (assq name (cdr specialized))))
|
||||
(let lp ((cfg config) (res '()))
|
||||
(if (not cfg)
|
||||
(make-conf (reverse res) config #f (current-second))
|
||||
(let* ((specialized (assq key (conf-alist cfg)))
|
||||
(named (and specialized (assq name (cdr specialized))))
|
||||
(next (conf-parent cfg)))
|
||||
(if named
|
||||
(lp (cdr ls) (cons (car ls) (cons (cdr named) res)))
|
||||
(lp (cdr ls) (cons (car ls) res))))))
|
||||
(else (lp (cdr ls) (cons (car ls) res))))))
|
||||
(lp next (cons (cdr named) res))
|
||||
(lp next res))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
|
|
|
@ -4,7 +4,7 @@
|
|||
conf-verify conf-extend conf-append conf-set conf-unfold-key
|
||||
conf-get conf-get-list conf-get-cdr conf-get-multi
|
||||
conf-specialize read-from-file conf-source conf-head conf-parent
|
||||
assoc-get)
|
||||
assoc-get assoc-get-list)
|
||||
(import (scheme base) (scheme read) (scheme write) (scheme file)
|
||||
(scheme time) (srfi 1))
|
||||
;; This is only used for config verification, it's acceptable to
|
||||
|
|
Loading…
Add table
Reference in a new issue