mirror of
https://github.com/false-schemers/skint.git
synced 2024-12-26 21:58:51 +01:00
include, cond-expand redone; minor fixes
This commit is contained in:
ESL
parent
608fb8063a
commit
d4f6ef3451
5 changed files with 78 additions and 95 deletions
14
i.c
14
i.c
|
|
@ -1195,12 +1195,14 @@ define_instruction(memq) {
|
|||
}
|
||||
|
||||
define_instruction(memv) {
|
||||
ac = ismemv(ac, spop()); /* FIXME: ckp() */
|
||||
obj l = spop(); ckl(l);
|
||||
ac = ismemv(ac, l); /* FIXME: inline? */
|
||||
gonexti();
|
||||
}
|
||||
|
||||
define_instruction(meme) {
|
||||
ac = ismember(ac, spop()); /* FIXME: ckp() */
|
||||
obj l = spop(); ckl(l);
|
||||
ac = ismember(ac, l); /* FIXME: inline? */
|
||||
gonexti();
|
||||
}
|
||||
|
||||
|
|
@ -1214,12 +1216,14 @@ define_instruction(assq) {
|
|||
}
|
||||
|
||||
define_instruction(assv) {
|
||||
ac = isassv(ac, spop()); /* FIXME: ckp() */
|
||||
obj l = spop(); ckl(l);
|
||||
ac = isassv(ac, l); /* FIXME: inline? */
|
||||
gonexti();
|
||||
}
|
||||
|
||||
define_instruction(asse) {
|
||||
ac = isassoc(ac, spop()); /* FIXME: ckp() */
|
||||
obj l = spop(); ckl(l);
|
||||
ac = isassoc(ac, l); /* FIXME: inline? */
|
||||
gonexti();
|
||||
}
|
||||
|
||||
|
|
@ -3456,7 +3460,7 @@ define_instruction(vmclo) {
|
|||
|
||||
define_instruction(hshim) {
|
||||
unsigned long long v = (unsigned long long)ac, base = 0; obj b = spop();
|
||||
if (v && isaptr(v)) failtype(v, "immediate value");
|
||||
if (v && isaptr(v)) { ac = fixnum_obj(0); gonexti(); }
|
||||
if (b) { ckk(b); base = get_fixnum(b); }
|
||||
if (!base) base = 1 + (unsigned long long)FIXNUM_MAX;
|
||||
ac = fixnum_obj((fixnum_t)(v % base));
|
||||
|
|
|
|||
33
s.c
33
s.c
|
|
@ -22,11 +22,11 @@ char *s_code[] = {
|
|||
";py4:body;y5:forms;;;;",
|
||||
|
||||
"S", "let",
|
||||
"l4:y12:syntax-rules;n;l2:py1:_;pl2:l2:y3:var;y4:init;;y3:...;;y5:forms"
|
||||
";;;l3:py6:lambda;pl2:y3:var;y3:...;;y5:forms;;;y4:init;y3:...;;;l2:py1"
|
||||
":_;py4:name;pl2:l2:y3:var;y4:init;;y3:...;;y5:forms;;;;l3:l3:y6:letrec"
|
||||
";l1:l2:y4:name;py6:lambda;pl2:y3:var;y3:...;;y5:forms;;;;;y4:name;;y4:"
|
||||
"init;y3:...;;;",
|
||||
"l5:y12:syntax-rules;n;l2:py1:_;pn;y5:forms;;;py4:body;y5:forms;;;l2:py"
|
||||
"1:_;pl2:l2:y3:var;y4:init;;y3:...;;y5:forms;;;l3:py6:lambda;pl2:y3:var"
|
||||
";y3:...;;y5:forms;;;y4:init;y3:...;;;l2:py1:_;py4:name;pl2:l2:y3:var;y"
|
||||
"4:init;;y3:...;;y5:forms;;;;l3:l3:y6:letrec;l1:l2:y4:name;py6:lambda;p"
|
||||
"l2:y3:var;y3:...;;y5:forms;;;;;y4:name;;y4:init;y3:...;;;",
|
||||
|
||||
"S", "let*",
|
||||
"l4:y12:syntax-rules;n;l2:py1:_;pn;y5:forms;;;py4:body;y5:forms;;;l2:py"
|
||||
|
|
@ -150,29 +150,6 @@ char *s_code[] = {
|
|||
"l3:y12:syntax-rules;n;l2:l3:y1:_;py4:args;y5:forms;;y3:...;;l3:y7:lamb"
|
||||
"da*;l2:y4:args;py6:lambda;py4:args;y5:forms;;;;y3:...;;;",
|
||||
|
||||
"S", "%if-expand",
|
||||
"l12:y12:syntax-rules;l4:y3:and;y2:or;y3:not;y7:library;;l2:l4:y1:_;l1:"
|
||||
"y3:and;;y3:con;y3:alt;;y3:con;;l2:l4:y1:_;l2:y3:and;y1:r;;y3:con;y3:al"
|
||||
"t;;l4:y10:%25if-expand;y1:r;y3:con;y3:alt;;;l2:l4:y1:_;py3:and;py1:r;y"
|
||||
"2:r*;;;y3:con;y3:alt;;l4:y10:%25if-expand;y1:r;l4:y10:%25if-expand;py3"
|
||||
":and;y2:r*;;y3:con;y3:alt;;y3:alt;;;l2:l4:y1:_;l1:y2:or;;y3:con;y3:alt"
|
||||
";;y3:alt;;l2:l4:y1:_;l2:y2:or;y1:r;;y3:con;y3:alt;;l4:y10:%25if-expand"
|
||||
";y1:r;y3:con;y3:alt;;;l2:l4:y1:_;py2:or;py1:r;y2:r*;;;y3:con;y3:alt;;l"
|
||||
"4:y10:%25if-expand;y1:r;y3:con;l4:y10:%25if-expand;py2:or;y2:r*;;y3:co"
|
||||
"n;y3:alt;;;;l2:l4:y1:_;l2:y3:not;y1:r;;y3:con;y3:alt;;l4:y10:%25if-exp"
|
||||
"and;y1:r;y3:alt;y3:con;;;l2:l4:y1:_;l2:y7:library;y1:l;;y3:con;y3:alt;"
|
||||
";l4:y20:if-library-available;y1:l;y3:con;y3:alt;;;l2:l4:y1:_;py1:x;y1:"
|
||||
"y;;y3:con;y3:alt;;l3:y12:syntax-error;s45:unrecognized cond-expand fea"
|
||||
"ture requirement:;py1:x;y1:y;;;;l2:l4:y1:_;y1:f;y3:con;y3:alt;;l4:y20:"
|
||||
"if-feature-available;y1:f;y3:con;y3:alt;;;",
|
||||
|
||||
"S", "cond-expand",
|
||||
"l6:y12:syntax-rules;l1:y4:else;;l2:l1:y1:_;;l1:y4:void;;;l2:l2:y1:_;py"
|
||||
"4:else;y4:exps;;;py5:begin;y4:exps;;;l2:py1:_;pl1:y1:x;;y4:rest;;;l4:y"
|
||||
"10:%25if-expand;y1:x;l1:y5:begin;;py11:cond-expand;y4:rest;;;;l2:py1:_"
|
||||
";ppy1:x;y4:exps;;y4:rest;;;l4:y10:%25if-expand;y1:x;py5:begin;y4:exps;"
|
||||
";py11:cond-expand;y4:rest;;;;",
|
||||
|
||||
"C", 0,
|
||||
"@(y4:box?)@!(y8:promise?)",
|
||||
|
||||
|
|
|
|||
29
src/s.scm
29
src/s.scm
|
|
@ -27,6 +27,7 @@
|
|||
; (syntax-lambda (id ...) form ...)
|
||||
; (syntax-rules (lit ...) [pat templ] ...)
|
||||
; (syntax-rules ellipsis (lit ...) [pat templ] ...)
|
||||
; (cond-expand [ftest exp ...] ...)
|
||||
|
||||
(define-syntax let-syntax
|
||||
(syntax-rules ()
|
||||
|
|
@ -56,6 +57,7 @@
|
|||
|
||||
(define-syntax let
|
||||
(syntax-rules ()
|
||||
[(_ () . forms) (body . forms)]
|
||||
[(_ ([var init] ...) . forms)
|
||||
((lambda (var ...) . forms) init ...)]
|
||||
[(_ name ([var init] ...) . forms)
|
||||
|
|
@ -192,33 +194,6 @@
|
|||
(syntax-rules ()
|
||||
[(_ [args . forms] ...) (lambda* [args (lambda args . forms)] ...)]))
|
||||
|
||||
(define-syntax %if-expand
|
||||
(syntax-rules (and or not library)
|
||||
[(_ (and) con alt) con]
|
||||
[(_ (and r) con alt) (%if-expand r con alt)]
|
||||
[(_ (and r . r*) con alt) (%if-expand r (%if-expand (and . r*) con alt) alt)]
|
||||
[(_ (or) con alt) alt]
|
||||
[(_ (or r) con alt) (%if-expand r con alt)]
|
||||
[(_ (or r . r*) con alt) (%if-expand r con (%if-expand (or . r*) con alt))]
|
||||
[(_ (not r) con alt) (%if-expand r alt con)]
|
||||
[(_ (library l) con alt)
|
||||
(if-library-available l con alt)] ; macro defined later in t.scm
|
||||
[(_ (x . y) con alt)
|
||||
(syntax-error "unrecognized cond-expand feature requirement:" (x . y))]
|
||||
[(_ f con alt)
|
||||
(if-feature-available f con alt)])) ; macro defined later in t.scm
|
||||
|
||||
(define-syntax cond-expand
|
||||
(syntax-rules (else)
|
||||
[(_) (void)]
|
||||
[(_ [else . exps])
|
||||
(begin . exps)]
|
||||
[(_ [x] . rest)
|
||||
(%if-expand x (begin) (cond-expand . rest))]
|
||||
[(_ [x . exps] . rest)
|
||||
(%if-expand x (begin . exps) (cond-expand . rest))]))
|
||||
|
||||
|
||||
;---------------------------------------------------------------------------------------------
|
||||
; Delayed evaluation
|
||||
;---------------------------------------------------------------------------------------------
|
||||
|
|
|
|||
48
src/t.scm
48
src/t.scm
|
|
@ -325,6 +325,9 @@
|
|||
(define (x-error msg . args)
|
||||
(error* (string-append "transformer: " msg) args))
|
||||
|
||||
(define (check-syntax sexp pat msg)
|
||||
(unless (sexp-match? pat sexp) (x-error msg sexp)))
|
||||
|
||||
; xform receives Scheme s-expressions and returns either Core Scheme <core>
|
||||
; (always a pair) or special-form, which is either a builtin (a symbol) or
|
||||
; a transformer (a procedure). Appos? flag is true when the context can
|
||||
|
|
@ -606,7 +609,6 @@
|
|||
(apply x-error args)
|
||||
(x-error "improper syntax-error form" (cons 'syntax-error tail)))))
|
||||
|
||||
|
||||
; make transformer procedure from the rules
|
||||
|
||||
(define (syntax-rules* mac-env ellipsis pat-literals rules)
|
||||
|
|
@ -748,22 +750,38 @@
|
|||
(if (null? files)
|
||||
(cons begin-id (apply append (reverse! exp-lists)))
|
||||
(let* ([filepath (file-resolve-relative-to-current (car files))]
|
||||
[fileok? (and (string? filepath) (file-exists? filepath))]
|
||||
[test (if fileok? #t (x-error "cannot include" (car files) sexp))]
|
||||
[sexps (read-file-sexps filepath ci?)]
|
||||
[wrapped-sexps `((,push-cf-id ,filepath) ,@sexps (,pop-cf-id))])
|
||||
(loop (cdr files) (cons wrapped-sexps exp-lists)))))))
|
||||
|
||||
; return the right ce branch using (lit=? id sym) for literal match
|
||||
(define (preprocess-cond-expand lit=? sexp) ;=> (sexp ...)
|
||||
(define (pp freq con alt)
|
||||
(cond [(lit=? freq 'else) (con)]
|
||||
[(id? freq) (if (feature-available? (id->sym freq)) (con) (alt))]
|
||||
[(and (list2? freq) (lit=? (car freq) 'library))
|
||||
(if (library-available? (xform-sexp->datum (cadr freq))) (con) (alt))]
|
||||
[(and (list1+? freq) (lit=? (car freq) 'and))
|
||||
(cond [(null? (cdr freq)) (con)] [(null? (cddr freq)) (pp (cadr freq) con alt)]
|
||||
[else (pp (cadr freq) (lambda () (pp (cons (car freq) (cddr freq)) con alt)) alt)])]
|
||||
[(and (list1+? freq) (lit=? (car freq) 'or))
|
||||
(cond [(null? (cdr freq)) (alt)] [(null? (cddr freq)) (pp (cadr freq) con alt)]
|
||||
[else (pp (cadr freq) con (lambda () (pp (cons (car freq) (cddr freq)) con alt)))])]
|
||||
[(and (list2? freq) (lit=? (car freq) 'not)) (pp (cadr freq) alt con)]
|
||||
[else (x-error freq "invalid cond-expand feature requirement")]))
|
||||
(check-syntax sexp '(<id> (* * ...) ...) "invalid cond-expand syntax")
|
||||
(let loop ([clauses (cdr sexp)])
|
||||
(if (null? clauses) '()
|
||||
(pp (caar clauses) (lambda () (cdar clauses)) (lambda () (loop (cdr clauses)))))))
|
||||
|
||||
(define (if-feature-available-transformer sexp env)
|
||||
(if (and (list? sexp) (= (length sexp) 4))
|
||||
(let ([r (cadr sexp)] [con (caddr sexp)] [alt (cadddr sexp)])
|
||||
(if (feature-available? (xform-sexp->datum r)) con alt))
|
||||
(x-error "invalid syntax" sexp)))
|
||||
|
||||
(define (if-library-available-transformer sexp env)
|
||||
(if (and (list? sexp) (= (length sexp) 4))
|
||||
(let ([r (cadr sexp)] [con (caddr sexp)] [alt (cadddr sexp)])
|
||||
(if (library-available? (xform-sexp->datum r)) con alt))
|
||||
(x-error "invalid syntax" sexp)))
|
||||
(define (make-cond-expand-transformer)
|
||||
(define begin-id (new-id 'begin (make-location 'begin) #f))
|
||||
(lambda (sexp env)
|
||||
(define (lit=? id sym) ; match literal using free-id=? -like match
|
||||
(and (id? id) (eq? (xenv-ref env id) (xenv-ref root-environment sym))))
|
||||
(cons begin-id (preprocess-cond-expand lit=? sexp))))
|
||||
|
||||
|
||||
;---------------------------------------------------------------------------------------------
|
||||
|
|
@ -1525,11 +1543,9 @@
|
|||
(define-in-root-environment! 'include-ci
|
||||
(make-location (make-include-transformer #t)) #t)
|
||||
|
||||
(define-in-root-environment! 'if-feature-available
|
||||
(make-location if-feature-available-transformer) #t)
|
||||
(define-in-root-environment! 'cond-expand
|
||||
(make-location (make-cond-expand-transformer)) #t)
|
||||
|
||||
(define-in-root-environment! 'if-library-available
|
||||
(make-location if-library-available-transformer) #t)
|
||||
|
||||
; now put the builtins (lazily) and others
|
||||
|
||||
|
|
|
|||
47
t.c
47
t.c
|
|
@ -187,6 +187,9 @@ char *t_code[] = {
|
|||
"P", "x-error",
|
||||
"%!1.0,.2,'(s13:transformer: )S6,@(y6:error*)[22",
|
||||
|
||||
"P", "check-syntax",
|
||||
"%3${.2,.4,@(y11:sexp-match?)[02}~?{.0,.3,@(y7:x-error)[32}]3",
|
||||
|
||||
"P", "xform",
|
||||
"%3${.3,@(y3:id?)[01}?{${.4,.4,@(y9:xform-ref)[02},.1?{.0]4}.0U0?{.0U7,"
|
||||
"'(y3:ref),l2]4}.0K0?{.3,${.6,.6,.5[02},.3,@(y5:xform)[43}.0p~?{.0,'(s2"
|
||||
|
|
@ -401,20 +404,32 @@ char *t_code[] = {
|
|||
"{@(y17:pop-current-file!)[00}:0^,l1]2}.!2${f,.4^b,'(y7:push-cf),@(y6:n"
|
||||
"ew-id)[03}.!3${f,.5^b,'(y6:pop-cf),@(y6:new-id)[03}.!4.3,.5,.7,.3,&4{%"
|
||||
"2${.2,@(y7:list1+?)[01}~?{${.2,'(s14:invalid syntax),@(y7:x-error)[02}"
|
||||
"}n,.1d,,#0:3,:2,.2,:1,:0,&5{%2.0u?{${.3A9,@(y7:%25append),@(y13:apply-"
|
||||
"to-list)[02},:0^c]2}${.2a,@(y32:file-resolve-relative-to-current)[01},"
|
||||
"${:1,.3,@(y15:read-file-sexps)[02},n,n,:3^cc,.1L6,n,.3c,:4^cc,.4,.1c,."
|
||||
"4d,:2^[52}.!0.0^_1[22}]6",
|
||||
"}n,.1d,,#0.3,:3,:2,.3,:1,:0,&6{%2.0u?{${.3A9,@(y7:%25append),@(y13:app"
|
||||
"ly-to-list)[02},:0^c]2}${.2a,@(y32:file-resolve-relative-to-current)[0"
|
||||
"1},.0S0?{.0F0}{f},.0?{t}{${:5,.5a,'(s14:cannot include),@(y7:x-error)["
|
||||
"03}},${:1,.5,@(y15:read-file-sexps)[02},n,n,:3^cc,.1L6,n,.5c,:4^cc,.6,"
|
||||
".1c,.6d,:2^[72}.!0.0^_1[22}]6",
|
||||
|
||||
"P", "if-feature-available-transformer",
|
||||
"%2.0L0?{'4,.1g=}{f}?{.0ddda,.1dda,.2da,${${.4,@(y17:xform-sexp->datum)"
|
||||
"[01},@(y18:feature-available?)[01}?{.1]5}.2]5}.0,'(s14:invalid syntax)"
|
||||
",@(y7:x-error)[22",
|
||||
"P", "preprocess-cond-expand",
|
||||
"%2,#0.0,.2,&2{%3${'(y4:else),.3,:0[02}?{.1[30}${.2,@(y3:id?)[01}?{${${"
|
||||
".4,@(y7:id->sym)[01},@(y18:feature-available?)[01}?{.1[30}.2[30}${.2,@"
|
||||
"(y6:list2?)[01}?{${'(y7:library),.3a,:0[02}}{f}?{${${.4da,@(y17:xform-"
|
||||
"sexp->datum)[01},@(y18:library-available?)[01}?{.1[30}.2[30}${.2,@(y7:"
|
||||
"list1+?)[01}?{${'(y3:and),.3a,:0[02}}{f}?{.0du?{.1[30}.0ddu?{.2,.2,.2d"
|
||||
"a,:1^[33}.2,.3,.3,.3,:1,&4{%0:3,:2,:1dd,:1ac,:0^[03},.2da,:1^[33}${.2,"
|
||||
"@(y7:list1+?)[01}?{${'(y2:or),.3a,:0[02}}{f}?{.0du?{.2[30}.0ddu?{.2,.2"
|
||||
",.2da,:1^[33}.2,.2,.2,:1,&4{%0:3,:2,:1dd,:1ac,:0^[03},.2,.2da,:1^[33}$"
|
||||
"{.2,@(y6:list2?)[01}?{${'(y3:not),.3a,:0[02}}{f}?{.1,.3,.2da,:1^[33}'("
|
||||
"s39:invalid cond-expand feature requirement),.1,@(y7:x-error)[32}.!0${"
|
||||
"'(s26:invalid cond-expand syntax),'(l3:y4:<id>;l3:y1:*;y1:*;y3:...;;y3"
|
||||
":...;),.6,@(y12:check-syntax)[03}.2d,,#0.0,.3,&2{%1.0u?{n]1}.0,:1,&2{%"
|
||||
"0:1d,:0^[01},.1,&1{%0:0ad]0},.2aa,:0^[13}.!0.0^_1[31",
|
||||
|
||||
"P", "if-library-available-transformer",
|
||||
"%2.0L0?{'4,.1g=}{f}?{.0ddda,.1dda,.2da,${${.4,@(y17:xform-sexp->datum)"
|
||||
"[01},@(y18:library-available?)[01}?{.1]5}.2]5}.0,'(s14:invalid syntax)"
|
||||
",@(y7:x-error)[22",
|
||||
"P", "make-cond-expand-transformer",
|
||||
"%0,#0${f,'(y5:begin)b,'(y5:begin),@(y6:new-id)[03}.!0.0,&1{%2,#0.2,&1{"
|
||||
"%2${.2,@(y3:id?)[01}?{${.3,@(y16:root-environment),@(y8:xenv-ref)[02},"
|
||||
"${.3,:0,@(y8:xenv-ref)[02}q]2}f]2}.!0${.3,.3^,@(y22:preprocess-cond-ex"
|
||||
"pand)[02},:0^c]3}]1",
|
||||
|
||||
"P", "write-serialized-char",
|
||||
"%2'(c%25),.1C=,.0?{.0}{'(c%22),.2C=,.0?{.0}{'(c%5c),.3C=,.0?{.0}{'(c )"
|
||||
|
|
@ -808,12 +823,8 @@ char *t_code[] = {
|
|||
"efine-in-root-environment!)[03}",
|
||||
|
||||
"C", 0,
|
||||
"${t,@(y32:if-feature-available-transformer)b,'(y20:if-feature-availabl"
|
||||
"e),@(y27:define-in-root-environment!)[03}",
|
||||
|
||||
"C", 0,
|
||||
"${t,@(y32:if-library-available-transformer)b,'(y20:if-library-availabl"
|
||||
"e),@(y27:define-in-root-environment!)[03}",
|
||||
"${t,${@(y28:make-cond-expand-transformer)[00}b,'(y11:cond-expand),@(y2"
|
||||
"7:define-in-root-environment!)[03}",
|
||||
|
||||
"C", 0,
|
||||
"&0{%2t,.2,.2,@(y27:define-in-root-environment!)[23},${U1,,#0.0,.5,&2{%"
|
||||
|
|
|
|||
Loading…
Reference in a new issue