From d4f6ef3451a2c4c25e5dafc2f1d3b5da4d970d93 Mon Sep 17 00:00:00 2001 From: ESL Date: Wed, 3 Jul 2024 18:47:26 -0400 Subject: [PATCH] include, cond-expand redone; minor fixes --- i.c | 14 +++++++++----- s.c | 33 +++++---------------------------- src/s.scm | 31 +++---------------------------- src/t.scm | 48 ++++++++++++++++++++++++++++++++---------------- t.c | 47 +++++++++++++++++++++++++++++------------------ 5 files changed, 78 insertions(+), 95 deletions(-) diff --git a/i.c b/i.c index ddd2353..0f6dedd 100644 --- a/i.c +++ b/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)); diff --git a/s.c b/s.c index 98c20aa..159c486 100644 --- a/s.c +++ b/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?)", diff --git a/src/s.scm b/src/s.scm index 85bc620..2df4e3e 100644 --- a/src/s.scm +++ b/src/s.scm @@ -26,7 +26,8 @@ ; (define-syntax kw form) ; (syntax-lambda (id ...) form ...) ; (syntax-rules (lit ...) [pat templ] ...) -; (syntax-rules ellipsis (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 ;--------------------------------------------------------------------------------------------- diff --git a/src/t.scm b/src/t.scm index 23a4efb..6e2de7c 100644 --- a/src/t.scm +++ b/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 ; (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 '( (* * ...) ...) "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 diff --git a/t.c b/t.c index 742214f..9a66271 100644 --- a/t.c +++ b/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:;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{%"