mirror of
https://github.com/false-schemers/skint.git
synced 2024-12-26 21:58:51 +01:00
*root-name-registry* fully initialized
This commit is contained in:
ESL
parent
f625b5103b
commit
666ace8461
3 changed files with 91 additions and 25 deletions
17
i.c
17
i.c
|
|
@ -17,6 +17,7 @@ extern obj cx__2Acurrent_2Derror_2A;
|
|||
|
||||
/* forwards */
|
||||
static struct intgtab_entry *lookup_integrable(int sym);
|
||||
static int intgtab_count(void);
|
||||
static int isintegrable(obj x);
|
||||
static struct intgtab_entry *integrabledata(obj x);
|
||||
static obj mkintegrable(struct intgtab_entry *);
|
||||
|
|
@ -3420,7 +3421,16 @@ define_instruction(igp) {
|
|||
}
|
||||
|
||||
define_instruction(iglk) {
|
||||
struct intgtab_entry *pe; cky(ac);
|
||||
struct intgtab_entry *pe;
|
||||
/* lookup by index: returns #f for out-of-scope, void for missing */
|
||||
if (is_fixnum(ac)) {
|
||||
int i = get_fixnum(ac), cnt = intgtab_count();
|
||||
if (i < 0 || i >= cnt) ac = bool_obj(0);
|
||||
else if (!isintegrable(ac)) ac = void_obj();
|
||||
gonexti();
|
||||
}
|
||||
/* lookup by by symbol */
|
||||
cky(ac);
|
||||
pe = lookup_integrable(get_symbol(ac));
|
||||
ac = pe ? mkintegrable(pe) : bool_obj(0);
|
||||
gonexti();
|
||||
|
|
@ -3957,6 +3967,11 @@ static obj mkintegrable(struct intgtab_entry *pe)
|
|||
return obj_from_fixnum(pe-intgtab);
|
||||
}
|
||||
|
||||
static int intgtab_count(void)
|
||||
{
|
||||
return sizeof(intgtab)/sizeof(intgtab[0]);
|
||||
}
|
||||
|
||||
static struct intgtab_entry *lookup_integrable(int sym)
|
||||
{
|
||||
struct intgtab_entry e, *pe;
|
||||
|
|
|
|||
49
src/t.scm
49
src/t.scm
|
|
@ -1814,12 +1814,14 @@
|
|||
(define (root-environment id at)
|
||||
(env-lookup id *root-environment* at))
|
||||
|
||||
|
||||
;---------------------------------------------------------------------------------------------
|
||||
; Symbol-name identifiers registry and built-in syntax values
|
||||
; Expand-time root name registry initialized with built-in and predefined values
|
||||
;---------------------------------------------------------------------------------------------
|
||||
|
||||
; name registries are htables (vectors of prime+1 length) of alists ((sym . <location>) ...)
|
||||
(define *root-name-registry* (make-vector 102 '()))
|
||||
; name registries are htables (vectors with one extra slot) of alists ((sym . <location>) ...)
|
||||
; last slot is used for list names (library names), the rest for regular symbolic names
|
||||
(define *root-name-registry* (make-vector 102 '())) ; vector of prime+1 length
|
||||
|
||||
(define (name-lookup nr name mkdefval) ;=> loc | #f
|
||||
(let* ([n-1 (- (vector-length nr) 1)] [i (if (pair? name) n-1 (immediate-hash name n-1))]
|
||||
|
|
@ -1831,7 +1833,37 @@
|
|||
loc)]
|
||||
[else #f])))
|
||||
|
||||
; register standard libraries as well as all-encompassing (repl) library
|
||||
; register integrable procedures
|
||||
(let loop ([i 0])
|
||||
(let ([li (lookup-integrable i)])
|
||||
(when li ; in range: void or integrable
|
||||
(when (integrable? i)
|
||||
(let ([name (integrable-global i)])
|
||||
;(display "integrable[") (write i) (display "] = ") (write name) (newline)
|
||||
(when (symbol? name) (name-lookup *root-name-registry* name (lambda (name) i)))))
|
||||
(loop (+ i 1)))))
|
||||
|
||||
; register initial transformers
|
||||
(let loop ([l (initial-transformers)])
|
||||
(unless (null? l)
|
||||
(let* ([p (car l)] [l (cdr l)] [k (car p)] [v (cdr p)])
|
||||
(cond [(or (symbol? v) (integrable? v))
|
||||
(name-lookup *root-name-registry* k (lambda (name) v))
|
||||
(loop l)]
|
||||
[(and (pair? v) (eq? (car v) 'syntax-rules))
|
||||
(body
|
||||
(define (sr-env id at)
|
||||
; FIXME: for now, we have to keep using old root env
|
||||
(env-lookup id *root-environment* at))
|
||||
(define sr-v
|
||||
(if (id? (cadr v))
|
||||
(syntax-rules* sr-env (cadr v) (caddr v) (cdddr v))
|
||||
(syntax-rules* sr-env #f (cadr v) (cddr v))))
|
||||
(name-lookup *root-name-registry* k (lambda (name) sr-v))
|
||||
(loop l))]))))
|
||||
|
||||
; register standard libraries as well as (repl) library for interactive environment
|
||||
; ... while doing that, bind missing standard names as refs to constant globals
|
||||
(for-each
|
||||
(lambda (r)
|
||||
(define (key->listname k)
|
||||
|
|
@ -1854,11 +1886,16 @@
|
|||
(let* ([eal (library-exports library)] [p (assq k eal)])
|
||||
(cond [p (set-cdr! p loc)]
|
||||
[else (library-set-exports! library (cons (cons k loc) eal))])))
|
||||
(define (get-loc name)
|
||||
; FIXME: switch root-environment to *root-name-registry*, and use this:
|
||||
; (name-lookup *root-name-registry* name (lambda (name) (list 'const name)))
|
||||
; for now, for libraries to work, we have to share old root env locations:
|
||||
(root-environment name 'ref))
|
||||
(let loop ([name (car r)] [keys (cdr r)])
|
||||
(cond [(null? keys) ; all go to (repl)
|
||||
(put-loc! (get-library! '(repl)) name (root-environment name 'ref))]
|
||||
(put-loc! (get-library! '(repl)) name (get-loc name))]
|
||||
[else
|
||||
(put-loc! (get-library! (key->listname (car keys))) name (root-environment name 'ref))
|
||||
(put-loc! (get-library! (key->listname (car keys))) name (get-loc name))
|
||||
(loop name (cdr keys))])))
|
||||
'((* v b) (+ v b) (- v b) (... v u b) (/ v b) (< v b) (<= v b) (= v b) (=> v u b) (> v b) (>= v b)
|
||||
(_ b) (abs v b) (and v u b) (append v b) (apply v b) (assoc v b) (assq v b) (assv v b) (begin v u b)
|
||||
|
|
|
|||
50
t.c
50
t.c
|
|
@ -1015,6 +1015,20 @@ char *t_code[] = {
|
|||
"%3'1,.1V3-,.2p?{.0}{.0,.3H2},.0,.3V4,.4p?{.0,.5A5}{.0,.5A3},.0?{.0d]7}"
|
||||
".6?{${.7,.9[01}b,.2,.1,.8cc,.4,.7V5.0]8}f]7",
|
||||
|
||||
"C", 0,
|
||||
"${'0,,#0.0,&1{%1.0U5,.0?{.1U0?{.1U7,.0Y0?{${.4,&1{%1:0]1},.3,@(y20:*ro"
|
||||
"ot-name-registry*),@(y11:name-lookup)[03}}_1}'1,.2+,:0^[21}]2}.!0.0^_1"
|
||||
"[01}",
|
||||
|
||||
"C", 0,
|
||||
"${U1,,#0.0,&1{%1.0u~?{.0a,.1d,.1a,.2d,.0Y0,.0?{.0}{.1U0}_1?{${.2,&1{%1"
|
||||
":0]1},.4,@(y20:*root-name-registry*),@(y11:name-lookup)[03}.2,:0^[51}."
|
||||
"0p?{'(y12:syntax-rules),.1aq}{f}?{,,#0#1&0{%2.1,@(y18:*root-environmen"
|
||||
"t*),.2,@(y10:env-lookup)[23}.!0${.4da,@(y3:id?)[01}?{${.4ddd,.5dda,.6d"
|
||||
"a,.5^,@(y13:syntax-rules*)[04}}{${.4dd,.5da,f,.5^,@(y13:syntax-rules*)"
|
||||
"[04}}.!1${.3,&1{%1:0^]1},.6,@(y20:*root-name-registry*),@(y11:name-loo"
|
||||
"kup)[03}.4,:0^[71}f]5}]1}.!0.0^_1[01}",
|
||||
|
||||
"C", 0,
|
||||
"${'(l343:l3:y1:*;y1:v;y1:b;;l3:y1:+;y1:v;y1:b;;l3:y1:-;y1:v;y1:b;;l4:y"
|
||||
"3:...;y1:v;y1:u;y1:b;;l3:y1:/;y1:v;y1:b;;l3:y1:<;y1:v;y1:b;;l3:y2:<=;y"
|
||||
|
|
@ -1146,24 +1160,24 @@ char *t_code[] = {
|
|||
"5:write;y1:w;y1:v;;l2:y13:current-jiffy;y1:t;;l2:y14:current-second;y1"
|
||||
":t;;l2:y18:jiffies-per-second;y1:t;;l2:y12:write-shared;y1:w;;l2:y12:w"
|
||||
"rite-simple;y1:w;;l1:y4:box?;;l1:y3:box;;l1:y5:unbox;;l1:y8:set-box!;;"
|
||||
"),&0{%1,,,#0#1#2&0{%1.0,'(y1:w),.1v?{'(l2:y6:scheme;y5:write;)]2}'(y1:"
|
||||
"t),.1v?{'(l2:y6:scheme;y4:time;)]2}'(y1:p),.1v?{'(l2:y6:scheme;y4:repl"
|
||||
";)]2}'(y1:r),.1v?{'(l2:y6:scheme;y4:read;)]2}'(y1:v),.1v?{'(l2:y6:sche"
|
||||
"me;y4:r5rs;)]2}'(y1:u),.1v?{'(l2:y6:scheme;y9:r5rs-null;)]2}'(y1:d),.1"
|
||||
"v?{'(l2:y6:scheme;y4:load;)]2}'(y1:z),.1v?{'(l2:y6:scheme;y4:lazy;)]2}"
|
||||
"'(y1:s),.1v?{'(l2:y6:scheme;y15:process-context;)]2}'(y1:i),.1v?{'(l2:"
|
||||
"y6:scheme;y7:inexact;)]2}'(y1:f),.1v?{'(l2:y6:scheme;y4:file;)]2}'(y1:"
|
||||
"e),.1v?{'(l2:y6:scheme;y4:eval;)]2}'(y1:o),.1v?{'(l2:y6:scheme;y7:comp"
|
||||
"lex;)]2}'(y1:h),.1v?{'(l2:y6:scheme;y4:char;)]2}'(y1:l),.1v?{'(l2:y6:s"
|
||||
"cheme;y11:case-lambda;)]2}'(y1:x),.1v?{'(l2:y6:scheme;y3:cxr;)]2}'(y1:"
|
||||
"b),.1v?{'(l2:y6:scheme;y4:base;)]2}]2}.!0&0{%1${.2,&1{%1n,'(l1:y5:begi"
|
||||
"n;),V12,${t,.3b,${:0,@(y16:listname->symbol)[01},@(y27:define-in-root-"
|
||||
"environment!)[03}.0]2},.3,@(y20:*root-name-registry*),@(y11:name-looku"
|
||||
"p)[03}z]1}.!1&0{%3'1,.1V4,.0,.3A3,.0?{.4,.1sd]5}.1,.5,.5cc,'1,.4V5]5}."
|
||||
"!2.3d,.4a,,#0.0,.6,.5,.7,&4{%2.1u?{${'(y3:ref),.3,@(y16:root-environme"
|
||||
"nt)[02},.1,${'(l1:y4:repl;),:0^[01},:2^[23}${${'(y3:ref),.5,@(y16:root"
|
||||
"-environment)[02},.3,${${.9a,:1^[01},:0^[01},:2^[03}.1d,.1,:3^[22}.!0."
|
||||
"0^_1[42},@(y10:%25for-each1)[02}",
|
||||
"),&0{%1,,,,#0#1#2#3&0{%1.0,'(y1:w),.1v?{'(l2:y6:scheme;y5:write;)]2}'("
|
||||
"y1:t),.1v?{'(l2:y6:scheme;y4:time;)]2}'(y1:p),.1v?{'(l2:y6:scheme;y4:r"
|
||||
"epl;)]2}'(y1:r),.1v?{'(l2:y6:scheme;y4:read;)]2}'(y1:v),.1v?{'(l2:y6:s"
|
||||
"cheme;y4:r5rs;)]2}'(y1:u),.1v?{'(l2:y6:scheme;y9:r5rs-null;)]2}'(y1:d)"
|
||||
",.1v?{'(l2:y6:scheme;y4:load;)]2}'(y1:z),.1v?{'(l2:y6:scheme;y4:lazy;)"
|
||||
"]2}'(y1:s),.1v?{'(l2:y6:scheme;y15:process-context;)]2}'(y1:i),.1v?{'("
|
||||
"l2:y6:scheme;y7:inexact;)]2}'(y1:f),.1v?{'(l2:y6:scheme;y4:file;)]2}'("
|
||||
"y1:e),.1v?{'(l2:y6:scheme;y4:eval;)]2}'(y1:o),.1v?{'(l2:y6:scheme;y7:c"
|
||||
"omplex;)]2}'(y1:h),.1v?{'(l2:y6:scheme;y4:char;)]2}'(y1:l),.1v?{'(l2:y"
|
||||
"6:scheme;y11:case-lambda;)]2}'(y1:x),.1v?{'(l2:y6:scheme;y3:cxr;)]2}'("
|
||||
"y1:b),.1v?{'(l2:y6:scheme;y4:base;)]2}]2}.!0&0{%1${.2,&1{%1n,'(l1:y5:b"
|
||||
"egin;),V12,${t,.3b,${:0,@(y16:listname->symbol)[01},@(y27:define-in-ro"
|
||||
"ot-environment!)[03}.0]2},.3,@(y20:*root-name-registry*),@(y11:name-lo"
|
||||
"okup)[03}z]1}.!1&0{%3'1,.1V4,.0,.3A3,.0?{.4,.1sd]5}.1,.5,.5cc,'1,.4V5]"
|
||||
"5}.!2&0{%1'(y3:ref),.1,@(y16:root-environment)[12}.!3.4d,.5a,,#0.0,.6,"
|
||||
".5,.7,.(i10),&5{%2.1u?{${.2,:0^[01},.1,${'(l1:y4:repl;),:1^[01},:3^[23"
|
||||
"}${${.4,:0^[01},.3,${${.9a,:2^[01},:1^[01},:3^[03}.1d,.1,:4^[22}.!0.0^"
|
||||
"_1[52},@(y10:%25for-each1)[02}",
|
||||
|
||||
"C", 0,
|
||||
"f@!(y9:*verbose*)",
|
||||
|
|
|
|||
Loading…
Reference in a new issue