/usr/lib/s9fes/get-prop.scm is in scheme9 2010.11.13-2.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 | ; Scheme 9 from Empty Space, Function Library
; By Nils M Holm, 2010
; See the LICENSE file of the S9fES package for terms of use
;
; (get-prop plist symbol) ==> object
; (put-prop plist symbol object) ==> plist
; (rem-prop plist symbol) ==> plist
; (put-prop! <variable> symbol object) ==> plist
; (rem-prop! <variable> symbol) ==> plist
;
; A property list (plist) is a list of the form
;
; (symbol1 object1 symbol2 object2 ...)
;
; GET-PROP returns the object (property) following the given
; SYMBOL or #F if SYMBOL does not exist in an odd position
; in the PLIST.
; PUT-PROP returns a new plist in which the given OBJECT is
; the property associated with SYMBOL. When SYMBOL is alreay
; in the PLIST, the existing association will be removed.
; REM-PROP returns a new plist with the given SYMBOL and the
; associated property removed.
;
; PUT-PROP! adds a new property to the plist bound to the
; given <variable>. The variable will be bound to the new
; list. REM-PROP! removes a property from a plist that is
; bound to the <variable>.
;
; Example: (get-prop '() 'foo) ==> #f
; (put-prop '() 'foo 42) ==> (foo 42)
; (get-prop '(foo 42) 'foo) ==> 42
; (rem-prop '(foo 42) 'foo) ==> ()
(define (get-prop a x)
(cond ((null? a)
#f)
((and (eq? x (car a))
(pair? (cdr a)))
(cadr a))
((pair? (cdr a))
(get-prop (cddr a) x))
(else
#f)))
(define (put-prop a k v)
(let loop ((in a)
(out '()))
(cond ((null? in)
(cons k (cons v a)))
((and (eq? k (car in))
(pair? (cdr in)))
(append (reverse! (cons v (cons k out)))
(cddr in)))
((pair? (cdr in))
(loop (cddr in)
(cons (cadr in)
(cons (car in) out))))
(else
(cons k (cons v a))))))
(define (rem-prop a x)
(let loop ((in a)
(out '()))
(cond ((and (eq? x (car in))
(pair? (cdr in)))
(append (reverse! out) (cddr in)))
((pair? (cdr in))
(loop (cddr in)
(cons (cadr in)
(cons (car in) out))))
(else
a))))
(define-syntax (put-prop! n k v)
`(set! ,n (put-prop ,n ,k ,v)))
(define-syntax (rem-prop! n k)
`(set! ,n (rem-prop ,n ,k)))
|