source: project/release/5/srfi-29/tags/3.0.2/srfi-29-logic.scm @ 38538

Last change on this file since 38538 was 38538, checked in by Kon Lovett, 16 months ago

rel 3.0.2

File size: 4.1 KB
Line 
1;;;; srfi-29-logic.scm
2;;;; Kon Lovett, Jun '17
3;;;; Kon Lovett,
4;;;; Kon Lovett, Dec '05
5
6;; Issues
7;;
8;; - Uses `module-rename' to construct a module qualified identifier; copied
9;; from unit modules.
10
11(declare
12  (bound-to-procedure
13    ##sys#symbol-has-toplevel-binding?))
14
15(module srfi-29-logic
16
17(;export
18  load-localized-compiled-code)
19
20(import scheme)
21(import (chicken base))
22(import (only (chicken load) load-library load-relative load-noisily))
23(import  (only (chicken platform) register-feature!))
24(import utf8)
25(import (only (srfi 1) first second every))
26(import (only type-checks check-symbol check-list define-check+error-type))
27(import (only type-errors-basic error-bound-value))
28(import (srfi 29))
29
30;;NOTE Symbol table access (unsupported)
31
32(define (%global-bound? sym) (##sys#symbol-has-toplevel-binding? sym))
33
34(define (%global-ref sym) (##sys#slot sym 0))
35
36;;; "Logic Bundle"
37
38;; Support
39
40;;(unit modules)
41
42(define (module-rename sym prefix)
43  (string->symbol
44    (string-append
45      (symbol->string prefix) "#" (symbol->string sym) ) ) )
46
47;Support both "styles" of alist element: (key . (value ...)) & (key . value)
48;where value is assumed to be an atom.
49;Assumes valid argument!
50(define (alist-element-atomic-value p)
51  (if (pair? (cdr p))
52    (cadr p)
53    (cdr p)) )
54
55;Assumes valid argument!
56(define (make-identifier ident)
57  (if (pair? ident)
58    ;qualified name
59    (module-rename (alist-element-atomic-value ident) (car ident))
60    ;unqualified name
61    ident ) )
62
63;Assumes valid argument!
64(define (required-global-ref loc ident)
65  (let (
66    (ident (make-identifier ident)) )
67    (if (and ident (%global-bound? ident))
68      (%global-ref ident)
69      (error-bound-value loc (void) ident) ) ) )
70
71;; Form checks
72
73(define (template-identifier-name? obj)
74  (or
75    (symbol? obj)
76    (and
77      (pair? obj)
78      (symbol? (car obj))
79      (symbol? (alist-element-atomic-value obj)))) )
80
81(define-check+error-type template-identifier-name)
82
83(define (check-template-variable-name loc pkgnam obj #!optional argnam)
84  (check-template-identifier-name
85    loc
86    (required-localized-template pkgnam (check-symbol loc obj argnam))
87    argnam)
88  obj )
89
90(define (check-template-variable-names loc pkgnam obj #!optional argnam)
91  (for-each
92    (cut check-template-variable-name loc pkgnam <> argnam)
93    (check-list loc obj argnam))
94  obj )
95
96;There must be a better way using sys namespace operations.
97;(Chicken 4.2.2 had a query for ALL loaded binaries.)
98;(KRL dloader branch still does.)
99
100; A `library-name' is a pathname or unitname.
101(define loaded-library?)
102(define loaded-library!)
103(let ((+loaded-libraries+ '()))
104  ;
105  (set! loaded-library? (lambda (ln)
106    (member ln +loaded-libraries+) ) )
107  ;
108  (set! loaded-library! (lambda (ln)
109    (set! +loaded-libraries+ (cons ln +loaded-libraries+)) ) ) )
110
111;;
112
113(define (load-code loc libspec)
114  (let (
115    (unit
116      (let ((itm (if (pair? libspec) (first libspec) libspec)))
117        (and (symbol? itm) itm)))
118    (path
119      (let ((itm (if (pair? libspec) (second libspec) libspec)))
120        (and (string? itm) itm))) )
121    ;pathname is preferred to a unitname
122    (let (
123      (pn (or path unit)) )
124      (unless (loaded-library? pn)
125        (cond
126          ;Library Unit w/ path
127          ((and unit path)
128            (load-library unit path) )
129          ;Library Unit
130          (unit
131            (load-library unit) )
132          ;Must be absolute pathaname, otherwise pathname is relative to
133          ;the "current file"
134          (path
135            (load-relative path) )
136          (else
137            (error loc "invalid library load specificiation" libspec) ) )
138        (loaded-library! pn) ) ) ) )
139
140;;
141
142(define (fixup-references loc pkgnam var-tplnams)
143  (check-package-name loc pkgnam)
144  (every
145    (lambda (tplnam)
146      (localized-template-set!
147        pkgnam tplnam
148        (required-global-ref loc (required-localized-template pkgnam tplnam))) )
149    (check-template-variable-names loc pkgnam var-tplnams)) )
150
151;;;
152
153;;
154
155(define (load-localized-compiled-code libspec pkgnam var-tplnams)
156  (load-code 'load-localized-compiled-code libspec)
157  (fixup-references 'load-localized-compiled-code pkgnam var-tplnams) )
158
159;;
160
161(register-feature! 'srfi-29-logic)
162
163) ;module srfi-29-logic
164
Note: See TracBrowser for help on using the repository browser.