From 4f16f52ed6d9a71fd2a8258b4232402c43fb6b2d Mon Sep 17 00:00:00 2001 From: ESL Date: Wed, 24 Jul 2024 01:47:28 -0400 Subject: [PATCH] top forms scan factored out for reuse --- pre/t.scm | 115 ++++++++++++++++++++++++++++++------------------------ t.c | 60 ++++++++++++++++------------ 2 files changed, 98 insertions(+), 77 deletions(-) diff --git a/pre/t.scm b/pre/t.scm index 7b9ee4b..5fcf68e 100644 --- a/pre/t.scm +++ b/pre/t.scm @@ -1046,7 +1046,67 @@ (loop decls code eal esps `(,@forms (,include-ci-id . ,(cdr decl))))] [(eq? (car decl) ld-begin-id) (loop decls code eal esps (append forms (xform-sexp->datum (cdr decl))))])))))) - + +; scan forms and return reversed list of core forms, interspersed with (define gs exp) +; forms that need further processing (each one will become (set! gs core) form +(define (preprocess-top-forms-scan forms cenv env) ;=> code* in reverse order + (define (scan body code*) ;=> code* extended, with side-effect on cenv + (if (null? body) + code* + (let ([first (car body)] [rest (cdr body)]) + (if (pair? first) + (let* ([head (car first)] [tail (cdr first)] [hval (xform #t head cenv)]) + (cond + [(eq? hval 'begin) + (unless (list? tail) (x-error "improper begin form" first)) + (scan (append tail rest) code*)] ; splice + [(eq? hval 'define) + (let ([tail (preprocess-define head tail)]) + (if (list1? tail) ; tail is either (sexp) or (id sexp) + (scan (append tail rest) code*) ; idless, splice + (let ([loc (top-defined-id-lookup cenv (car tail) 'define)]) + (unless (and (location? loc) (sexp-match? '(ref *) (location-val loc))) + (x-error "unexpected define for id" (car tail) first)) + (let ([gs (cadr (location-val loc))] [exp (cadr tail)]) + ; exp expansiom is delayed until all defined ids are ready + (scan rest (cons (list 'define gs exp) code*))))))] + [(eq? hval 'define-syntax) + (let* ([tail (preprocess-define-syntax head tail)] + [loc (top-defined-id-lookup cenv (car tail) 'define-syntax)]) + (unless (location? loc) + (x-error "unexpected define-syntax for id" (car tail) first)) + (location-set-val! loc (xform #t (cadr tail) cenv)) + (scan rest code*))] + [(eq? hval 'define-library) + (let* ([core (xform-define-library head tail env #f)] + ; core is (define-library ) + [loc (xenv-lookup env (cadr core) 'define-syntax)]) + (unless (location? loc) + (x-error "unexpected define-library for id" (cadr core) first)) + (location-set-val! loc (caddr core)) + (scan rest code*))] + [(eq? hval 'import) ; support, in case there is an internal import + (let* ([core (xform-import head tail cenv #f)] + ; core is (import ) + [l (cadr core)] [code (library-code l)] [eal (library-exports l)]) + (unless (cenv eal 'import) ; adjoins eal to cenv's imports + (x-error "broken import inside library code" first)) + (scan rest (cons code code*)))] ; adds library init code + [(val-transformer? hval) ; apply transformer and loop + (scan (cons (hval first cenv) rest) code*)] + [else ; form expansion may need to be delayed + (scan rest (cons (list 'define '() first) code*))])) + ; form expansion may need to be delayed + (scan rest (cons (list 'define '() first) code*)))))) + (scan forms '())) + +; scan returns underprocessed defines; this fn fixes that +(define (preprocess-forms-fix-define! code cenv) ;=> core + (if (and (pair? code) (eq? (car code) 'define) (list3? code)) + (let* ([gs (cadr code)] [exp (caddr code)] [core (xform #f exp cenv)]) + (if (null? gs) core (list 'set! gs core))) + code)) + (define (preprocess-library sexp env) ;=> (init-core . exports-eal) ; generator of globals: use prefix or temporary if no prefix is given (define (make-nid id) @@ -1060,56 +1120,9 @@ [icimesfs (preprocess-library-declarations (cons (car sexp) decls) env)]) (let* ([code (car icimesfs)] [ial (cadr icimesfs)] [esps (caddr icimesfs)] [forms (cadddr icimesfs)] [cenv (make-controlled-environment ial make-nid env)] [eal '()]) ; m-c-e is defined below - (define (scan body code*) ;=> code* extended, with side-effect on cenv - (if (null? body) - code* - (let ([first (car body)] [rest (cdr body)]) - (if (pair? first) - (let* ([head (car first)] [tail (cdr first)] [hval (xform #t head cenv)]) - (cond - [(eq? hval 'begin) - (unless (list? tail) (x-error "improper begin form" first)) - (scan (append tail rest) code*)] ; splice - [(eq? hval 'define) - (let ([tail (preprocess-define head tail)]) - (if (list1? tail) ; tail is either (sexp) or (id sexp) - (scan (append tail rest) code*) ; idless, splice - (let ([loc (top-defined-id-lookup cenv (car tail) 'define)]) - (unless (and (location? loc) (sexp-match? '(ref *) (location-val loc))) - (x-error "unexpected define for id" (car tail) first)) - (let ([g (cadr (location-val loc))] [core (xform #f (cadr tail) cenv)]) - (scan rest (cons (list 'set! g core) code*))))))] - [(eq? hval 'define-syntax) - (let* ([tail (preprocess-define-syntax head tail)] - [loc (top-defined-id-lookup cenv (car tail) 'define-syntax)]) - (unless (location? loc) - (x-error "unexpected define-syntax for id" (car tail) first)) - (location-set-val! loc (xform #t (cadr tail) cenv)) - (scan rest code*))] - [(eq? hval 'define-library) - (let* ([core (xform-define-library head tail env #f)] - ; core is (define-library ) - [loc (xenv-lookup env (cadr core) 'define-syntax)]) - (unless (location? loc) - (x-error "unexpected define-library for id" (cadr core) first)) - (location-set-val! loc (caddr core)) - (scan rest code*))] - [(eq? hval 'import) ; support, in case there is an internal import - (let* ([core (xform-import head tail cenv #f)] - ; core is (import ) - [l (cadr core)] [code (library-code l)] [eal (library-exports l)]) - (unless (cenv eal 'import) ; adjoins eal to cenv's imports - (x-error "broken import inside library code" first)) - (scan rest (cons code code*)))] ; adds library init code - ; TODO: check for built-in (export) and modify eal! - [(val-transformer? hval) ; apply transformer and loop - (scan (cons (hval first cenv) rest) code*)] - [(val-integrable? hval) ; integrable application - (scan rest (cons (xform-integrable hval tail cenv) code*))] - [else ; other specials and calls (xform does not return libraries) - (scan rest (cons (xform #f first cenv) code*))])) - (scan rest (cons (xform #f first cenv) code*)))))) - (let* ([code* (scan forms '())] [forms-code (cons 'begin (reverse! code*))] + (let* ([code* (preprocess-top-forms-scan forms cenv env)] + [fix! (lambda (code) (preprocess-forms-fix-define! code cenv))] + [forms-code (cons 'begin (map fix! (reverse! code*)))] [combined-code (adjoin-code code (if lid (list 'once lid forms-code) forms-code))]) ; walk through esps, fetching locations from cenv (let loop ([esps esps] [eal eal]) diff --git a/t.c b/t.c index 7fe6a35..cc27df3 100644 --- a/t.c +++ b/t.c @@ -613,6 +613,31 @@ char *t_code[] = { ".1aq?{${.2d,@(y17:xform-sexp->datum)[01},.7L6,.6,.6,.6,.5,:0^[75}f]7}." "!0.0^_1[(i17)5", + "P", "preprocess-top-forms-scan", + "%3,#0.2,.4,.2,&3{%2.0u?{.1]2}.0d,.1a,.0p?{.0a,.1d,${:2,.4,t,@(y5:xform" + ")[03},'(y5:begin),.1q?{.1L0~?{${.5,'(s19:improper begin form),@(y7:x-e" + "rror)[02}}.6,.5,.3L6,:0^[72}'(y6:define),.1q?{${.3,.5,@(y17:preprocess" + "-define)[02},${.2,@(y6:list1?)[01}?{.7,.6,.2L6,:0^[82}${'(y6:define),." + "3a,:2,@(y21:top-defined-id-lookup)[03},.0Y2?{${.2z,'(l2:y3:ref;y1:*;)," + "@(y11:sexp-match?)[02}}{f}~?{${.7,.4a,'(s24:unexpected define for id)," + "@(y7:x-error)[03}}.1da,.1zda,.(i10),.2,.2,'(y6:define),l3c,.9,:0^[(i11" + ")2}'(y13:define-syntax),.1q?{${.3,.5,@(y24:preprocess-define-syntax)[0" + "2},${'(y13:define-syntax),.3a,:2,@(y21:top-defined-id-lookup)[03},.0Y2" + "~?{${.7,.4a,'(s31:unexpected define-syntax for id),@(y7:x-error)[03}}$" + "{:2,.4da,t,@(y5:xform)[03},.1sz.8,.7,:0^[92}'(y14:define-library),.1q?" + "{${f,:1,.5,.7,@(y20:xform-define-library)[04},${'(y13:define-syntax),." + "3da,:1,@(y11:xenv-lookup)[03},.0Y2~?{${.7,.4da,'(s32:unexpected define" + "-library for id),@(y7:x-error)[03}}.1dda,.1sz.8,.7,:0^[92}'(y6:import)" + ",.1q?{${f,:2,.5,.7,@(y12:xform-import)[04},.0da,'0,.1V4,'1,.2V4,${'(y6" + ":import),.3,:2[02}~?{${.9,'(s33:broken import inside library code),@(y" + "7:x-error)[02}}.(i10),.2c,.9,:0^[(i11)2}.0K0?{.6,.5,${:2,.8,.6[02}c,:0" + "^[72}.6,.4,n,'(y6:define),l3c,.5,:0^[72}.3,.1,n,'(y6:define),l3c,.2,:0" + "^[42}.!0n,.2,.2^[42", + + "P", "preprocess-forms-fix-define!", + "%2.0p?{'(y6:define),.1aq?{${.2,@(y6:list3?)[01}}{f}}{f}?{.0da,.1dda,${" + ".5,.3,f,@(y5:xform)[03},.2u?{.0]5}.0,.3,'(y4:set!),l3]5}.0]2", + "P", "preprocess-library", "%2,#0.1,&1{%1${:0,@(y7:list2+?)[01}?{${:0da,@(y3:id?)[01}}{f}?{${.2,@(" "y7:id->sym)[01},${:0da,@(y7:id->sym)[01},@(y37:fully-qualified-library" @@ -621,32 +646,15 @@ char *t_code[] = { "03}${.3,@(y7:list2+?)[01}?{${.3da,@(y3:id?)[01}}{f}?{${.3da,@(y7:id->s" "ym)[01}}{f},.0?{.2dd}{.2d},${.6,.3,.7ac,@(y31:preprocess-library-decla" "rations)[02},.0a,.1da,.2dda,.3ddda,${.(i11),.(i10)^,.6,@(y27:make-cont" - "rolled-environment)[03},n,,#0.(i12),.1,.4,&3{%2.0u?{.1]2}.0d,.1a,.0p?{" - ".0a,.1d,${:0,.4,t,@(y5:xform)[03},'(y5:begin),.1q?{.1L0~?{${.5,'(s19:i" - "mproper begin form),@(y7:x-error)[02}}.6,.5,.3L6,:1^[72}'(y6:define),." - "1q?{${.3,.5,@(y17:preprocess-define)[02},${.2,@(y6:list1?)[01}?{.7,.6," - ".2L6,:1^[82}${'(y6:define),.3a,:0,@(y21:top-defined-id-lookup)[03},.0Y" - "2?{${.2z,'(l2:y3:ref;y1:*;),@(y11:sexp-match?)[02}}{f}~?{${.7,.4a,'(s2" - "4:unexpected define for id),@(y7:x-error)[03}}${:0,.4da,f,@(y5:xform)[" - "03},.1zda,.(i10),.2,.2,'(y4:set!),l3c,.9,:1^[(i11)2}'(y13:define-synta" - "x),.1q?{${.3,.5,@(y24:preprocess-define-syntax)[02},${'(y13:define-syn" - "tax),.3a,:0,@(y21:top-defined-id-lookup)[03},.0Y2~?{${.7,.4a,'(s31:une" - "xpected define-syntax for id),@(y7:x-error)[03}}${:0,.4da,t,@(y5:xform" - ")[03},.1sz.8,.7,:1^[92}'(y14:define-library),.1q?{${f,:2,.5,.7,@(y20:x" - "form-define-library)[04},${'(y13:define-syntax),.3da,:2,@(y11:xenv-loo" - "kup)[03},.0Y2~?{${.7,.4da,'(s32:unexpected define-library for id),@(y7" - ":x-error)[03}}.1dda,.1sz.8,.7,:1^[92}'(y6:import),.1q?{${f,:0,.5,.7,@(" - "y12:xform-import)[04},.0da,'0,.1V4,'1,.2V4,${'(y6:import),.3,:0[02}~?{" - "${.9,'(s33:broken import inside library code),@(y7:x-error)[02}}.(i10)" - ",.2c,.9,:1^[(i11)2}.0K0?{.6,.5,${:0,.8,.6[02}c,:1^[72}.0U0?{.6,${:0,.5" - ",.5,@(y16:xform-integrable)[03}c,.5,:1^[72}.6,${:0,.7,f,@(y5:xform)[03" - "}c,.5,:1^[72}.3,${:0,.4,f,@(y5:xform)[03}c,.2,:1^[42}.!0${n,.6,.4^[02}" - ",.0A9,'(y5:begin)c,${.(i13)?{.2,.(i14),'(y4:once),l3}{.2},.(i11),@(y11" - ":adjoin-code)[02},.4,.8,,#0.8,.1,.5,&3{%2.0u?{.1A9,:0c]2}.0aa,.1ad,${'" - "(y3:ref),.4,:2[02},.0~?{.2,'(s16:cannot export id),@(y7:x-error)[52}${" - ".2,@(y17:location-special?)[01}?{.4,.1,.3cc,.4d,:1^[52}.0z,.0p~,.0?{.0" - "}{'(l2:y3:ref;y5:const;),.2aA0}_1?{.5,.2,.4cc,.5d,:1^[62}.0,.4,'(s27:c" - "annot export code alias id),@(y7:x-error)[63}.!0.0^_1[(i16)2", + "rolled-environment)[03},n,${.(i13),.4,.6,@(y25:preprocess-top-forms-sc" + "an)[03},.2,&1{%1:0,.1,@(y28:preprocess-forms-fix-define!)[12},${.3A9,." + "3,@(y5:%25map1)[02},'(y5:begin)c,${.(i13)?{.2,.(i14),'(y4:once),l3}{.2" + "},.(i11),@(y11:adjoin-code)[02},.4,.8,,#0.8,.1,.5,&3{%2.0u?{.1A9,:0c]2" + "}.0aa,.1ad,${'(y3:ref),.4,:2[02},.0~?{.2,'(s16:cannot export id),@(y7:" + "x-error)[52}${.2,@(y17:location-special?)[01}?{.4,.1,.3cc,.4d,:1^[52}." + "0z,.0p~,.0?{.0}{'(l2:y3:ref;y5:const;),.2aA0}_1?{.5,.2,.4cc,.5d,:1^[62" + "}.0,.4,'(s27:cannot export code alias id),@(y7:x-error)[63}.!0.0^_1[(i" + "16)2", "P", "xform-define-library", "%4${.3,@(y7:list2+?)[01}?{${.3a,@(y9:listname?)[01}}{f}?{${.3a,@(y17:x"