source: project/release/5/srfi-29/trunk/srfi-29-logic.scm @ 38077

Last change on this file since 38077 was 38077, checked in by Kon Lovett, 6 weeks ago

C5 port

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