psyntax-pp.scm 166 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548154915501551155215531554155515561557155815591560156115621563156415651566156715681569157015711572157315741575157615771578157915801581158215831584158515861587158815891590159115921593159415951596159715981599160016011602160316041605160616071608160916101611161216131614161516161617161816191620162116221623162416251626162716281629163016311632163316341635163616371638163916401641164216431644164516461647164816491650165116521653165416551656165716581659166016611662166316641665166616671668166916701671167216731674167516761677167816791680168116821683168416851686168716881689169016911692169316941695169616971698169917001701170217031704170517061707170817091710171117121713171417151716171717181719172017211722172317241725172617271728172917301731173217331734173517361737173817391740174117421743174417451746174717481749175017511752175317541755175617571758175917601761176217631764176517661767176817691770177117721773177417751776177717781779178017811782178317841785178617871788178917901791179217931794179517961797179817991800180118021803180418051806180718081809181018111812181318141815181618171818181918201821182218231824182518261827182818291830183118321833183418351836183718381839184018411842184318441845184618471848184918501851185218531854185518561857185818591860186118621863186418651866186718681869187018711872187318741875187618771878187918801881188218831884188518861887188818891890189118921893189418951896189718981899190019011902190319041905190619071908190919101911191219131914191519161917191819191920192119221923192419251926192719281929193019311932193319341935193619371938193919401941194219431944194519461947194819491950195119521953195419551956195719581959196019611962196319641965196619671968196919701971197219731974197519761977197819791980198119821983198419851986198719881989199019911992199319941995199619971998199920002001200220032004200520062007200820092010201120122013201420152016201720182019202020212022202320242025202620272028202920302031203220332034203520362037203820392040204120422043204420452046204720482049205020512052205320542055205620572058205920602061206220632064206520662067206820692070207120722073207420752076207720782079208020812082208320842085208620872088208920902091209220932094209520962097209820992100210121022103210421052106210721082109211021112112211321142115211621172118211921202121212221232124212521262127212821292130213121322133213421352136213721382139214021412142214321442145214621472148214921502151215221532154215521562157215821592160216121622163216421652166216721682169217021712172217321742175217621772178217921802181218221832184218521862187218821892190219121922193219421952196219721982199220022012202220322042205220622072208220922102211221222132214221522162217221822192220222122222223222422252226222722282229223022312232223322342235223622372238223922402241224222432244224522462247224822492250225122522253225422552256225722582259226022612262226322642265226622672268226922702271227222732274227522762277227822792280228122822283228422852286228722882289229022912292229322942295229622972298229923002301230223032304230523062307230823092310231123122313231423152316231723182319232023212322232323242325232623272328232923302331233223332334233523362337233823392340234123422343234423452346234723482349235023512352235323542355235623572358235923602361236223632364236523662367236823692370237123722373237423752376237723782379238023812382238323842385238623872388238923902391239223932394239523962397239823992400240124022403240424052406240724082409241024112412241324142415241624172418241924202421242224232424242524262427242824292430243124322433243424352436243724382439244024412442244324442445244624472448244924502451245224532454245524562457245824592460246124622463246424652466246724682469247024712472247324742475247624772478247924802481248224832484248524862487248824892490249124922493249424952496249724982499250025012502250325042505250625072508250925102511251225132514251525162517251825192520252125222523252425252526252725282529253025312532253325342535253625372538253925402541254225432544254525462547254825492550255125522553255425552556255725582559256025612562256325642565256625672568256925702571257225732574257525762577257825792580258125822583258425852586258725882589259025912592259325942595259625972598259926002601260226032604260526062607260826092610261126122613261426152616261726182619262026212622262326242625262626272628262926302631263226332634263526362637263826392640264126422643264426452646264726482649265026512652265326542655265626572658265926602661266226632664266526662667266826692670267126722673267426752676267726782679268026812682268326842685268626872688268926902691269226932694269526962697269826992700270127022703270427052706270727082709271027112712271327142715271627172718271927202721272227232724272527262727272827292730273127322733273427352736273727382739274027412742274327442745274627472748274927502751275227532754275527562757275827592760276127622763276427652766276727682769277027712772277327742775277627772778277927802781278227832784278527862787278827892790279127922793279427952796279727982799280028012802280328042805280628072808280928102811281228132814281528162817281828192820282128222823282428252826282728282829283028312832283328342835283628372838283928402841284228432844284528462847284828492850285128522853285428552856285728582859286028612862286328642865286628672868286928702871287228732874287528762877287828792880288128822883288428852886288728882889289028912892289328942895289628972898289929002901290229032904290529062907290829092910291129122913291429152916291729182919292029212922292329242925292629272928292929302931293229332934293529362937293829392940294129422943294429452946294729482949295029512952295329542955295629572958295929602961296229632964296529662967296829692970297129722973297429752976297729782979298029812982298329842985298629872988298929902991299229932994299529962997299829993000300130023003300430053006300730083009301030113012301330143015301630173018301930203021302230233024302530263027302830293030303130323033303430353036303730383039304030413042304330443045304630473048304930503051305230533054305530563057305830593060306130623063306430653066306730683069307030713072307330743075307630773078307930803081308230833084308530863087308830893090309130923093309430953096309730983099310031013102310331043105310631073108310931103111311231133114311531163117311831193120312131223123312431253126312731283129313031313132313331343135313631373138313931403141314231433144314531463147314831493150315131523153315431553156315731583159316031613162316331643165316631673168316931703171317231733174317531763177317831793180318131823183318431853186318731883189319031913192319331943195319631973198319932003201320232033204320532063207320832093210321132123213321432153216321732183219322032213222322332243225322632273228322932303231323232333234323532363237323832393240324132423243324432453246324732483249325032513252325332543255325632573258325932603261326232633264326532663267326832693270327132723273327432753276327732783279328032813282328332843285328632873288328932903291329232933294329532963297329832993300330133023303330433053306330733083309331033113312331333143315331633173318331933203321332233233324332533263327332833293330333133323333333433353336333733383339334033413342334333443345334633473348334933503351335233533354335533563357335833593360336133623363336433653366336733683369337033713372337333743375337633773378337933803381338233833384338533863387338833893390339133923393339433953396339733983399340034013402340334043405340634073408340934103411341234133414341534163417341834193420342134223423342434253426
  1. (eval-when (compile) (set-current-module (resolve-module (quote (guile)))))
  2. (if #f #f)
  3. (letrec*
  4. ((make-void
  5. (lambda (src) (make-struct (vector-ref %expanded-vtables 0) 0 src)))
  6. (make-const
  7. (lambda (src exp)
  8. (make-struct (vector-ref %expanded-vtables 1) 0 src exp)))
  9. (make-primitive-ref
  10. (lambda (src name)
  11. (make-struct (vector-ref %expanded-vtables 2) 0 src name)))
  12. (make-lexical-ref
  13. (lambda (src name gensym)
  14. (make-struct (vector-ref %expanded-vtables 3) 0 src name gensym)))
  15. (make-lexical-set
  16. (lambda (src name gensym exp)
  17. (make-struct (vector-ref %expanded-vtables 4) 0 src name gensym exp)))
  18. (make-module-ref
  19. (lambda (src mod name public?)
  20. (make-struct (vector-ref %expanded-vtables 5) 0 src mod name public?)))
  21. (make-module-set
  22. (lambda (src mod name public? exp)
  23. (make-struct
  24. (vector-ref %expanded-vtables 6)
  25. 0
  26. src
  27. mod
  28. name
  29. public?
  30. exp)))
  31. (make-toplevel-ref
  32. (lambda (src name)
  33. (make-struct (vector-ref %expanded-vtables 7) 0 src name)))
  34. (make-toplevel-set
  35. (lambda (src name exp)
  36. (make-struct (vector-ref %expanded-vtables 8) 0 src name exp)))
  37. (make-toplevel-define
  38. (lambda (src name exp)
  39. (make-struct (vector-ref %expanded-vtables 9) 0 src name exp)))
  40. (make-conditional
  41. (lambda (src test consequent alternate)
  42. (make-struct
  43. (vector-ref %expanded-vtables 10)
  44. 0
  45. src
  46. test
  47. consequent
  48. alternate)))
  49. (make-call
  50. (lambda (src proc args)
  51. (make-struct (vector-ref %expanded-vtables 11) 0 src proc args)))
  52. (make-primcall
  53. (lambda (src name args)
  54. (make-struct (vector-ref %expanded-vtables 12) 0 src name args)))
  55. (make-seq
  56. (lambda (src head tail)
  57. (make-struct (vector-ref %expanded-vtables 13) 0 src head tail)))
  58. (make-lambda
  59. (lambda (src meta body)
  60. (make-struct (vector-ref %expanded-vtables 14) 0 src meta body)))
  61. (make-lambda-case
  62. (lambda (src req opt rest kw inits gensyms body alternate)
  63. (make-struct
  64. (vector-ref %expanded-vtables 15)
  65. 0
  66. src
  67. req
  68. opt
  69. rest
  70. kw
  71. inits
  72. gensyms
  73. body
  74. alternate)))
  75. (make-let
  76. (lambda (src names gensyms vals body)
  77. (make-struct
  78. (vector-ref %expanded-vtables 16)
  79. 0
  80. src
  81. names
  82. gensyms
  83. vals
  84. body)))
  85. (make-letrec
  86. (lambda (src in-order? names gensyms vals body)
  87. (make-struct
  88. (vector-ref %expanded-vtables 17)
  89. 0
  90. src
  91. in-order?
  92. names
  93. gensyms
  94. vals
  95. body)))
  96. (lambda?
  97. (lambda (x)
  98. (and (struct? x)
  99. (eq? (struct-vtable x) (vector-ref %expanded-vtables 14)))))
  100. (lambda-meta (lambda (x) (struct-ref x 1)))
  101. (set-lambda-meta! (lambda (x v) (struct-set! x 1 v)))
  102. (top-level-eval-hook (lambda (x mod) (primitive-eval x)))
  103. (local-eval-hook (lambda (x mod) (primitive-eval x)))
  104. (session-id
  105. (let ((v (module-variable (current-module) 'syntax-session-id)))
  106. (lambda () ((variable-ref v)))))
  107. (put-global-definition-hook
  108. (lambda (symbol type val)
  109. (module-define!
  110. (current-module)
  111. symbol
  112. (make-syntax-transformer symbol type val))))
  113. (get-global-definition-hook
  114. (lambda (symbol module)
  115. (if (and (not module) (current-module))
  116. (warn "module system is booted, we should have a module" symbol))
  117. (and (not (equal? module '(primitive)))
  118. (let ((v (module-variable
  119. (if module (resolve-module (cdr module)) (current-module))
  120. symbol)))
  121. (and v
  122. (variable-bound? v)
  123. (let ((val (variable-ref v)))
  124. (and (macro? val)
  125. (macro-type val)
  126. (cons (macro-type val) (macro-binding val)))))))))
  127. (decorate-source
  128. (lambda (e s)
  129. (if (and s (supports-source-properties? e))
  130. (set-source-properties! e s))
  131. e))
  132. (maybe-name-value!
  133. (lambda (name val)
  134. (if (lambda? val)
  135. (let ((meta (lambda-meta val)))
  136. (if (not (assq 'name meta))
  137. (set-lambda-meta! val (acons 'name name meta)))))))
  138. (build-void (lambda (source) (make-void source)))
  139. (build-call
  140. (lambda (source fun-exp arg-exps)
  141. (make-call source fun-exp arg-exps)))
  142. (build-conditional
  143. (lambda (source test-exp then-exp else-exp)
  144. (make-conditional source test-exp then-exp else-exp)))
  145. (build-lexical-reference
  146. (lambda (type source name var) (make-lexical-ref source name var)))
  147. (build-lexical-assignment
  148. (lambda (source name var exp)
  149. (maybe-name-value! name exp)
  150. (make-lexical-set source name var exp)))
  151. (analyze-variable
  152. (lambda (mod var modref-cont bare-cont)
  153. (if (not mod)
  154. (bare-cont var)
  155. (let ((kind (car mod)) (mod (cdr mod)))
  156. (let ((key kind))
  157. (cond ((memv key '(public)) (modref-cont mod var #t))
  158. ((memv key '(private))
  159. (if (not (equal? mod (module-name (current-module))))
  160. (modref-cont mod var #f)
  161. (bare-cont var)))
  162. ((memv key '(bare)) (bare-cont var))
  163. ((memv key '(hygiene))
  164. (if (and (not (equal? mod (module-name (current-module))))
  165. (module-variable (resolve-module mod) var))
  166. (modref-cont mod var #f)
  167. (bare-cont var)))
  168. ((memv key '(primitive))
  169. (syntax-violation #f "primitive not in operator position" var))
  170. (else (syntax-violation #f "bad module kind" var mod))))))))
  171. (build-global-reference
  172. (lambda (source var mod)
  173. (analyze-variable
  174. mod
  175. var
  176. (lambda (mod var public?) (make-module-ref source mod var public?))
  177. (lambda (var) (make-toplevel-ref source var)))))
  178. (build-global-assignment
  179. (lambda (source var exp mod)
  180. (maybe-name-value! var exp)
  181. (analyze-variable
  182. mod
  183. var
  184. (lambda (mod var public?)
  185. (make-module-set source mod var public? exp))
  186. (lambda (var) (make-toplevel-set source var exp)))))
  187. (build-global-definition
  188. (lambda (source var exp)
  189. (maybe-name-value! var exp)
  190. (make-toplevel-define source var exp)))
  191. (build-simple-lambda
  192. (lambda (src req rest vars meta exp)
  193. (make-lambda
  194. src
  195. meta
  196. (make-lambda-case src req #f rest #f '() vars exp #f))))
  197. (build-case-lambda
  198. (lambda (src meta body) (make-lambda src meta body)))
  199. (build-lambda-case
  200. (lambda (src req opt rest kw inits vars body else-case)
  201. (make-lambda-case src req opt rest kw inits vars body else-case)))
  202. (build-primcall
  203. (lambda (src name args) (make-primcall src name args)))
  204. (build-primref (lambda (src name) (make-primitive-ref src name)))
  205. (build-data (lambda (src exp) (make-const src exp)))
  206. (build-sequence
  207. (lambda (src exps)
  208. (if (null? (cdr exps))
  209. (car exps)
  210. (make-seq src (car exps) (build-sequence #f (cdr exps))))))
  211. (build-let
  212. (lambda (src ids vars val-exps body-exp)
  213. (for-each maybe-name-value! ids val-exps)
  214. (if (null? vars) body-exp (make-let src ids vars val-exps body-exp))))
  215. (build-named-let
  216. (lambda (src ids vars val-exps body-exp)
  217. (let ((f (car vars)) (f-name (car ids)) (vars (cdr vars)) (ids (cdr ids)))
  218. (let ((proc (build-simple-lambda src ids #f vars '() body-exp)))
  219. (maybe-name-value! f-name proc)
  220. (for-each maybe-name-value! ids val-exps)
  221. (make-letrec
  222. src
  223. #f
  224. (list f-name)
  225. (list f)
  226. (list proc)
  227. (build-call src (build-lexical-reference 'fun src f-name f) val-exps))))))
  228. (build-letrec
  229. (lambda (src in-order? ids vars val-exps body-exp)
  230. (if (null? vars)
  231. body-exp
  232. (begin
  233. (for-each maybe-name-value! ids val-exps)
  234. (make-letrec src in-order? ids vars val-exps body-exp)))))
  235. (make-syntax-object
  236. (lambda (expression wrap module)
  237. (vector 'syntax-object expression wrap module)))
  238. (syntax-object?
  239. (lambda (x)
  240. (and (vector? x)
  241. (= (vector-length x) 4)
  242. (eq? (vector-ref x 0) 'syntax-object))))
  243. (syntax-object-expression (lambda (x) (vector-ref x 1)))
  244. (syntax-object-wrap (lambda (x) (vector-ref x 2)))
  245. (syntax-object-module (lambda (x) (vector-ref x 3)))
  246. (set-syntax-object-expression!
  247. (lambda (x update) (vector-set! x 1 update)))
  248. (set-syntax-object-wrap!
  249. (lambda (x update) (vector-set! x 2 update)))
  250. (set-syntax-object-module!
  251. (lambda (x update) (vector-set! x 3 update)))
  252. (source-annotation
  253. (lambda (x)
  254. (let ((props (source-properties
  255. (if (syntax-object? x) (syntax-object-expression x) x))))
  256. (and (pair? props) props))))
  257. (extend-env
  258. (lambda (labels bindings r)
  259. (if (null? labels)
  260. r
  261. (extend-env
  262. (cdr labels)
  263. (cdr bindings)
  264. (cons (cons (car labels) (car bindings)) r)))))
  265. (extend-var-env
  266. (lambda (labels vars r)
  267. (if (null? labels)
  268. r
  269. (extend-var-env
  270. (cdr labels)
  271. (cdr vars)
  272. (cons (cons (car labels) (cons 'lexical (car vars))) r)))))
  273. (macros-only-env
  274. (lambda (r)
  275. (if (null? r)
  276. '()
  277. (let ((a (car r)))
  278. (if (memq (cadr a) '(macro syntax-parameter ellipsis))
  279. (cons a (macros-only-env (cdr r)))
  280. (macros-only-env (cdr r)))))))
  281. (global-extend
  282. (lambda (type sym val) (put-global-definition-hook sym type val)))
  283. (nonsymbol-id?
  284. (lambda (x)
  285. (and (syntax-object? x) (symbol? (syntax-object-expression x)))))
  286. (id? (lambda (x)
  287. (if (symbol? x)
  288. #t
  289. (and (syntax-object? x) (symbol? (syntax-object-expression x))))))
  290. (id-sym-name&marks
  291. (lambda (x w)
  292. (if (syntax-object? x)
  293. (values
  294. (syntax-object-expression x)
  295. (join-marks (car w) (car (syntax-object-wrap x))))
  296. (values x (car w)))))
  297. (gen-label
  298. (lambda ()
  299. (string-append "l-" (session-id) (symbol->string (gensym "-")))))
  300. (gen-labels
  301. (lambda (ls)
  302. (if (null? ls) '() (cons (gen-label) (gen-labels (cdr ls))))))
  303. (make-ribcage
  304. (lambda (symnames marks labels)
  305. (vector 'ribcage symnames marks labels)))
  306. (ribcage?
  307. (lambda (x)
  308. (and (vector? x)
  309. (= (vector-length x) 4)
  310. (eq? (vector-ref x 0) 'ribcage))))
  311. (ribcage-symnames (lambda (x) (vector-ref x 1)))
  312. (ribcage-marks (lambda (x) (vector-ref x 2)))
  313. (ribcage-labels (lambda (x) (vector-ref x 3)))
  314. (set-ribcage-symnames! (lambda (x update) (vector-set! x 1 update)))
  315. (set-ribcage-marks! (lambda (x update) (vector-set! x 2 update)))
  316. (set-ribcage-labels! (lambda (x update) (vector-set! x 3 update)))
  317. (anti-mark
  318. (lambda (w) (cons (cons #f (car w)) (cons 'shift (cdr w)))))
  319. (extend-ribcage!
  320. (lambda (ribcage id label)
  321. (set-ribcage-symnames!
  322. ribcage
  323. (cons (syntax-object-expression id) (ribcage-symnames ribcage)))
  324. (set-ribcage-marks!
  325. ribcage
  326. (cons (car (syntax-object-wrap id)) (ribcage-marks ribcage)))
  327. (set-ribcage-labels! ribcage (cons label (ribcage-labels ribcage)))))
  328. (make-binding-wrap
  329. (lambda (ids labels w)
  330. (if (null? ids)
  331. w
  332. (cons (car w)
  333. (cons (let* ((labelvec (list->vector labels)) (n (vector-length labelvec)))
  334. (let ((symnamevec (make-vector n)) (marksvec (make-vector n)))
  335. (let f ((ids ids) (i 0))
  336. (if (not (null? ids))
  337. (call-with-values
  338. (lambda () (id-sym-name&marks (car ids) w))
  339. (lambda (symname marks)
  340. (vector-set! symnamevec i symname)
  341. (vector-set! marksvec i marks)
  342. (f (cdr ids) (+ i 1))))))
  343. (make-ribcage symnamevec marksvec labelvec)))
  344. (cdr w))))))
  345. (smart-append (lambda (m1 m2) (if (null? m2) m1 (append m1 m2))))
  346. (join-wraps
  347. (lambda (w1 w2)
  348. (let ((m1 (car w1)) (s1 (cdr w1)))
  349. (if (null? m1)
  350. (if (null? s1) w2 (cons (car w2) (smart-append s1 (cdr w2))))
  351. (cons (smart-append m1 (car w2)) (smart-append s1 (cdr w2)))))))
  352. (join-marks (lambda (m1 m2) (smart-append m1 m2)))
  353. (same-marks?
  354. (lambda (x y)
  355. (or (eq? x y)
  356. (and (not (null? x))
  357. (not (null? y))
  358. (eq? (car x) (car y))
  359. (same-marks? (cdr x) (cdr y))))))
  360. (id-var-name
  361. (lambda (id w mod)
  362. (letrec*
  363. ((search
  364. (lambda (sym subst marks mod)
  365. (if (null? subst)
  366. (values #f marks)
  367. (let ((fst (car subst)))
  368. (if (eq? fst 'shift)
  369. (search sym (cdr subst) (cdr marks) mod)
  370. (let ((symnames (ribcage-symnames fst)))
  371. (if (vector? symnames)
  372. (search-vector-rib sym subst marks symnames fst mod)
  373. (search-list-rib sym subst marks symnames fst mod))))))))
  374. (search-list-rib
  375. (lambda (sym subst marks symnames ribcage mod)
  376. (let f ((symnames symnames) (i 0))
  377. (cond ((null? symnames) (search sym (cdr subst) marks mod))
  378. ((and (eq? (car symnames) sym)
  379. (same-marks? marks (list-ref (ribcage-marks ribcage) i)))
  380. (let ((n (list-ref (ribcage-labels ribcage) i)))
  381. (if (pair? n)
  382. (if (equal? mod (car n))
  383. (values (cdr n) marks)
  384. (f (cdr symnames) (+ i 1)))
  385. (values n marks))))
  386. (else (f (cdr symnames) (+ i 1)))))))
  387. (search-vector-rib
  388. (lambda (sym subst marks symnames ribcage mod)
  389. (let ((n (vector-length symnames)))
  390. (let f ((i 0))
  391. (cond ((= i n) (search sym (cdr subst) marks mod))
  392. ((and (eq? (vector-ref symnames i) sym)
  393. (same-marks? marks (vector-ref (ribcage-marks ribcage) i)))
  394. (let ((n (vector-ref (ribcage-labels ribcage) i)))
  395. (if (pair? n)
  396. (if (equal? mod (car n)) (values (cdr n) marks) (f (+ i 1)))
  397. (values n marks))))
  398. (else (f (+ i 1)))))))))
  399. (cond ((symbol? id) (or (search id (cdr w) (car w) mod) id))
  400. ((syntax-object? id)
  401. (let ((id (syntax-object-expression id))
  402. (w1 (syntax-object-wrap id))
  403. (mod (syntax-object-module id)))
  404. (let ((marks (join-marks (car w) (car w1))))
  405. (call-with-values
  406. (lambda () (search id (cdr w) marks mod))
  407. (lambda (new-id marks) (or new-id (search id (cdr w1) marks mod) id))))))
  408. (else (syntax-violation 'id-var-name "invalid id" id))))))
  409. (locally-bound-identifiers
  410. (lambda (w mod)
  411. (letrec*
  412. ((scan (lambda (subst results)
  413. (if (null? subst)
  414. results
  415. (let ((fst (car subst)))
  416. (if (eq? fst 'shift)
  417. (scan (cdr subst) results)
  418. (let ((symnames (ribcage-symnames fst)) (marks (ribcage-marks fst)))
  419. (if (vector? symnames)
  420. (scan-vector-rib subst symnames marks results)
  421. (scan-list-rib subst symnames marks results))))))))
  422. (scan-list-rib
  423. (lambda (subst symnames marks results)
  424. (let f ((symnames symnames) (marks marks) (results results))
  425. (if (null? symnames)
  426. (scan (cdr subst) results)
  427. (f (cdr symnames)
  428. (cdr marks)
  429. (cons (wrap (car symnames) (anti-mark (cons (car marks) subst)) mod)
  430. results))))))
  431. (scan-vector-rib
  432. (lambda (subst symnames marks results)
  433. (let ((n (vector-length symnames)))
  434. (let f ((i 0) (results results))
  435. (if (= i n)
  436. (scan (cdr subst) results)
  437. (f (+ i 1)
  438. (cons (wrap (vector-ref symnames i)
  439. (anti-mark (cons (vector-ref marks i) subst))
  440. mod)
  441. results))))))))
  442. (scan (cdr w) '()))))
  443. (resolve-identifier
  444. (lambda (id w r mod resolve-syntax-parameters?)
  445. (letrec*
  446. ((resolve-syntax-parameters
  447. (lambda (b)
  448. (if (and resolve-syntax-parameters? (eq? (car b) 'syntax-parameter))
  449. (or (assq-ref r (cdr b)) (cons 'macro (car (cdr b))))
  450. b)))
  451. (resolve-global
  452. (lambda (var mod)
  453. (let ((b (resolve-syntax-parameters
  454. (or (get-global-definition-hook var mod) '(global)))))
  455. (if (eq? (car b) 'global)
  456. (values 'global var mod)
  457. (values (car b) (cdr b) mod)))))
  458. (resolve-lexical
  459. (lambda (label mod)
  460. (let ((b (resolve-syntax-parameters
  461. (or (assq-ref r label) '(displaced-lexical)))))
  462. (values (car b) (cdr b) mod)))))
  463. (let ((n (id-var-name id w mod)))
  464. (cond ((syntax-object? n)
  465. (resolve-identifier n w r mod resolve-syntax-parameters?))
  466. ((symbol? n)
  467. (resolve-global
  468. n
  469. (if (syntax-object? id) (syntax-object-module id) mod)))
  470. ((string? n)
  471. (resolve-lexical
  472. n
  473. (if (syntax-object? id) (syntax-object-module id) mod)))
  474. (else (error "unexpected id-var-name" id w n)))))))
  475. (transformer-environment
  476. (make-fluid
  477. (lambda (k)
  478. (error "called outside the dynamic extent of a syntax transformer"))))
  479. (with-transformer-environment
  480. (lambda (k) ((fluid-ref transformer-environment) k)))
  481. (free-id=?
  482. (lambda (i j)
  483. (let* ((mi (and (syntax-object? i) (syntax-object-module i)))
  484. (mj (and (syntax-object? j) (syntax-object-module j)))
  485. (ni (id-var-name i '(()) mi))
  486. (nj (id-var-name j '(()) mj)))
  487. (letrec*
  488. ((id-module-binding
  489. (lambda (id mod)
  490. (module-variable
  491. (if mod (resolve-module (cdr mod)) (current-module))
  492. (let ((x id)) (if (syntax-object? x) (syntax-object-expression x) x))))))
  493. (cond ((syntax-object? ni) (free-id=? ni j))
  494. ((syntax-object? nj) (free-id=? i nj))
  495. ((symbol? ni)
  496. (and (eq? nj
  497. (let ((x j)) (if (syntax-object? x) (syntax-object-expression x) x)))
  498. (let ((bi (id-module-binding i mi)))
  499. (if bi
  500. (eq? bi (id-module-binding j mj))
  501. (and (not (id-module-binding j mj)) (eq? ni nj))))
  502. (eq? (id-module-binding i mi) (id-module-binding j mj))))
  503. (else (equal? ni nj)))))))
  504. (bound-id=?
  505. (lambda (i j)
  506. (if (and (syntax-object? i) (syntax-object? j))
  507. (and (eq? (syntax-object-expression i) (syntax-object-expression j))
  508. (same-marks?
  509. (car (syntax-object-wrap i))
  510. (car (syntax-object-wrap j))))
  511. (eq? i j))))
  512. (valid-bound-ids?
  513. (lambda (ids)
  514. (and (let all-ids? ((ids ids))
  515. (or (null? ids) (and (id? (car ids)) (all-ids? (cdr ids)))))
  516. (distinct-bound-ids? ids))))
  517. (distinct-bound-ids?
  518. (lambda (ids)
  519. (let distinct? ((ids ids))
  520. (or (null? ids)
  521. (and (not (bound-id-member? (car ids) (cdr ids)))
  522. (distinct? (cdr ids)))))))
  523. (bound-id-member?
  524. (lambda (x list)
  525. (and (not (null? list))
  526. (or (bound-id=? x (car list)) (bound-id-member? x (cdr list))))))
  527. (wrap (lambda (x w defmod)
  528. (cond ((and (null? (car w)) (null? (cdr w))) x)
  529. ((syntax-object? x)
  530. (make-syntax-object
  531. (syntax-object-expression x)
  532. (join-wraps w (syntax-object-wrap x))
  533. (syntax-object-module x)))
  534. ((null? x) x)
  535. (else (make-syntax-object x w defmod)))))
  536. (source-wrap
  537. (lambda (x w s defmod) (wrap (decorate-source x s) w defmod)))
  538. (expand-sequence
  539. (lambda (body r w s mod)
  540. (build-sequence
  541. s
  542. (let dobody ((body body) (r r) (w w) (mod mod))
  543. (if (null? body)
  544. '()
  545. (let ((first (expand (car body) r w mod)))
  546. (cons first (dobody (cdr body) r w mod))))))))
  547. (expand-top-sequence
  548. (lambda (body r w s m esew mod)
  549. (let* ((r (cons '("placeholder" placeholder) r))
  550. (ribcage (make-ribcage '() '() '()))
  551. (w (cons (car w) (cons ribcage (cdr w)))))
  552. (letrec*
  553. ((record-definition!
  554. (lambda (id var)
  555. (let ((mod (cons 'hygiene (module-name (current-module)))))
  556. (extend-ribcage!
  557. ribcage
  558. id
  559. (cons (syntax-object-module id) (wrap var '((top)) mod))))))
  560. (macro-introduced-identifier?
  561. (lambda (id) (not (equal? (car (syntax-object-wrap id)) '(top)))))
  562. (fresh-derived-name
  563. (lambda (id orig-form)
  564. (symbol-append
  565. (syntax-object-expression id)
  566. '-
  567. (string->symbol
  568. (number->string
  569. (hash (syntax->datum orig-form) most-positive-fixnum)
  570. 16)))))
  571. (parse (lambda (body r w s m esew mod)
  572. (let lp ((body body) (exps '()))
  573. (if (null? body)
  574. exps
  575. (lp (cdr body) (append (parse1 (car body) r w s m esew mod) exps))))))
  576. (parse1
  577. (lambda (x r w s m esew mod)
  578. (call-with-values
  579. (lambda () (syntax-type x r w (source-annotation x) ribcage mod #f))
  580. (lambda (type value form e w s mod)
  581. (let ((key type))
  582. (cond ((memv key '(define-form))
  583. (let* ((id (wrap value w mod))
  584. (label (gen-label))
  585. (var (if (macro-introduced-identifier? id)
  586. (fresh-derived-name id x)
  587. (syntax-object-expression id))))
  588. (record-definition! id var)
  589. (list (if (eq? m 'c&e)
  590. (let ((x (build-global-definition s var (expand e r w mod))))
  591. (top-level-eval-hook x mod)
  592. (lambda () x))
  593. (call-with-values
  594. (lambda () (resolve-identifier id '(()) r mod #t))
  595. (lambda (type* value* mod*)
  596. (if (eq? type* 'macro)
  597. (top-level-eval-hook
  598. (build-global-definition s var (build-void s))
  599. mod))
  600. (lambda () (build-global-definition s var (expand e r w mod)))))))))
  601. ((memv key '(define-syntax-form define-syntax-parameter-form))
  602. (let* ((id (wrap value w mod))
  603. (label (gen-label))
  604. (var (if (macro-introduced-identifier? id)
  605. (fresh-derived-name id x)
  606. (syntax-object-expression id))))
  607. (record-definition! id var)
  608. (let ((key m))
  609. (cond ((memv key '(c))
  610. (cond ((memq 'compile esew)
  611. (let ((e (expand-install-global var type (expand e r w mod))))
  612. (top-level-eval-hook e mod)
  613. (if (memq 'load esew) (list (lambda () e)) '())))
  614. ((memq 'load esew)
  615. (list (lambda () (expand-install-global var type (expand e r w mod)))))
  616. (else '())))
  617. ((memv key '(c&e))
  618. (let ((e (expand-install-global var type (expand e r w mod))))
  619. (top-level-eval-hook e mod)
  620. (list (lambda () e))))
  621. (else
  622. (if (memq 'eval esew)
  623. (top-level-eval-hook
  624. (expand-install-global var type (expand e r w mod))
  625. mod))
  626. '())))))
  627. ((memv key '(begin-form))
  628. (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ . each-any))))
  629. (if tmp
  630. (apply (lambda (e1) (parse e1 r w s m esew mod)) tmp)
  631. (syntax-violation
  632. #f
  633. "source expression failed to match any pattern"
  634. tmp-1))))
  635. ((memv key '(local-syntax-form))
  636. (expand-local-syntax
  637. value
  638. e
  639. r
  640. w
  641. s
  642. mod
  643. (lambda (forms r w s mod) (parse forms r w s m esew mod))))
  644. ((memv key '(eval-when-form))
  645. (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ each-any any . each-any))))
  646. (if tmp
  647. (apply (lambda (x e1 e2)
  648. (let ((when-list (parse-when-list e x)) (body (cons e1 e2)))
  649. (letrec*
  650. ((recurse (lambda (m esew) (parse body r w s m esew mod))))
  651. (cond ((eq? m 'e)
  652. (if (memq 'eval when-list)
  653. (recurse (if (memq 'expand when-list) 'c&e 'e) '(eval))
  654. (begin
  655. (if (memq 'expand when-list)
  656. (top-level-eval-hook
  657. (expand-top-sequence body r w s 'e '(eval) mod)
  658. mod))
  659. '())))
  660. ((memq 'load when-list)
  661. (cond ((or (memq 'compile when-list)
  662. (memq 'expand when-list)
  663. (and (eq? m 'c&e) (memq 'eval when-list)))
  664. (recurse 'c&e '(compile load)))
  665. ((memq m '(c c&e)) (recurse 'c '(load)))
  666. (else '())))
  667. ((or (memq 'compile when-list)
  668. (memq 'expand when-list)
  669. (and (eq? m 'c&e) (memq 'eval when-list)))
  670. (top-level-eval-hook
  671. (expand-top-sequence body r w s 'e '(eval) mod)
  672. mod)
  673. '())
  674. (else '())))))
  675. tmp)
  676. (syntax-violation
  677. #f
  678. "source expression failed to match any pattern"
  679. tmp-1))))
  680. (else
  681. (list (if (eq? m 'c&e)
  682. (let ((x (expand-expr type value form e r w s mod)))
  683. (top-level-eval-hook x mod)
  684. (lambda () x))
  685. (lambda () (expand-expr type value form e r w s mod))))))))))))
  686. (let ((exps (map (lambda (x) (x)) (reverse (parse body r w s m esew mod)))))
  687. (if (null? exps) (build-void s) (build-sequence s exps)))))))
  688. (expand-install-global
  689. (lambda (name type e)
  690. (build-global-definition
  691. #f
  692. name
  693. (build-primcall
  694. #f
  695. 'make-syntax-transformer
  696. (if (eq? type 'define-syntax-parameter-form)
  697. (list (build-data #f name)
  698. (build-data #f 'syntax-parameter)
  699. (build-primcall #f 'list (list e)))
  700. (list (build-data #f name) (build-data #f 'macro) e))))))
  701. (parse-when-list
  702. (lambda (e when-list)
  703. (let ((result (strip when-list '(()))))
  704. (let lp ((l result))
  705. (cond ((null? l) result)
  706. ((memq (car l) '(compile load eval expand)) (lp (cdr l)))
  707. (else (syntax-violation 'eval-when "invalid situation" e (car l))))))))
  708. (syntax-type
  709. (lambda (e r w s rib mod for-car?)
  710. (cond ((symbol? e)
  711. (call-with-values
  712. (lambda () (resolve-identifier e w r mod #t))
  713. (lambda (type value mod*)
  714. (let ((key type))
  715. (cond ((memv key '(macro))
  716. (if for-car?
  717. (values type value e e w s mod)
  718. (syntax-type
  719. (expand-macro value e r w s rib mod)
  720. r
  721. '(())
  722. s
  723. rib
  724. mod
  725. #f)))
  726. ((memv key '(global)) (values type value e value w s mod*))
  727. (else (values type value e e w s mod)))))))
  728. ((pair? e)
  729. (let ((first (car e)))
  730. (call-with-values
  731. (lambda () (syntax-type first r w s rib mod #t))
  732. (lambda (ftype fval fform fe fw fs fmod)
  733. (let ((key ftype))
  734. (cond ((memv key '(lexical)) (values 'lexical-call fval e e w s mod))
  735. ((memv key '(global))
  736. (if (equal? fmod '(primitive))
  737. (values 'primitive-call fval e e w s mod)
  738. (values 'global-call (make-syntax-object fval w fmod) e e w s mod)))
  739. ((memv key '(macro))
  740. (syntax-type
  741. (expand-macro fval e r w s rib mod)
  742. r
  743. '(())
  744. s
  745. rib
  746. mod
  747. for-car?))
  748. ((memv key '(module-ref))
  749. (call-with-values
  750. (lambda () (fval e r w mod))
  751. (lambda (e r w s mod) (syntax-type e r w s rib mod for-car?))))
  752. ((memv key '(core)) (values 'core-form fval e e w s mod))
  753. ((memv key '(local-syntax))
  754. (values 'local-syntax-form fval e e w s mod))
  755. ((memv key '(begin)) (values 'begin-form #f e e w s mod))
  756. ((memv key '(eval-when)) (values 'eval-when-form #f e e w s mod))
  757. ((memv key '(define))
  758. (let* ((tmp e) (tmp-1 ($sc-dispatch tmp '(_ any any))))
  759. (if (and tmp-1 (apply (lambda (name val) (id? name)) tmp-1))
  760. (apply (lambda (name val) (values 'define-form name e val w s mod))
  761. tmp-1)
  762. (let ((tmp-1 ($sc-dispatch tmp '(_ (any . any) any . each-any))))
  763. (if (and tmp-1
  764. (apply (lambda (name args e1 e2)
  765. (and (id? name) (valid-bound-ids? (lambda-var-list args))))
  766. tmp-1))
  767. (apply (lambda (name args e1 e2)
  768. (values
  769. 'define-form
  770. (wrap name w mod)
  771. (wrap e w mod)
  772. (decorate-source
  773. (cons '#(syntax-object lambda ((top)) (hygiene guile))
  774. (wrap (cons args (cons e1 e2)) w mod))
  775. s)
  776. '(())
  777. s
  778. mod))
  779. tmp-1)
  780. (let ((tmp-1 ($sc-dispatch tmp '(_ any))))
  781. (if (and tmp-1 (apply (lambda (name) (id? name)) tmp-1))
  782. (apply (lambda (name)
  783. (values
  784. 'define-form
  785. (wrap name w mod)
  786. (wrap e w mod)
  787. '(#(syntax-object if ((top)) (hygiene guile)) #f #f)
  788. '(())
  789. s
  790. mod))
  791. tmp-1)
  792. (syntax-violation
  793. #f
  794. "source expression failed to match any pattern"
  795. tmp))))))))
  796. ((memv key '(define-syntax))
  797. (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ any any))))
  798. (if (and tmp (apply (lambda (name val) (id? name)) tmp))
  799. (apply (lambda (name val) (values 'define-syntax-form name e val w s mod))
  800. tmp)
  801. (syntax-violation
  802. #f
  803. "source expression failed to match any pattern"
  804. tmp-1))))
  805. ((memv key '(define-syntax-parameter))
  806. (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ any any))))
  807. (if (and tmp (apply (lambda (name val) (id? name)) tmp))
  808. (apply (lambda (name val)
  809. (values 'define-syntax-parameter-form name e val w s mod))
  810. tmp)
  811. (syntax-violation
  812. #f
  813. "source expression failed to match any pattern"
  814. tmp-1))))
  815. (else (values 'call #f e e w s mod))))))))
  816. ((syntax-object? e)
  817. (syntax-type
  818. (syntax-object-expression e)
  819. r
  820. (join-wraps w (syntax-object-wrap e))
  821. (or (source-annotation e) s)
  822. rib
  823. (or (syntax-object-module e) mod)
  824. for-car?))
  825. ((self-evaluating? e) (values 'constant #f e e w s mod))
  826. (else (values 'other #f e e w s mod)))))
  827. (expand
  828. (lambda (e r w mod)
  829. (call-with-values
  830. (lambda () (syntax-type e r w (source-annotation e) #f mod #f))
  831. (lambda (type value form e w s mod)
  832. (expand-expr type value form e r w s mod)))))
  833. (expand-expr
  834. (lambda (type value form e r w s mod)
  835. (let ((key type))
  836. (cond ((memv key '(lexical)) (build-lexical-reference 'value s e value))
  837. ((memv key '(core core-form)) (value e r w s mod))
  838. ((memv key '(module-ref))
  839. (call-with-values
  840. (lambda () (value e r w mod))
  841. (lambda (e r w s mod) (expand e r w mod))))
  842. ((memv key '(lexical-call))
  843. (expand-call
  844. (let ((id (car e)))
  845. (build-lexical-reference
  846. 'fun
  847. (source-annotation id)
  848. (if (syntax-object? id) (syntax->datum id) id)
  849. value))
  850. e
  851. r
  852. w
  853. s
  854. mod))
  855. ((memv key '(global-call))
  856. (expand-call
  857. (build-global-reference
  858. (source-annotation (car e))
  859. (if (syntax-object? value) (syntax-object-expression value) value)
  860. (if (syntax-object? value) (syntax-object-module value) mod))
  861. e
  862. r
  863. w
  864. s
  865. mod))
  866. ((memv key '(primitive-call))
  867. (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ . each-any))))
  868. (if tmp
  869. (apply (lambda (e)
  870. (build-primcall s value (map (lambda (e) (expand e r w mod)) e)))
  871. tmp)
  872. (syntax-violation
  873. #f
  874. "source expression failed to match any pattern"
  875. tmp-1))))
  876. ((memv key '(constant))
  877. (build-data s (strip (source-wrap e w s mod) '(()))))
  878. ((memv key '(global)) (build-global-reference s value mod))
  879. ((memv key '(call))
  880. (expand-call (expand (car e) r w mod) e r w s mod))
  881. ((memv key '(begin-form))
  882. (let* ((tmp e) (tmp-1 ($sc-dispatch tmp '(_ any . each-any))))
  883. (if tmp-1
  884. (apply (lambda (e1 e2) (expand-sequence (cons e1 e2) r w s mod))
  885. tmp-1)
  886. (let ((tmp-1 ($sc-dispatch tmp '(_))))
  887. (if tmp-1
  888. (apply (lambda ()
  889. (syntax-violation
  890. #f
  891. "sequence of zero expressions"
  892. (source-wrap e w s mod)))
  893. tmp-1)
  894. (syntax-violation
  895. #f
  896. "source expression failed to match any pattern"
  897. tmp))))))
  898. ((memv key '(local-syntax-form))
  899. (expand-local-syntax value e r w s mod expand-sequence))
  900. ((memv key '(eval-when-form))
  901. (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ each-any any . each-any))))
  902. (if tmp
  903. (apply (lambda (x e1 e2)
  904. (let ((when-list (parse-when-list e x)))
  905. (if (memq 'eval when-list)
  906. (expand-sequence (cons e1 e2) r w s mod)
  907. (expand-void))))
  908. tmp)
  909. (syntax-violation
  910. #f
  911. "source expression failed to match any pattern"
  912. tmp-1))))
  913. ((memv key
  914. '(define-form define-syntax-form define-syntax-parameter-form))
  915. (syntax-violation
  916. #f
  917. "definition in expression context, where definitions are not allowed,"
  918. (source-wrap form w s mod)))
  919. ((memv key '(syntax))
  920. (syntax-violation
  921. #f
  922. "reference to pattern variable outside syntax form"
  923. (source-wrap e w s mod)))
  924. ((memv key '(displaced-lexical))
  925. (syntax-violation
  926. #f
  927. "reference to identifier outside its scope"
  928. (source-wrap e w s mod)))
  929. (else
  930. (syntax-violation #f "unexpected syntax" (source-wrap e w s mod)))))))
  931. (expand-call
  932. (lambda (x e r w s mod)
  933. (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(any . each-any))))
  934. (if tmp
  935. (apply (lambda (e0 e1)
  936. (build-call s x (map (lambda (e) (expand e r w mod)) e1)))
  937. tmp)
  938. (syntax-violation
  939. #f
  940. "source expression failed to match any pattern"
  941. tmp-1)))))
  942. (expand-macro
  943. (lambda (p e r w s rib mod)
  944. (letrec*
  945. ((rebuild-macro-output
  946. (lambda (x m)
  947. (cond ((pair? x)
  948. (decorate-source
  949. (cons (rebuild-macro-output (car x) m)
  950. (rebuild-macro-output (cdr x) m))
  951. s))
  952. ((syntax-object? x)
  953. (let ((w (syntax-object-wrap x)))
  954. (let ((ms (car w)) (ss (cdr w)))
  955. (if (and (pair? ms) (eq? (car ms) #f))
  956. (make-syntax-object
  957. (syntax-object-expression x)
  958. (cons (cdr ms) (if rib (cons rib (cdr ss)) (cdr ss)))
  959. (syntax-object-module x))
  960. (make-syntax-object
  961. (decorate-source (syntax-object-expression x) s)
  962. (cons (cons m ms)
  963. (if rib (cons rib (cons 'shift ss)) (cons 'shift ss)))
  964. (syntax-object-module x))))))
  965. ((vector? x)
  966. (let* ((n (vector-length x)) (v (decorate-source (make-vector n) s)))
  967. (let loop ((i 0))
  968. (if (= i n)
  969. (begin (if #f #f) v)
  970. (begin
  971. (vector-set! v i (rebuild-macro-output (vector-ref x i) m))
  972. (loop (+ i 1)))))))
  973. ((symbol? x)
  974. (syntax-violation
  975. #f
  976. "encountered raw symbol in macro output"
  977. (source-wrap e w (cdr w) mod)
  978. x))
  979. (else (decorate-source x s))))))
  980. (let* ((t-1 transformer-environment) (t (lambda (k) (k e r w s rib mod))))
  981. (with-fluid*
  982. t-1
  983. t
  984. (lambda ()
  985. (rebuild-macro-output
  986. (p (source-wrap e (anti-mark w) s mod))
  987. (gensym (string-append "m-" (session-id) "-")))))))))
  988. (expand-body
  989. (lambda (body outer-form r w mod)
  990. (let* ((r (cons '("placeholder" placeholder) r))
  991. (ribcage (make-ribcage '() '() '()))
  992. (w (cons (car w) (cons ribcage (cdr w)))))
  993. (let parse ((body (map (lambda (x) (cons r (wrap x w mod))) body))
  994. (ids '())
  995. (labels '())
  996. (var-ids '())
  997. (vars '())
  998. (vals '())
  999. (bindings '()))
  1000. (if (null? body)
  1001. (syntax-violation #f "no expressions in body" outer-form)
  1002. (let ((e (cdar body)) (er (caar body)))
  1003. (call-with-values
  1004. (lambda ()
  1005. (syntax-type e er '(()) (source-annotation e) ribcage mod #f))
  1006. (lambda (type value form e w s mod)
  1007. (let ((key type))
  1008. (cond ((memv key '(define-form))
  1009. (let ((id (wrap value w mod)) (label (gen-label)))
  1010. (let ((var (gen-var id)))
  1011. (extend-ribcage! ribcage id label)
  1012. (parse (cdr body)
  1013. (cons id ids)
  1014. (cons label labels)
  1015. (cons id var-ids)
  1016. (cons var vars)
  1017. (cons (cons er (wrap e w mod)) vals)
  1018. (cons (cons 'lexical var) bindings)))))
  1019. ((memv key '(define-syntax-form))
  1020. (let ((id (wrap value w mod))
  1021. (label (gen-label))
  1022. (trans-r (macros-only-env er)))
  1023. (extend-ribcage! ribcage id label)
  1024. (set-cdr!
  1025. r
  1026. (extend-env
  1027. (list label)
  1028. (list (cons 'macro (eval-local-transformer (expand e trans-r w mod) mod)))
  1029. (cdr r)))
  1030. (parse (cdr body) (cons id ids) labels var-ids vars vals bindings)))
  1031. ((memv key '(define-syntax-parameter-form))
  1032. (let ((id (wrap value w mod))
  1033. (label (gen-label))
  1034. (trans-r (macros-only-env er)))
  1035. (extend-ribcage! ribcage id label)
  1036. (set-cdr!
  1037. r
  1038. (extend-env
  1039. (list label)
  1040. (list (cons 'syntax-parameter
  1041. (list (eval-local-transformer (expand e trans-r w mod) mod))))
  1042. (cdr r)))
  1043. (parse (cdr body) (cons id ids) labels var-ids vars vals bindings)))
  1044. ((memv key '(begin-form))
  1045. (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ . each-any))))
  1046. (if tmp
  1047. (apply (lambda (e1)
  1048. (parse (let f ((forms e1))
  1049. (if (null? forms)
  1050. (cdr body)
  1051. (cons (cons er (wrap (car forms) w mod)) (f (cdr forms)))))
  1052. ids
  1053. labels
  1054. var-ids
  1055. vars
  1056. vals
  1057. bindings))
  1058. tmp)
  1059. (syntax-violation
  1060. #f
  1061. "source expression failed to match any pattern"
  1062. tmp-1))))
  1063. ((memv key '(local-syntax-form))
  1064. (expand-local-syntax
  1065. value
  1066. e
  1067. er
  1068. w
  1069. s
  1070. mod
  1071. (lambda (forms er w s mod)
  1072. (parse (let f ((forms forms))
  1073. (if (null? forms)
  1074. (cdr body)
  1075. (cons (cons er (wrap (car forms) w mod)) (f (cdr forms)))))
  1076. ids
  1077. labels
  1078. var-ids
  1079. vars
  1080. vals
  1081. bindings))))
  1082. ((null? ids)
  1083. (build-sequence
  1084. #f
  1085. (map (lambda (x) (expand (cdr x) (car x) '(()) mod))
  1086. (cons (cons er (source-wrap e w s mod)) (cdr body)))))
  1087. (else
  1088. (if (not (valid-bound-ids? ids))
  1089. (syntax-violation
  1090. #f
  1091. "invalid or duplicate identifier in definition"
  1092. outer-form))
  1093. (set-cdr! r (extend-env labels bindings (cdr r)))
  1094. (build-letrec
  1095. #f
  1096. #t
  1097. (reverse (map syntax->datum var-ids))
  1098. (reverse vars)
  1099. (map (lambda (x) (expand (cdr x) (car x) '(()) mod)) (reverse vals))
  1100. (build-sequence
  1101. #f
  1102. (map (lambda (x) (expand (cdr x) (car x) '(()) mod))
  1103. (cons (cons er (source-wrap e w s mod)) (cdr body))))))))))))))))
  1104. (expand-local-syntax
  1105. (lambda (rec? e r w s mod k)
  1106. (let* ((tmp e)
  1107. (tmp ($sc-dispatch tmp '(_ #(each (any any)) any . each-any))))
  1108. (if tmp
  1109. (apply (lambda (id val e1 e2)
  1110. (let ((ids id))
  1111. (if (not (valid-bound-ids? ids))
  1112. (syntax-violation #f "duplicate bound keyword" e)
  1113. (let* ((labels (gen-labels ids)) (new-w (make-binding-wrap ids labels w)))
  1114. (k (cons e1 e2)
  1115. (extend-env
  1116. labels
  1117. (let ((w (if rec? new-w w)) (trans-r (macros-only-env r)))
  1118. (map (lambda (x)
  1119. (cons 'macro (eval-local-transformer (expand x trans-r w mod) mod)))
  1120. val))
  1121. r)
  1122. new-w
  1123. s
  1124. mod)))))
  1125. tmp)
  1126. (syntax-violation
  1127. #f
  1128. "bad local syntax definition"
  1129. (source-wrap e w s mod))))))
  1130. (eval-local-transformer
  1131. (lambda (expanded mod)
  1132. (let ((p (local-eval-hook expanded mod)))
  1133. (if (procedure? p)
  1134. p
  1135. (syntax-violation #f "nonprocedure transformer" p)))))
  1136. (expand-void (lambda () (build-void #f)))
  1137. (ellipsis?
  1138. (lambda (e r mod)
  1139. (and (nonsymbol-id? e)
  1140. (call-with-values
  1141. (lambda ()
  1142. (resolve-identifier
  1143. (make-syntax-object
  1144. '#{ $sc-ellipsis }#
  1145. (syntax-object-wrap e)
  1146. (syntax-object-module e))
  1147. '(())
  1148. r
  1149. mod
  1150. #f))
  1151. (lambda (type value mod)
  1152. (if (eq? type 'ellipsis)
  1153. (bound-id=? e value)
  1154. (free-id=? e '#(syntax-object ... ((top)) (hygiene guile)))))))))
  1155. (lambda-formals
  1156. (lambda (orig-args)
  1157. (letrec*
  1158. ((req (lambda (args rreq)
  1159. (let* ((tmp args) (tmp-1 ($sc-dispatch tmp '())))
  1160. (if tmp-1
  1161. (apply (lambda () (check (reverse rreq) #f)) tmp-1)
  1162. (let ((tmp-1 ($sc-dispatch tmp '(any . any))))
  1163. (if (and tmp-1 (apply (lambda (a b) (id? a)) tmp-1))
  1164. (apply (lambda (a b) (req b (cons a rreq))) tmp-1)
  1165. (let ((tmp-1 (list tmp)))
  1166. (if (and tmp-1 (apply (lambda (r) (id? r)) tmp-1))
  1167. (apply (lambda (r) (check (reverse rreq) r)) tmp-1)
  1168. (let ((else tmp))
  1169. (syntax-violation 'lambda "invalid argument list" orig-args args))))))))))
  1170. (check (lambda (req rest)
  1171. (if (distinct-bound-ids? (if rest (cons rest req) req))
  1172. (values req #f rest #f)
  1173. (syntax-violation
  1174. 'lambda
  1175. "duplicate identifier in argument list"
  1176. orig-args)))))
  1177. (req orig-args '()))))
  1178. (expand-simple-lambda
  1179. (lambda (e r w s mod req rest meta body)
  1180. (let* ((ids (if rest (append req (list rest)) req))
  1181. (vars (map gen-var ids))
  1182. (labels (gen-labels ids)))
  1183. (build-simple-lambda
  1184. s
  1185. (map syntax->datum req)
  1186. (and rest (syntax->datum rest))
  1187. vars
  1188. meta
  1189. (expand-body
  1190. body
  1191. (source-wrap e w s mod)
  1192. (extend-var-env labels vars r)
  1193. (make-binding-wrap ids labels w)
  1194. mod)))))
  1195. (lambda*-formals
  1196. (lambda (orig-args)
  1197. (letrec*
  1198. ((req (lambda (args rreq)
  1199. (let* ((tmp args) (tmp-1 ($sc-dispatch tmp '())))
  1200. (if tmp-1
  1201. (apply (lambda () (check (reverse rreq) '() #f '())) tmp-1)
  1202. (let ((tmp-1 ($sc-dispatch tmp '(any . any))))
  1203. (if (and tmp-1 (apply (lambda (a b) (id? a)) tmp-1))
  1204. (apply (lambda (a b) (req b (cons a rreq))) tmp-1)
  1205. (let ((tmp-1 ($sc-dispatch tmp '(any . any))))
  1206. (if (and tmp-1
  1207. (apply (lambda (a b) (eq? (syntax->datum a) #:optional)) tmp-1))
  1208. (apply (lambda (a b) (opt b (reverse rreq) '())) tmp-1)
  1209. (let ((tmp-1 ($sc-dispatch tmp '(any . any))))
  1210. (if (and tmp-1
  1211. (apply (lambda (a b) (eq? (syntax->datum a) #:key)) tmp-1))
  1212. (apply (lambda (a b) (key b (reverse rreq) '() '())) tmp-1)
  1213. (let ((tmp-1 ($sc-dispatch tmp '(any any))))
  1214. (if (and tmp-1
  1215. (apply (lambda (a b) (eq? (syntax->datum a) #:rest)) tmp-1))
  1216. (apply (lambda (a b) (rest b (reverse rreq) '() '())) tmp-1)
  1217. (let ((tmp-1 (list tmp)))
  1218. (if (and tmp-1 (apply (lambda (r) (id? r)) tmp-1))
  1219. (apply (lambda (r) (rest r (reverse rreq) '() '())) tmp-1)
  1220. (let ((else tmp))
  1221. (syntax-violation
  1222. 'lambda*
  1223. "invalid argument list"
  1224. orig-args
  1225. args))))))))))))))))
  1226. (opt (lambda (args req ropt)
  1227. (let* ((tmp args) (tmp-1 ($sc-dispatch tmp '())))
  1228. (if tmp-1
  1229. (apply (lambda () (check req (reverse ropt) #f '())) tmp-1)
  1230. (let ((tmp-1 ($sc-dispatch tmp '(any . any))))
  1231. (if (and tmp-1 (apply (lambda (a b) (id? a)) tmp-1))
  1232. (apply (lambda (a b) (opt b req (cons (cons a '(#f)) ropt))) tmp-1)
  1233. (let ((tmp-1 ($sc-dispatch tmp '((any any) . any))))
  1234. (if (and tmp-1 (apply (lambda (a init b) (id? a)) tmp-1))
  1235. (apply (lambda (a init b) (opt b req (cons (list a init) ropt)))
  1236. tmp-1)
  1237. (let ((tmp-1 ($sc-dispatch tmp '(any . any))))
  1238. (if (and tmp-1
  1239. (apply (lambda (a b) (eq? (syntax->datum a) #:key)) tmp-1))
  1240. (apply (lambda (a b) (key b req (reverse ropt) '())) tmp-1)
  1241. (let ((tmp-1 ($sc-dispatch tmp '(any any))))
  1242. (if (and tmp-1
  1243. (apply (lambda (a b) (eq? (syntax->datum a) #:rest)) tmp-1))
  1244. (apply (lambda (a b) (rest b req (reverse ropt) '())) tmp-1)
  1245. (let ((tmp-1 (list tmp)))
  1246. (if (and tmp-1 (apply (lambda (r) (id? r)) tmp-1))
  1247. (apply (lambda (r) (rest r req (reverse ropt) '())) tmp-1)
  1248. (let ((else tmp))
  1249. (syntax-violation
  1250. 'lambda*
  1251. "invalid optional argument list"
  1252. orig-args
  1253. args))))))))))))))))
  1254. (key (lambda (args req opt rkey)
  1255. (let* ((tmp args) (tmp-1 ($sc-dispatch tmp '())))
  1256. (if tmp-1
  1257. (apply (lambda () (check req opt #f (cons #f (reverse rkey)))) tmp-1)
  1258. (let ((tmp-1 ($sc-dispatch tmp '(any . any))))
  1259. (if (and tmp-1 (apply (lambda (a b) (id? a)) tmp-1))
  1260. (apply (lambda (a b)
  1261. (let* ((tmp (symbol->keyword (syntax->datum a))) (k tmp))
  1262. (key b req opt (cons (cons k (cons a '(#f))) rkey))))
  1263. tmp-1)
  1264. (let ((tmp-1 ($sc-dispatch tmp '((any any) . any))))
  1265. (if (and tmp-1 (apply (lambda (a init b) (id? a)) tmp-1))
  1266. (apply (lambda (a init b)
  1267. (let* ((tmp (symbol->keyword (syntax->datum a))) (k tmp))
  1268. (key b req opt (cons (list k a init) rkey))))
  1269. tmp-1)
  1270. (let ((tmp-1 ($sc-dispatch tmp '((any any any) . any))))
  1271. (if (and tmp-1
  1272. (apply (lambda (a init k b) (and (id? a) (keyword? (syntax->datum k))))
  1273. tmp-1))
  1274. (apply (lambda (a init k b) (key b req opt (cons (list k a init) rkey)))
  1275. tmp-1)
  1276. (let ((tmp-1 ($sc-dispatch tmp '(any))))
  1277. (if (and tmp-1
  1278. (apply (lambda (aok) (eq? (syntax->datum aok) #:allow-other-keys))
  1279. tmp-1))
  1280. (apply (lambda (aok) (check req opt #f (cons #t (reverse rkey))))
  1281. tmp-1)
  1282. (let ((tmp-1 ($sc-dispatch tmp '(any any any))))
  1283. (if (and tmp-1
  1284. (apply (lambda (aok a b)
  1285. (and (eq? (syntax->datum aok) #:allow-other-keys)
  1286. (eq? (syntax->datum a) #:rest)))
  1287. tmp-1))
  1288. (apply (lambda (aok a b) (rest b req opt (cons #t (reverse rkey))))
  1289. tmp-1)
  1290. (let ((tmp-1 ($sc-dispatch tmp '(any . any))))
  1291. (if (and tmp-1
  1292. (apply (lambda (aok r)
  1293. (and (eq? (syntax->datum aok) #:allow-other-keys) (id? r)))
  1294. tmp-1))
  1295. (apply (lambda (aok r) (rest r req opt (cons #t (reverse rkey))))
  1296. tmp-1)
  1297. (let ((tmp-1 ($sc-dispatch tmp '(any any))))
  1298. (if (and tmp-1
  1299. (apply (lambda (a b) (eq? (syntax->datum a) #:rest)) tmp-1))
  1300. (apply (lambda (a b) (rest b req opt (cons #f (reverse rkey))))
  1301. tmp-1)
  1302. (let ((tmp-1 (list tmp)))
  1303. (if (and tmp-1 (apply (lambda (r) (id? r)) tmp-1))
  1304. (apply (lambda (r) (rest r req opt (cons #f (reverse rkey))))
  1305. tmp-1)
  1306. (let ((else tmp))
  1307. (syntax-violation
  1308. 'lambda*
  1309. "invalid keyword argument list"
  1310. orig-args
  1311. args))))))))))))))))))))))
  1312. (rest (lambda (args req opt kw)
  1313. (let* ((tmp-1 args) (tmp (list tmp-1)))
  1314. (if (and tmp (apply (lambda (r) (id? r)) tmp))
  1315. (apply (lambda (r) (check req opt r kw)) tmp)
  1316. (let ((else tmp-1))
  1317. (syntax-violation 'lambda* "invalid rest argument" orig-args args))))))
  1318. (check (lambda (req opt rest kw)
  1319. (if (distinct-bound-ids?
  1320. (append
  1321. req
  1322. (map car opt)
  1323. (if rest (list rest) '())
  1324. (if (pair? kw) (map cadr (cdr kw)) '())))
  1325. (values req opt rest kw)
  1326. (syntax-violation
  1327. 'lambda*
  1328. "duplicate identifier in argument list"
  1329. orig-args)))))
  1330. (req orig-args '()))))
  1331. (expand-lambda-case
  1332. (lambda (e r w s mod get-formals clauses)
  1333. (letrec*
  1334. ((parse-req
  1335. (lambda (req opt rest kw body)
  1336. (let ((vars (map gen-var req)) (labels (gen-labels req)))
  1337. (let ((r* (extend-var-env labels vars r))
  1338. (w* (make-binding-wrap req labels w)))
  1339. (parse-opt
  1340. (map syntax->datum req)
  1341. opt
  1342. rest
  1343. kw
  1344. body
  1345. (reverse vars)
  1346. r*
  1347. w*
  1348. '()
  1349. '())))))
  1350. (parse-opt
  1351. (lambda (req opt rest kw body vars r* w* out inits)
  1352. (cond ((pair? opt)
  1353. (let* ((tmp-1 (car opt)) (tmp ($sc-dispatch tmp-1 '(any any))))
  1354. (if tmp
  1355. (apply (lambda (id i)
  1356. (let* ((v (gen-var id))
  1357. (l (gen-labels (list v)))
  1358. (r** (extend-var-env l (list v) r*))
  1359. (w** (make-binding-wrap (list id) l w*)))
  1360. (parse-opt
  1361. req
  1362. (cdr opt)
  1363. rest
  1364. kw
  1365. body
  1366. (cons v vars)
  1367. r**
  1368. w**
  1369. (cons (syntax->datum id) out)
  1370. (cons (expand i r* w* mod) inits))))
  1371. tmp)
  1372. (syntax-violation
  1373. #f
  1374. "source expression failed to match any pattern"
  1375. tmp-1))))
  1376. (rest
  1377. (let* ((v (gen-var rest))
  1378. (l (gen-labels (list v)))
  1379. (r* (extend-var-env l (list v) r*))
  1380. (w* (make-binding-wrap (list rest) l w*)))
  1381. (parse-kw
  1382. req
  1383. (and (pair? out) (reverse out))
  1384. (syntax->datum rest)
  1385. (if (pair? kw) (cdr kw) kw)
  1386. body
  1387. (cons v vars)
  1388. r*
  1389. w*
  1390. (and (pair? kw) (car kw))
  1391. '()
  1392. inits)))
  1393. (else
  1394. (parse-kw
  1395. req
  1396. (and (pair? out) (reverse out))
  1397. #f
  1398. (if (pair? kw) (cdr kw) kw)
  1399. body
  1400. vars
  1401. r*
  1402. w*
  1403. (and (pair? kw) (car kw))
  1404. '()
  1405. inits)))))
  1406. (parse-kw
  1407. (lambda (req opt rest kw body vars r* w* aok out inits)
  1408. (if (pair? kw)
  1409. (let* ((tmp-1 (car kw)) (tmp ($sc-dispatch tmp-1 '(any any any))))
  1410. (if tmp
  1411. (apply (lambda (k id i)
  1412. (let* ((v (gen-var id))
  1413. (l (gen-labels (list v)))
  1414. (r** (extend-var-env l (list v) r*))
  1415. (w** (make-binding-wrap (list id) l w*)))
  1416. (parse-kw
  1417. req
  1418. opt
  1419. rest
  1420. (cdr kw)
  1421. body
  1422. (cons v vars)
  1423. r**
  1424. w**
  1425. aok
  1426. (cons (list (syntax->datum k) (syntax->datum id) v) out)
  1427. (cons (expand i r* w* mod) inits))))
  1428. tmp)
  1429. (syntax-violation
  1430. #f
  1431. "source expression failed to match any pattern"
  1432. tmp-1)))
  1433. (parse-body
  1434. req
  1435. opt
  1436. rest
  1437. (and (or aok (pair? out)) (cons aok (reverse out)))
  1438. body
  1439. (reverse vars)
  1440. r*
  1441. w*
  1442. (reverse inits)
  1443. '()))))
  1444. (parse-body
  1445. (lambda (req opt rest kw body vars r* w* inits meta)
  1446. (let* ((tmp body) (tmp-1 ($sc-dispatch tmp '(any any . each-any))))
  1447. (if (and tmp-1
  1448. (apply (lambda (docstring e1 e2) (string? (syntax->datum docstring)))
  1449. tmp-1))
  1450. (apply (lambda (docstring e1 e2)
  1451. (parse-body
  1452. req
  1453. opt
  1454. rest
  1455. kw
  1456. (cons e1 e2)
  1457. vars
  1458. r*
  1459. w*
  1460. inits
  1461. (append meta (list (cons 'documentation (syntax->datum docstring))))))
  1462. tmp-1)
  1463. (let ((tmp-1 ($sc-dispatch tmp '(#(vector #(each (any . any))) any . each-any))))
  1464. (if tmp-1
  1465. (apply (lambda (k v e1 e2)
  1466. (parse-body
  1467. req
  1468. opt
  1469. rest
  1470. kw
  1471. (cons e1 e2)
  1472. vars
  1473. r*
  1474. w*
  1475. inits
  1476. (append meta (syntax->datum (map cons k v)))))
  1477. tmp-1)
  1478. (let ((tmp-1 ($sc-dispatch tmp '(any . each-any))))
  1479. (if tmp-1
  1480. (apply (lambda (e1 e2)
  1481. (values
  1482. meta
  1483. req
  1484. opt
  1485. rest
  1486. kw
  1487. inits
  1488. vars
  1489. (expand-body (cons e1 e2) (source-wrap e w s mod) r* w* mod)))
  1490. tmp-1)
  1491. (syntax-violation
  1492. #f
  1493. "source expression failed to match any pattern"
  1494. tmp))))))))))
  1495. (let* ((tmp clauses) (tmp-1 ($sc-dispatch tmp '())))
  1496. (if tmp-1
  1497. (apply (lambda () (values '() #f)) tmp-1)
  1498. (let ((tmp-1 ($sc-dispatch
  1499. tmp
  1500. '((any any . each-any) . #(each (any any . each-any))))))
  1501. (if tmp-1
  1502. (apply (lambda (args e1 e2 args* e1* e2*)
  1503. (call-with-values
  1504. (lambda () (get-formals args))
  1505. (lambda (req opt rest kw)
  1506. (call-with-values
  1507. (lambda () (parse-req req opt rest kw (cons e1 e2)))
  1508. (lambda (meta req opt rest kw inits vars body)
  1509. (call-with-values
  1510. (lambda ()
  1511. (expand-lambda-case
  1512. e
  1513. r
  1514. w
  1515. s
  1516. mod
  1517. get-formals
  1518. (map (lambda (tmp-2 tmp-1 tmp) (cons tmp (cons tmp-1 tmp-2)))
  1519. e2*
  1520. e1*
  1521. args*)))
  1522. (lambda (meta* else*)
  1523. (values
  1524. (append meta meta*)
  1525. (build-lambda-case s req opt rest kw inits vars body else*)))))))))
  1526. tmp-1)
  1527. (syntax-violation
  1528. #f
  1529. "source expression failed to match any pattern"
  1530. tmp))))))))
  1531. (strip (lambda (x w)
  1532. (if (memq 'top (car w))
  1533. x
  1534. (let f ((x x))
  1535. (cond ((syntax-object? x)
  1536. (strip (syntax-object-expression x) (syntax-object-wrap x)))
  1537. ((pair? x)
  1538. (let ((a (f (car x))) (d (f (cdr x))))
  1539. (if (and (eq? a (car x)) (eq? d (cdr x))) x (cons a d))))
  1540. ((vector? x)
  1541. (let* ((old (vector->list x)) (new (map f old)))
  1542. (let lp ((l1 old) (l2 new))
  1543. (cond ((null? l1) x)
  1544. ((eq? (car l1) (car l2)) (lp (cdr l1) (cdr l2)))
  1545. (else (list->vector new))))))
  1546. (else x))))))
  1547. (gen-var
  1548. (lambda (id)
  1549. (let ((id (if (syntax-object? id) (syntax-object-expression id) id)))
  1550. (gensym (string-append (symbol->string id) "-")))))
  1551. (lambda-var-list
  1552. (lambda (vars)
  1553. (let lvl ((vars vars) (ls '()) (w '(())))
  1554. (cond ((pair? vars) (lvl (cdr vars) (cons (wrap (car vars) w #f) ls) w))
  1555. ((id? vars) (cons (wrap vars w #f) ls))
  1556. ((null? vars) ls)
  1557. ((syntax-object? vars)
  1558. (lvl (syntax-object-expression vars)
  1559. ls
  1560. (join-wraps w (syntax-object-wrap vars))))
  1561. (else (cons vars ls)))))))
  1562. (global-extend 'local-syntax 'letrec-syntax #t)
  1563. (global-extend 'local-syntax 'let-syntax #f)
  1564. (global-extend
  1565. 'core
  1566. 'syntax-parameterize
  1567. (lambda (e r w s mod)
  1568. (let* ((tmp e)
  1569. (tmp ($sc-dispatch tmp '(_ #(each (any any)) any . each-any))))
  1570. (if (and tmp (apply (lambda (var val e1 e2) (valid-bound-ids? var)) tmp))
  1571. (apply (lambda (var val e1 e2)
  1572. (let ((names (map (lambda (x)
  1573. (call-with-values
  1574. (lambda () (resolve-identifier x w r mod #f))
  1575. (lambda (type value mod)
  1576. (let ((key type))
  1577. (cond ((memv key '(displaced-lexical))
  1578. (syntax-violation
  1579. 'syntax-parameterize
  1580. "identifier out of context"
  1581. e
  1582. (source-wrap x w s mod)))
  1583. ((memv key '(syntax-parameter)) value)
  1584. (else
  1585. (syntax-violation
  1586. 'syntax-parameterize
  1587. "invalid syntax parameter"
  1588. e
  1589. (source-wrap x w s mod))))))))
  1590. var))
  1591. (bindings
  1592. (let ((trans-r (macros-only-env r)))
  1593. (map (lambda (x)
  1594. (cons 'macro (eval-local-transformer (expand x trans-r w mod) mod)))
  1595. val))))
  1596. (expand-body
  1597. (cons e1 e2)
  1598. (source-wrap e w s mod)
  1599. (extend-env names bindings r)
  1600. w
  1601. mod)))
  1602. tmp)
  1603. (syntax-violation
  1604. 'syntax-parameterize
  1605. "bad syntax"
  1606. (source-wrap e w s mod))))))
  1607. (global-extend
  1608. 'core
  1609. 'quote
  1610. (lambda (e r w s mod)
  1611. (let* ((tmp e) (tmp ($sc-dispatch tmp '(_ any))))
  1612. (if tmp
  1613. (apply (lambda (e) (build-data s (strip e w))) tmp)
  1614. (syntax-violation 'quote "bad syntax" (source-wrap e w s mod))))))
  1615. (global-extend
  1616. 'core
  1617. 'syntax
  1618. (letrec*
  1619. ((gen-syntax
  1620. (lambda (src e r maps ellipsis? mod)
  1621. (if (id? e)
  1622. (call-with-values
  1623. (lambda () (resolve-identifier e '(()) r mod #f))
  1624. (lambda (type value mod)
  1625. (let ((key type))
  1626. (cond ((memv key '(syntax))
  1627. (call-with-values
  1628. (lambda () (gen-ref src (car value) (cdr value) maps))
  1629. (lambda (var maps) (values (list 'ref var) maps))))
  1630. ((ellipsis? e r mod)
  1631. (syntax-violation 'syntax "misplaced ellipsis" src))
  1632. (else (values (list 'quote e) maps))))))
  1633. (let* ((tmp e) (tmp-1 ($sc-dispatch tmp '(any any))))
  1634. (if (and tmp-1 (apply (lambda (dots e) (ellipsis? dots r mod)) tmp-1))
  1635. (apply (lambda (dots e) (gen-syntax src e r maps (lambda (e r mod) #f) mod))
  1636. tmp-1)
  1637. (let ((tmp-1 ($sc-dispatch tmp '(any any . any))))
  1638. (if (and tmp-1 (apply (lambda (x dots y) (ellipsis? dots r mod)) tmp-1))
  1639. (apply (lambda (x dots y)
  1640. (let f ((y y)
  1641. (k (lambda (maps)
  1642. (call-with-values
  1643. (lambda () (gen-syntax src x r (cons '() maps) ellipsis? mod))
  1644. (lambda (x maps)
  1645. (if (null? (car maps))
  1646. (syntax-violation 'syntax "extra ellipsis" src)
  1647. (values (gen-map x (car maps)) (cdr maps))))))))
  1648. (let* ((tmp y) (tmp ($sc-dispatch tmp '(any . any))))
  1649. (if (and tmp (apply (lambda (dots y) (ellipsis? dots r mod)) tmp))
  1650. (apply (lambda (dots y)
  1651. (f y
  1652. (lambda (maps)
  1653. (call-with-values
  1654. (lambda () (k (cons '() maps)))
  1655. (lambda (x maps)
  1656. (if (null? (car maps))
  1657. (syntax-violation 'syntax "extra ellipsis" src)
  1658. (values (gen-mappend x (car maps)) (cdr maps))))))))
  1659. tmp)
  1660. (call-with-values
  1661. (lambda () (gen-syntax src y r maps ellipsis? mod))
  1662. (lambda (y maps)
  1663. (call-with-values
  1664. (lambda () (k maps))
  1665. (lambda (x maps) (values (gen-append x y) maps)))))))))
  1666. tmp-1)
  1667. (let ((tmp-1 ($sc-dispatch tmp '(any . any))))
  1668. (if tmp-1
  1669. (apply (lambda (x y)
  1670. (call-with-values
  1671. (lambda () (gen-syntax src x r maps ellipsis? mod))
  1672. (lambda (x maps)
  1673. (call-with-values
  1674. (lambda () (gen-syntax src y r maps ellipsis? mod))
  1675. (lambda (y maps) (values (gen-cons x y) maps))))))
  1676. tmp-1)
  1677. (let ((tmp ($sc-dispatch tmp '#(vector (any . each-any)))))
  1678. (if tmp
  1679. (apply (lambda (e1 e2)
  1680. (call-with-values
  1681. (lambda () (gen-syntax src (cons e1 e2) r maps ellipsis? mod))
  1682. (lambda (e maps) (values (gen-vector e) maps))))
  1683. tmp)
  1684. (values (list 'quote e) maps))))))))))))
  1685. (gen-ref
  1686. (lambda (src var level maps)
  1687. (cond ((= level 0) (values var maps))
  1688. ((null? maps) (syntax-violation 'syntax "missing ellipsis" src))
  1689. (else
  1690. (call-with-values
  1691. (lambda () (gen-ref src var (- level 1) (cdr maps)))
  1692. (lambda (outer-var outer-maps)
  1693. (let ((b (assq outer-var (car maps))))
  1694. (if b
  1695. (values (cdr b) maps)
  1696. (let ((inner-var (gen-var 'tmp)))
  1697. (values
  1698. inner-var
  1699. (cons (cons (cons outer-var inner-var) (car maps)) outer-maps)))))))))))
  1700. (gen-mappend
  1701. (lambda (e map-env)
  1702. (list 'apply '(primitive append) (gen-map e map-env))))
  1703. (gen-map
  1704. (lambda (e map-env)
  1705. (let ((formals (map cdr map-env))
  1706. (actuals (map (lambda (x) (list 'ref (car x))) map-env)))
  1707. (cond ((eq? (car e) 'ref) (car actuals))
  1708. ((and-map
  1709. (lambda (x) (and (eq? (car x) 'ref) (memq (cadr x) formals)))
  1710. (cdr e))
  1711. (cons 'map
  1712. (cons (list 'primitive (car e))
  1713. (map (let ((r (map cons formals actuals)))
  1714. (lambda (x) (cdr (assq (cadr x) r))))
  1715. (cdr e)))))
  1716. (else (cons 'map (cons (list 'lambda formals e) actuals)))))))
  1717. (gen-cons
  1718. (lambda (x y)
  1719. (let ((key (car y)))
  1720. (cond ((memv key '(quote))
  1721. (cond ((eq? (car x) 'quote) (list 'quote (cons (cadr x) (cadr y))))
  1722. ((eq? (cadr y) '()) (list 'list x))
  1723. (else (list 'cons x y))))
  1724. ((memv key '(list)) (cons 'list (cons x (cdr y))))
  1725. (else (list 'cons x y))))))
  1726. (gen-append (lambda (x y) (if (equal? y ''()) x (list 'append x y))))
  1727. (gen-vector
  1728. (lambda (x)
  1729. (cond ((eq? (car x) 'list) (cons 'vector (cdr x)))
  1730. ((eq? (car x) 'quote) (list 'quote (list->vector (cadr x))))
  1731. (else (list 'list->vector x)))))
  1732. (regen (lambda (x)
  1733. (let ((key (car x)))
  1734. (cond ((memv key '(ref))
  1735. (build-lexical-reference 'value #f (cadr x) (cadr x)))
  1736. ((memv key '(primitive)) (build-primref #f (cadr x)))
  1737. ((memv key '(quote)) (build-data #f (cadr x)))
  1738. ((memv key '(lambda))
  1739. (if (list? (cadr x))
  1740. (build-simple-lambda #f (cadr x) #f (cadr x) '() (regen (caddr x)))
  1741. (error "how did we get here" x)))
  1742. (else (build-primcall #f (car x) (map regen (cdr x)))))))))
  1743. (lambda (e r w s mod)
  1744. (let* ((e (source-wrap e w s mod))
  1745. (tmp e)
  1746. (tmp ($sc-dispatch tmp '(_ any))))
  1747. (if tmp
  1748. (apply (lambda (x)
  1749. (call-with-values
  1750. (lambda () (gen-syntax e x r '() ellipsis? mod))
  1751. (lambda (e maps) (regen e))))
  1752. tmp)
  1753. (syntax-violation 'syntax "bad `syntax' form" e))))))
  1754. (global-extend
  1755. 'core
  1756. 'lambda
  1757. (lambda (e r w s mod)
  1758. (let* ((tmp e) (tmp ($sc-dispatch tmp '(_ any any . each-any))))
  1759. (if tmp
  1760. (apply (lambda (args e1 e2)
  1761. (call-with-values
  1762. (lambda () (lambda-formals args))
  1763. (lambda (req opt rest kw)
  1764. (let lp ((body (cons e1 e2)) (meta '()))
  1765. (let* ((tmp-1 body) (tmp ($sc-dispatch tmp-1 '(any any . each-any))))
  1766. (if (and tmp
  1767. (apply (lambda (docstring e1 e2) (string? (syntax->datum docstring)))
  1768. tmp))
  1769. (apply (lambda (docstring e1 e2)
  1770. (lp (cons e1 e2)
  1771. (append meta (list (cons 'documentation (syntax->datum docstring))))))
  1772. tmp)
  1773. (let ((tmp ($sc-dispatch tmp-1 '(#(vector #(each (any . any))) any . each-any))))
  1774. (if tmp
  1775. (apply (lambda (k v e1 e2)
  1776. (lp (cons e1 e2) (append meta (syntax->datum (map cons k v)))))
  1777. tmp)
  1778. (expand-simple-lambda e r w s mod req rest meta body)))))))))
  1779. tmp)
  1780. (syntax-violation 'lambda "bad lambda" e)))))
  1781. (global-extend
  1782. 'core
  1783. 'lambda*
  1784. (lambda (e r w s mod)
  1785. (let* ((tmp e) (tmp ($sc-dispatch tmp '(_ any any . each-any))))
  1786. (if tmp
  1787. (apply (lambda (args e1 e2)
  1788. (call-with-values
  1789. (lambda ()
  1790. (expand-lambda-case
  1791. e
  1792. r
  1793. w
  1794. s
  1795. mod
  1796. lambda*-formals
  1797. (list (cons args (cons e1 e2)))))
  1798. (lambda (meta lcase) (build-case-lambda s meta lcase))))
  1799. tmp)
  1800. (syntax-violation 'lambda "bad lambda*" e)))))
  1801. (global-extend
  1802. 'core
  1803. 'case-lambda
  1804. (lambda (e r w s mod)
  1805. (letrec*
  1806. ((build-it
  1807. (lambda (meta clauses)
  1808. (call-with-values
  1809. (lambda () (expand-lambda-case e r w s mod lambda-formals clauses))
  1810. (lambda (meta* lcase)
  1811. (build-case-lambda s (append meta meta*) lcase))))))
  1812. (let* ((tmp-1 e)
  1813. (tmp ($sc-dispatch tmp-1 '(_ . #(each (any any . each-any))))))
  1814. (if tmp
  1815. (apply (lambda (args e1 e2)
  1816. (build-it
  1817. '()
  1818. (map (lambda (tmp-2 tmp-1 tmp) (cons tmp (cons tmp-1 tmp-2)))
  1819. e2
  1820. e1
  1821. args)))
  1822. tmp)
  1823. (let ((tmp ($sc-dispatch tmp-1 '(_ any . #(each (any any . each-any))))))
  1824. (if (and tmp
  1825. (apply (lambda (docstring args e1 e2) (string? (syntax->datum docstring)))
  1826. tmp))
  1827. (apply (lambda (docstring args e1 e2)
  1828. (build-it
  1829. (list (cons 'documentation (syntax->datum docstring)))
  1830. (map (lambda (tmp-2 tmp-1 tmp) (cons tmp (cons tmp-1 tmp-2)))
  1831. e2
  1832. e1
  1833. args)))
  1834. tmp)
  1835. (syntax-violation 'case-lambda "bad case-lambda" e))))))))
  1836. (global-extend
  1837. 'core
  1838. 'case-lambda*
  1839. (lambda (e r w s mod)
  1840. (letrec*
  1841. ((build-it
  1842. (lambda (meta clauses)
  1843. (call-with-values
  1844. (lambda () (expand-lambda-case e r w s mod lambda*-formals clauses))
  1845. (lambda (meta* lcase)
  1846. (build-case-lambda s (append meta meta*) lcase))))))
  1847. (let* ((tmp-1 e)
  1848. (tmp ($sc-dispatch tmp-1 '(_ . #(each (any any . each-any))))))
  1849. (if tmp
  1850. (apply (lambda (args e1 e2)
  1851. (build-it
  1852. '()
  1853. (map (lambda (tmp-2 tmp-1 tmp) (cons tmp (cons tmp-1 tmp-2)))
  1854. e2
  1855. e1
  1856. args)))
  1857. tmp)
  1858. (let ((tmp ($sc-dispatch tmp-1 '(_ any . #(each (any any . each-any))))))
  1859. (if (and tmp
  1860. (apply (lambda (docstring args e1 e2) (string? (syntax->datum docstring)))
  1861. tmp))
  1862. (apply (lambda (docstring args e1 e2)
  1863. (build-it
  1864. (list (cons 'documentation (syntax->datum docstring)))
  1865. (map (lambda (tmp-2 tmp-1 tmp) (cons tmp (cons tmp-1 tmp-2)))
  1866. e2
  1867. e1
  1868. args)))
  1869. tmp)
  1870. (syntax-violation 'case-lambda "bad case-lambda*" e))))))))
  1871. (global-extend
  1872. 'core
  1873. 'with-ellipsis
  1874. (lambda (e r w s mod)
  1875. (let* ((tmp e) (tmp ($sc-dispatch tmp '(_ any any . each-any))))
  1876. (if (and tmp (apply (lambda (dots e1 e2) (id? dots)) tmp))
  1877. (apply (lambda (dots e1 e2)
  1878. (let ((id (if (symbol? dots)
  1879. '#{ $sc-ellipsis }#
  1880. (make-syntax-object
  1881. '#{ $sc-ellipsis }#
  1882. (syntax-object-wrap dots)
  1883. (syntax-object-module dots)))))
  1884. (let ((ids (list id))
  1885. (labels (list (gen-label)))
  1886. (bindings (list (cons 'ellipsis (source-wrap dots w s mod)))))
  1887. (let ((nw (make-binding-wrap ids labels w))
  1888. (nr (extend-env labels bindings r)))
  1889. (expand-body (cons e1 e2) (source-wrap e nw s mod) nr nw mod)))))
  1890. tmp)
  1891. (syntax-violation
  1892. 'with-ellipsis
  1893. "bad syntax"
  1894. (source-wrap e w s mod))))))
  1895. (global-extend
  1896. 'core
  1897. 'let
  1898. (letrec*
  1899. ((expand-let
  1900. (lambda (e r w s mod constructor ids vals exps)
  1901. (if (not (valid-bound-ids? ids))
  1902. (syntax-violation 'let "duplicate bound variable" e)
  1903. (let ((labels (gen-labels ids)) (new-vars (map gen-var ids)))
  1904. (let ((nw (make-binding-wrap ids labels w))
  1905. (nr (extend-var-env labels new-vars r)))
  1906. (constructor
  1907. s
  1908. (map syntax->datum ids)
  1909. new-vars
  1910. (map (lambda (x) (expand x r w mod)) vals)
  1911. (expand-body exps (source-wrap e nw s mod) nr nw mod))))))))
  1912. (lambda (e r w s mod)
  1913. (let* ((tmp-1 e)
  1914. (tmp ($sc-dispatch tmp-1 '(_ #(each (any any)) any . each-any))))
  1915. (if (and tmp (apply (lambda (id val e1 e2) (and-map id? id)) tmp))
  1916. (apply (lambda (id val e1 e2)
  1917. (expand-let e r w s mod build-let id val (cons e1 e2)))
  1918. tmp)
  1919. (let ((tmp ($sc-dispatch tmp-1 '(_ any #(each (any any)) any . each-any))))
  1920. (if (and tmp
  1921. (apply (lambda (f id val e1 e2) (and (id? f) (and-map id? id))) tmp))
  1922. (apply (lambda (f id val e1 e2)
  1923. (expand-let e r w s mod build-named-let (cons f id) val (cons e1 e2)))
  1924. tmp)
  1925. (syntax-violation 'let "bad let" (source-wrap e w s mod)))))))))
  1926. (global-extend
  1927. 'core
  1928. 'letrec
  1929. (lambda (e r w s mod)
  1930. (let* ((tmp e)
  1931. (tmp ($sc-dispatch tmp '(_ #(each (any any)) any . each-any))))
  1932. (if (and tmp (apply (lambda (id val e1 e2) (and-map id? id)) tmp))
  1933. (apply (lambda (id val e1 e2)
  1934. (let ((ids id))
  1935. (if (not (valid-bound-ids? ids))
  1936. (syntax-violation 'letrec "duplicate bound variable" e)
  1937. (let ((labels (gen-labels ids)) (new-vars (map gen-var ids)))
  1938. (let ((w (make-binding-wrap ids labels w))
  1939. (r (extend-var-env labels new-vars r)))
  1940. (build-letrec
  1941. s
  1942. #f
  1943. (map syntax->datum ids)
  1944. new-vars
  1945. (map (lambda (x) (expand x r w mod)) val)
  1946. (expand-body (cons e1 e2) (source-wrap e w s mod) r w mod)))))))
  1947. tmp)
  1948. (syntax-violation 'letrec "bad letrec" (source-wrap e w s mod))))))
  1949. (global-extend
  1950. 'core
  1951. 'letrec*
  1952. (lambda (e r w s mod)
  1953. (let* ((tmp e)
  1954. (tmp ($sc-dispatch tmp '(_ #(each (any any)) any . each-any))))
  1955. (if (and tmp (apply (lambda (id val e1 e2) (and-map id? id)) tmp))
  1956. (apply (lambda (id val e1 e2)
  1957. (let ((ids id))
  1958. (if (not (valid-bound-ids? ids))
  1959. (syntax-violation 'letrec* "duplicate bound variable" e)
  1960. (let ((labels (gen-labels ids)) (new-vars (map gen-var ids)))
  1961. (let ((w (make-binding-wrap ids labels w))
  1962. (r (extend-var-env labels new-vars r)))
  1963. (build-letrec
  1964. s
  1965. #t
  1966. (map syntax->datum ids)
  1967. new-vars
  1968. (map (lambda (x) (expand x r w mod)) val)
  1969. (expand-body (cons e1 e2) (source-wrap e w s mod) r w mod)))))))
  1970. tmp)
  1971. (syntax-violation 'letrec* "bad letrec*" (source-wrap e w s mod))))))
  1972. (global-extend
  1973. 'core
  1974. 'set!
  1975. (lambda (e r w s mod)
  1976. (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ any any))))
  1977. (if (and tmp (apply (lambda (id val) (id? id)) tmp))
  1978. (apply (lambda (id val)
  1979. (call-with-values
  1980. (lambda () (resolve-identifier id w r mod #t))
  1981. (lambda (type value id-mod)
  1982. (let ((key type))
  1983. (cond ((memv key '(lexical))
  1984. (build-lexical-assignment
  1985. s
  1986. (syntax->datum id)
  1987. value
  1988. (expand val r w mod)))
  1989. ((memv key '(global))
  1990. (build-global-assignment s value (expand val r w mod) id-mod))
  1991. ((memv key '(macro))
  1992. (if (procedure-property value 'variable-transformer)
  1993. (expand (expand-macro value e r w s #f mod) r '(()) mod)
  1994. (syntax-violation
  1995. 'set!
  1996. "not a variable transformer"
  1997. (wrap e w mod)
  1998. (wrap id w id-mod))))
  1999. ((memv key '(displaced-lexical))
  2000. (syntax-violation 'set! "identifier out of context" (wrap id w mod)))
  2001. (else (syntax-violation 'set! "bad set!" (source-wrap e w s mod))))))))
  2002. tmp)
  2003. (let ((tmp ($sc-dispatch tmp-1 '(_ (any . each-any) any))))
  2004. (if tmp
  2005. (apply (lambda (head tail val)
  2006. (call-with-values
  2007. (lambda () (syntax-type head r '(()) #f #f mod #t))
  2008. (lambda (type value ee* ee ww ss modmod)
  2009. (let ((key type))
  2010. (if (memv key '(module-ref))
  2011. (let ((val (expand val r w mod)))
  2012. (call-with-values
  2013. (lambda () (value (cons head tail) r w mod))
  2014. (lambda (e r w s* mod)
  2015. (let* ((tmp-1 e) (tmp (list tmp-1)))
  2016. (if (and tmp (apply (lambda (e) (id? e)) tmp))
  2017. (apply (lambda (e) (build-global-assignment s (syntax->datum e) val mod))
  2018. tmp)
  2019. (syntax-violation
  2020. #f
  2021. "source expression failed to match any pattern"
  2022. tmp-1))))))
  2023. (build-call
  2024. s
  2025. (expand
  2026. (list '#(syntax-object setter ((top)) (hygiene guile)) head)
  2027. r
  2028. w
  2029. mod)
  2030. (map (lambda (e) (expand e r w mod)) (append tail (list val)))))))))
  2031. tmp)
  2032. (syntax-violation 'set! "bad set!" (source-wrap e w s mod))))))))
  2033. (global-extend
  2034. 'module-ref
  2035. '@
  2036. (lambda (e r w mod)
  2037. (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ each-any any))))
  2038. (if (and tmp
  2039. (apply (lambda (mod id) (and (and-map id? mod) (id? id))) tmp))
  2040. (apply (lambda (mod id)
  2041. (values
  2042. (syntax->datum id)
  2043. r
  2044. '((top))
  2045. #f
  2046. (syntax->datum
  2047. (cons '#(syntax-object public ((top)) (hygiene guile)) mod))))
  2048. tmp)
  2049. (syntax-violation
  2050. #f
  2051. "source expression failed to match any pattern"
  2052. tmp-1)))))
  2053. (global-extend
  2054. 'module-ref
  2055. '@@
  2056. (lambda (e r w mod)
  2057. (letrec*
  2058. ((remodulate
  2059. (lambda (x mod)
  2060. (cond ((pair? x) (cons (remodulate (car x) mod) (remodulate (cdr x) mod)))
  2061. ((syntax-object? x)
  2062. (make-syntax-object
  2063. (remodulate (syntax-object-expression x) mod)
  2064. (syntax-object-wrap x)
  2065. mod))
  2066. ((vector? x)
  2067. (let* ((n (vector-length x)) (v (make-vector n)))
  2068. (let loop ((i 0))
  2069. (if (= i n)
  2070. (begin (if #f #f) v)
  2071. (begin
  2072. (vector-set! v i (remodulate (vector-ref x i) mod))
  2073. (loop (+ i 1)))))))
  2074. (else x)))))
  2075. (let* ((tmp e)
  2076. (tmp-1 ($sc-dispatch
  2077. tmp
  2078. '(_ #(free-id #(syntax-object primitive ((top)) (hygiene guile))) any))))
  2079. (if (and tmp-1
  2080. (apply (lambda (id)
  2081. (and (id? id)
  2082. (equal?
  2083. (cdr (if (syntax-object? id) (syntax-object-module id) mod))
  2084. '(guile))))
  2085. tmp-1))
  2086. (apply (lambda (id) (values (syntax->datum id) r '((top)) #f '(primitive)))
  2087. tmp-1)
  2088. (let ((tmp-1 ($sc-dispatch tmp '(_ each-any any))))
  2089. (if (and tmp-1
  2090. (apply (lambda (mod id) (and (and-map id? mod) (id? id))) tmp-1))
  2091. (apply (lambda (mod id)
  2092. (values
  2093. (syntax->datum id)
  2094. r
  2095. '((top))
  2096. #f
  2097. (syntax->datum
  2098. (cons '#(syntax-object private ((top)) (hygiene guile)) mod))))
  2099. tmp-1)
  2100. (let ((tmp-1 ($sc-dispatch
  2101. tmp
  2102. '(_ #(free-id #(syntax-object @@ ((top)) (hygiene guile)))
  2103. each-any
  2104. any))))
  2105. (if (and tmp-1 (apply (lambda (mod exp) (and-map id? mod)) tmp-1))
  2106. (apply (lambda (mod exp)
  2107. (let ((mod (syntax->datum
  2108. (cons '#(syntax-object private ((top)) (hygiene guile)) mod))))
  2109. (values (remodulate exp mod) r w (source-annotation exp) mod)))
  2110. tmp-1)
  2111. (syntax-violation
  2112. #f
  2113. "source expression failed to match any pattern"
  2114. tmp))))))))))
  2115. (global-extend
  2116. 'core
  2117. 'if
  2118. (lambda (e r w s mod)
  2119. (let* ((tmp e) (tmp-1 ($sc-dispatch tmp '(_ any any))))
  2120. (if tmp-1
  2121. (apply (lambda (test then)
  2122. (build-conditional
  2123. s
  2124. (expand test r w mod)
  2125. (expand then r w mod)
  2126. (build-void #f)))
  2127. tmp-1)
  2128. (let ((tmp-1 ($sc-dispatch tmp '(_ any any any))))
  2129. (if tmp-1
  2130. (apply (lambda (test then else)
  2131. (build-conditional
  2132. s
  2133. (expand test r w mod)
  2134. (expand then r w mod)
  2135. (expand else r w mod)))
  2136. tmp-1)
  2137. (syntax-violation
  2138. #f
  2139. "source expression failed to match any pattern"
  2140. tmp)))))))
  2141. (global-extend 'begin 'begin '())
  2142. (global-extend 'define 'define '())
  2143. (global-extend 'define-syntax 'define-syntax '())
  2144. (global-extend 'define-syntax-parameter 'define-syntax-parameter '())
  2145. (global-extend 'eval-when 'eval-when '())
  2146. (global-extend
  2147. 'core
  2148. 'syntax-case
  2149. (letrec*
  2150. ((convert-pattern
  2151. (lambda (pattern keys ellipsis?)
  2152. (letrec*
  2153. ((cvt* (lambda (p* n ids)
  2154. (let* ((tmp p*) (tmp ($sc-dispatch tmp '(any . any))))
  2155. (if tmp
  2156. (apply (lambda (x y)
  2157. (call-with-values
  2158. (lambda () (cvt* y n ids))
  2159. (lambda (y ids)
  2160. (call-with-values
  2161. (lambda () (cvt x n ids))
  2162. (lambda (x ids) (values (cons x y) ids))))))
  2163. tmp)
  2164. (cvt p* n ids)))))
  2165. (v-reverse
  2166. (lambda (x)
  2167. (let loop ((r '()) (x x))
  2168. (if (not (pair? x)) (values r x) (loop (cons (car x) r) (cdr x))))))
  2169. (cvt (lambda (p n ids)
  2170. (if (id? p)
  2171. (cond ((bound-id-member? p keys) (values (vector 'free-id p) ids))
  2172. ((free-id=? p '#(syntax-object _ ((top)) (hygiene guile)))
  2173. (values '_ ids))
  2174. (else (values 'any (cons (cons p n) ids))))
  2175. (let* ((tmp p) (tmp-1 ($sc-dispatch tmp '(any any))))
  2176. (if (and tmp-1 (apply (lambda (x dots) (ellipsis? dots)) tmp-1))
  2177. (apply (lambda (x dots)
  2178. (call-with-values
  2179. (lambda () (cvt x (+ n 1) ids))
  2180. (lambda (p ids)
  2181. (values (if (eq? p 'any) 'each-any (vector 'each p)) ids))))
  2182. tmp-1)
  2183. (let ((tmp-1 ($sc-dispatch tmp '(any any . any))))
  2184. (if (and tmp-1 (apply (lambda (x dots ys) (ellipsis? dots)) tmp-1))
  2185. (apply (lambda (x dots ys)
  2186. (call-with-values
  2187. (lambda () (cvt* ys n ids))
  2188. (lambda (ys ids)
  2189. (call-with-values
  2190. (lambda () (cvt x (+ n 1) ids))
  2191. (lambda (x ids)
  2192. (call-with-values
  2193. (lambda () (v-reverse ys))
  2194. (lambda (ys e) (values (vector 'each+ x ys e) ids))))))))
  2195. tmp-1)
  2196. (let ((tmp-1 ($sc-dispatch tmp '(any . any))))
  2197. (if tmp-1
  2198. (apply (lambda (x y)
  2199. (call-with-values
  2200. (lambda () (cvt y n ids))
  2201. (lambda (y ids)
  2202. (call-with-values
  2203. (lambda () (cvt x n ids))
  2204. (lambda (x ids) (values (cons x y) ids))))))
  2205. tmp-1)
  2206. (let ((tmp-1 ($sc-dispatch tmp '())))
  2207. (if tmp-1
  2208. (apply (lambda () (values '() ids)) tmp-1)
  2209. (let ((tmp-1 ($sc-dispatch tmp '#(vector each-any))))
  2210. (if tmp-1
  2211. (apply (lambda (x)
  2212. (call-with-values
  2213. (lambda () (cvt x n ids))
  2214. (lambda (p ids) (values (vector 'vector p) ids))))
  2215. tmp-1)
  2216. (let ((x tmp)) (values (vector 'atom (strip p '(()))) ids))))))))))))))))
  2217. (cvt pattern 0 '()))))
  2218. (build-dispatch-call
  2219. (lambda (pvars exp y r mod)
  2220. (let ((ids (map car pvars)) (levels (map cdr pvars)))
  2221. (let ((labels (gen-labels ids)) (new-vars (map gen-var ids)))
  2222. (build-primcall
  2223. #f
  2224. 'apply
  2225. (list (build-simple-lambda
  2226. #f
  2227. (map syntax->datum ids)
  2228. #f
  2229. new-vars
  2230. '()
  2231. (expand
  2232. exp
  2233. (extend-env
  2234. labels
  2235. (map (lambda (var level) (cons 'syntax (cons var level)))
  2236. new-vars
  2237. (map cdr pvars))
  2238. r)
  2239. (make-binding-wrap ids labels '(()))
  2240. mod))
  2241. y))))))
  2242. (gen-clause
  2243. (lambda (x keys clauses r pat fender exp mod)
  2244. (call-with-values
  2245. (lambda ()
  2246. (convert-pattern pat keys (lambda (e) (ellipsis? e r mod))))
  2247. (lambda (p pvars)
  2248. (cond ((not (and-map (lambda (x) (not (ellipsis? (car x) r mod))) pvars))
  2249. (syntax-violation 'syntax-case "misplaced ellipsis" pat))
  2250. ((not (distinct-bound-ids? (map car pvars)))
  2251. (syntax-violation 'syntax-case "duplicate pattern variable" pat))
  2252. (else
  2253. (let ((y (gen-var 'tmp)))
  2254. (build-call
  2255. #f
  2256. (build-simple-lambda
  2257. #f
  2258. (list 'tmp)
  2259. #f
  2260. (list y)
  2261. '()
  2262. (let ((y (build-lexical-reference 'value #f 'tmp y)))
  2263. (build-conditional
  2264. #f
  2265. (let* ((tmp fender) (tmp ($sc-dispatch tmp '#(atom #t))))
  2266. (if tmp
  2267. (apply (lambda () y) tmp)
  2268. (build-conditional
  2269. #f
  2270. y
  2271. (build-dispatch-call pvars fender y r mod)
  2272. (build-data #f #f))))
  2273. (build-dispatch-call pvars exp y r mod)
  2274. (gen-syntax-case x keys clauses r mod))))
  2275. (list (if (eq? p 'any)
  2276. (build-primcall #f 'list (list x))
  2277. (build-primcall #f '$sc-dispatch (list x (build-data #f p)))))))))))))
  2278. (gen-syntax-case
  2279. (lambda (x keys clauses r mod)
  2280. (if (null? clauses)
  2281. (build-primcall
  2282. #f
  2283. 'syntax-violation
  2284. (list (build-data #f #f)
  2285. (build-data #f "source expression failed to match any pattern")
  2286. x))
  2287. (let* ((tmp-1 (car clauses)) (tmp ($sc-dispatch tmp-1 '(any any))))
  2288. (if tmp
  2289. (apply (lambda (pat exp)
  2290. (if (and (id? pat)
  2291. (and-map
  2292. (lambda (x) (not (free-id=? pat x)))
  2293. (cons '#(syntax-object ... ((top)) (hygiene guile)) keys)))
  2294. (if (free-id=? pat '#(syntax-object _ ((top)) (hygiene guile)))
  2295. (expand exp r '(()) mod)
  2296. (let ((labels (list (gen-label))) (var (gen-var pat)))
  2297. (build-call
  2298. #f
  2299. (build-simple-lambda
  2300. #f
  2301. (list (syntax->datum pat))
  2302. #f
  2303. (list var)
  2304. '()
  2305. (expand
  2306. exp
  2307. (extend-env labels (list (cons 'syntax (cons var 0))) r)
  2308. (make-binding-wrap (list pat) labels '(()))
  2309. mod))
  2310. (list x))))
  2311. (gen-clause x keys (cdr clauses) r pat #t exp mod)))
  2312. tmp)
  2313. (let ((tmp ($sc-dispatch tmp-1 '(any any any))))
  2314. (if tmp
  2315. (apply (lambda (pat fender exp)
  2316. (gen-clause x keys (cdr clauses) r pat fender exp mod))
  2317. tmp)
  2318. (syntax-violation 'syntax-case "invalid clause" (car clauses))))))))))
  2319. (lambda (e r w s mod)
  2320. (let* ((e (source-wrap e w s mod))
  2321. (tmp-1 e)
  2322. (tmp ($sc-dispatch tmp-1 '(_ any each-any . each-any))))
  2323. (if tmp
  2324. (apply (lambda (val key m)
  2325. (if (and-map (lambda (x) (and (id? x) (not (ellipsis? x r mod)))) key)
  2326. (let ((x (gen-var 'tmp)))
  2327. (build-call
  2328. s
  2329. (build-simple-lambda
  2330. #f
  2331. (list 'tmp)
  2332. #f
  2333. (list x)
  2334. '()
  2335. (gen-syntax-case
  2336. (build-lexical-reference 'value #f 'tmp x)
  2337. key
  2338. m
  2339. r
  2340. mod))
  2341. (list (expand val r '(()) mod))))
  2342. (syntax-violation 'syntax-case "invalid literals list" e)))
  2343. tmp)
  2344. (syntax-violation
  2345. #f
  2346. "source expression failed to match any pattern"
  2347. tmp-1))))))
  2348. (set! macroexpand
  2349. (lambda* (x #:optional (m 'e) (esew '(eval)))
  2350. (expand-top-sequence
  2351. (list x)
  2352. '()
  2353. '((top))
  2354. #f
  2355. m
  2356. esew
  2357. (cons 'hygiene (module-name (current-module))))))
  2358. (set! identifier? (lambda (x) (nonsymbol-id? x)))
  2359. (set! datum->syntax
  2360. (lambda (id datum)
  2361. (make-syntax-object
  2362. datum
  2363. (syntax-object-wrap id)
  2364. (syntax-object-module id))))
  2365. (set! syntax->datum (lambda (x) (strip x '(()))))
  2366. (set! syntax-source (lambda (x) (source-annotation x)))
  2367. (set! generate-temporaries
  2368. (lambda (ls)
  2369. (let ((x ls))
  2370. (if (not (list? x))
  2371. (syntax-violation 'generate-temporaries "invalid argument" x)))
  2372. (let ((mod (cons 'hygiene (module-name (current-module)))))
  2373. (map (lambda (x) (wrap (gensym "t-") '((top)) mod)) ls))))
  2374. (set! free-identifier=?
  2375. (lambda (x y)
  2376. (let ((x x))
  2377. (if (not (nonsymbol-id? x))
  2378. (syntax-violation 'free-identifier=? "invalid argument" x)))
  2379. (let ((x y))
  2380. (if (not (nonsymbol-id? x))
  2381. (syntax-violation 'free-identifier=? "invalid argument" x)))
  2382. (free-id=? x y)))
  2383. (set! bound-identifier=?
  2384. (lambda (x y)
  2385. (let ((x x))
  2386. (if (not (nonsymbol-id? x))
  2387. (syntax-violation 'bound-identifier=? "invalid argument" x)))
  2388. (let ((x y))
  2389. (if (not (nonsymbol-id? x))
  2390. (syntax-violation 'bound-identifier=? "invalid argument" x)))
  2391. (bound-id=? x y)))
  2392. (set! syntax-violation
  2393. (lambda* (who message form #:optional (subform #f))
  2394. (let ((x who))
  2395. (if (not (let ((x x)) (or (not x) (string? x) (symbol? x))))
  2396. (syntax-violation 'syntax-violation "invalid argument" x)))
  2397. (let ((x message))
  2398. (if (not (string? x))
  2399. (syntax-violation 'syntax-violation "invalid argument" x)))
  2400. (throw 'syntax-error
  2401. who
  2402. message
  2403. (or (source-annotation subform) (source-annotation form))
  2404. (strip form '(()))
  2405. (and subform (strip subform '(()))))))
  2406. (letrec*
  2407. ((syntax-module
  2408. (lambda (id)
  2409. (let ((x id))
  2410. (if (not (nonsymbol-id? x))
  2411. (syntax-violation 'syntax-module "invalid argument" x)))
  2412. (let ((mod (syntax-object-module id)))
  2413. (and (not (equal? mod '(primitive))) (cdr mod)))))
  2414. (syntax-local-binding
  2415. (lambda* (id
  2416. #:key
  2417. (resolve-syntax-parameters? #t #:resolve-syntax-parameters?))
  2418. (let ((x id))
  2419. (if (not (nonsymbol-id? x))
  2420. (syntax-violation 'syntax-local-binding "invalid argument" x)))
  2421. (with-transformer-environment
  2422. (lambda (e r w s rib mod)
  2423. (letrec*
  2424. ((strip-anti-mark
  2425. (lambda (w)
  2426. (let ((ms (car w)) (s (cdr w)))
  2427. (if (and (pair? ms) (eq? (car ms) #f))
  2428. (cons (cdr ms) (if rib (cons rib (cdr s)) (cdr s)))
  2429. (cons ms (if rib (cons rib s) s)))))))
  2430. (call-with-values
  2431. (lambda ()
  2432. (resolve-identifier
  2433. (syntax-object-expression id)
  2434. (strip-anti-mark (syntax-object-wrap id))
  2435. r
  2436. (syntax-object-module id)
  2437. resolve-syntax-parameters?))
  2438. (lambda (type value mod)
  2439. (let ((key type))
  2440. (cond ((memv key '(lexical)) (values 'lexical value))
  2441. ((memv key '(macro)) (values 'macro value))
  2442. ((memv key '(syntax-parameter))
  2443. (values 'syntax-parameter (car value)))
  2444. ((memv key '(syntax)) (values 'pattern-variable value))
  2445. ((memv key '(displaced-lexical)) (values 'displaced-lexical #f))
  2446. ((memv key '(global))
  2447. (if (equal? mod '(primitive))
  2448. (values 'primitive value)
  2449. (values 'global (cons value (cdr mod)))))
  2450. ((memv key '(ellipsis))
  2451. (values
  2452. 'ellipsis
  2453. (make-syntax-object
  2454. (syntax-object-expression value)
  2455. (anti-mark (syntax-object-wrap value))
  2456. (syntax-object-module value))))
  2457. (else (values 'other #f)))))))))))
  2458. (syntax-locally-bound-identifiers
  2459. (lambda (id)
  2460. (let ((x id))
  2461. (if (not (nonsymbol-id? x))
  2462. (syntax-violation
  2463. 'syntax-locally-bound-identifiers
  2464. "invalid argument"
  2465. x)))
  2466. (locally-bound-identifiers
  2467. (syntax-object-wrap id)
  2468. (syntax-object-module id)))))
  2469. (define! 'syntax-module syntax-module)
  2470. (define! 'syntax-local-binding syntax-local-binding)
  2471. (define!
  2472. 'syntax-locally-bound-identifiers
  2473. syntax-locally-bound-identifiers))
  2474. (letrec*
  2475. ((match-each
  2476. (lambda (e p w mod)
  2477. (cond ((pair? e)
  2478. (let ((first (match (car e) p w '() mod)))
  2479. (and first
  2480. (let ((rest (match-each (cdr e) p w mod)))
  2481. (and rest (cons first rest))))))
  2482. ((null? e) '())
  2483. ((syntax-object? e)
  2484. (match-each
  2485. (syntax-object-expression e)
  2486. p
  2487. (join-wraps w (syntax-object-wrap e))
  2488. (syntax-object-module e)))
  2489. (else #f))))
  2490. (match-each+
  2491. (lambda (e x-pat y-pat z-pat w r mod)
  2492. (let f ((e e) (w w))
  2493. (cond ((pair? e)
  2494. (call-with-values
  2495. (lambda () (f (cdr e) w))
  2496. (lambda (xr* y-pat r)
  2497. (if r
  2498. (if (null? y-pat)
  2499. (let ((xr (match (car e) x-pat w '() mod)))
  2500. (if xr (values (cons xr xr*) y-pat r) (values #f #f #f)))
  2501. (values '() (cdr y-pat) (match (car e) (car y-pat) w r mod)))
  2502. (values #f #f #f)))))
  2503. ((syntax-object? e)
  2504. (f (syntax-object-expression e) (join-wraps w e)))
  2505. (else (values '() y-pat (match e z-pat w r mod)))))))
  2506. (match-each-any
  2507. (lambda (e w mod)
  2508. (cond ((pair? e)
  2509. (let ((l (match-each-any (cdr e) w mod)))
  2510. (and l (cons (wrap (car e) w mod) l))))
  2511. ((null? e) '())
  2512. ((syntax-object? e)
  2513. (match-each-any
  2514. (syntax-object-expression e)
  2515. (join-wraps w (syntax-object-wrap e))
  2516. mod))
  2517. (else #f))))
  2518. (match-empty
  2519. (lambda (p r)
  2520. (cond ((null? p) r)
  2521. ((eq? p '_) r)
  2522. ((eq? p 'any) (cons '() r))
  2523. ((pair? p) (match-empty (car p) (match-empty (cdr p) r)))
  2524. ((eq? p 'each-any) (cons '() r))
  2525. (else
  2526. (let ((key (vector-ref p 0)))
  2527. (cond ((memv key '(each)) (match-empty (vector-ref p 1) r))
  2528. ((memv key '(each+))
  2529. (match-empty
  2530. (vector-ref p 1)
  2531. (match-empty
  2532. (reverse (vector-ref p 2))
  2533. (match-empty (vector-ref p 3) r))))
  2534. ((memv key '(free-id atom)) r)
  2535. ((memv key '(vector)) (match-empty (vector-ref p 1) r))))))))
  2536. (combine
  2537. (lambda (r* r)
  2538. (if (null? (car r*)) r (cons (map car r*) (combine (map cdr r*) r)))))
  2539. (match*
  2540. (lambda (e p w r mod)
  2541. (cond ((null? p) (and (null? e) r))
  2542. ((pair? p)
  2543. (and (pair? e)
  2544. (match (car e) (car p) w (match (cdr e) (cdr p) w r mod) mod)))
  2545. ((eq? p 'each-any)
  2546. (let ((l (match-each-any e w mod))) (and l (cons l r))))
  2547. (else
  2548. (let ((key (vector-ref p 0)))
  2549. (cond ((memv key '(each))
  2550. (if (null? e)
  2551. (match-empty (vector-ref p 1) r)
  2552. (let ((l (match-each e (vector-ref p 1) w mod)))
  2553. (and l
  2554. (let collect ((l l))
  2555. (if (null? (car l)) r (cons (map car l) (collect (map cdr l)))))))))
  2556. ((memv key '(each+))
  2557. (call-with-values
  2558. (lambda ()
  2559. (match-each+
  2560. e
  2561. (vector-ref p 1)
  2562. (vector-ref p 2)
  2563. (vector-ref p 3)
  2564. w
  2565. r
  2566. mod))
  2567. (lambda (xr* y-pat r)
  2568. (and r
  2569. (null? y-pat)
  2570. (if (null? xr*) (match-empty (vector-ref p 1) r) (combine xr* r))))))
  2571. ((memv key '(free-id))
  2572. (and (id? e) (free-id=? (wrap e w mod) (vector-ref p 1)) r))
  2573. ((memv key '(atom)) (and (equal? (vector-ref p 1) (strip e w)) r))
  2574. ((memv key '(vector))
  2575. (and (vector? e) (match (vector->list e) (vector-ref p 1) w r mod)))))))))
  2576. (match (lambda (e p w r mod)
  2577. (cond ((not r) #f)
  2578. ((eq? p '_) r)
  2579. ((eq? p 'any) (cons (wrap e w mod) r))
  2580. ((syntax-object? e)
  2581. (match*
  2582. (syntax-object-expression e)
  2583. p
  2584. (join-wraps w (syntax-object-wrap e))
  2585. r
  2586. (syntax-object-module e)))
  2587. (else (match* e p w r mod))))))
  2588. (set! $sc-dispatch
  2589. (lambda (e p)
  2590. (cond ((eq? p 'any) (list e))
  2591. ((eq? p '_) '())
  2592. ((syntax-object? e)
  2593. (match*
  2594. (syntax-object-expression e)
  2595. p
  2596. (syntax-object-wrap e)
  2597. '()
  2598. (syntax-object-module e)))
  2599. (else (match* e p '(()) '() #f)))))))
  2600. (define with-syntax
  2601. (make-syntax-transformer
  2602. 'with-syntax
  2603. 'macro
  2604. (lambda (x)
  2605. (let ((tmp x))
  2606. (let ((tmp-1 ($sc-dispatch tmp '(_ () any . each-any))))
  2607. (if tmp-1
  2608. (apply (lambda (e1 e2)
  2609. (cons '#(syntax-object let ((top)) (hygiene guile))
  2610. (cons '() (cons e1 e2))))
  2611. tmp-1)
  2612. (let ((tmp-1 ($sc-dispatch tmp '(_ ((any any)) any . each-any))))
  2613. (if tmp-1
  2614. (apply (lambda (out in e1 e2)
  2615. (list '#(syntax-object syntax-case ((top)) (hygiene guile))
  2616. in
  2617. '()
  2618. (list out
  2619. (cons '#(syntax-object let ((top)) (hygiene guile))
  2620. (cons '() (cons e1 e2))))))
  2621. tmp-1)
  2622. (let ((tmp-1 ($sc-dispatch tmp '(_ #(each (any any)) any . each-any))))
  2623. (if tmp-1
  2624. (apply (lambda (out in e1 e2)
  2625. (list '#(syntax-object syntax-case ((top)) (hygiene guile))
  2626. (cons '#(syntax-object list ((top)) (hygiene guile)) in)
  2627. '()
  2628. (list out
  2629. (cons '#(syntax-object let ((top)) (hygiene guile))
  2630. (cons '() (cons e1 e2))))))
  2631. tmp-1)
  2632. (syntax-violation
  2633. #f
  2634. "source expression failed to match any pattern"
  2635. tmp)))))))))))
  2636. (define syntax-error
  2637. (make-syntax-transformer
  2638. 'syntax-error
  2639. 'macro
  2640. (lambda (x)
  2641. (let ((tmp-1 x))
  2642. (let ((tmp ($sc-dispatch tmp-1 '(_ (any . any) any . each-any))))
  2643. (if (if tmp
  2644. (apply (lambda (keyword operands message arg)
  2645. (string? (syntax->datum message)))
  2646. tmp)
  2647. #f)
  2648. (apply (lambda (keyword operands message arg)
  2649. (syntax-violation
  2650. (syntax->datum keyword)
  2651. (string-join
  2652. (cons (syntax->datum message)
  2653. (map (lambda (x) (object->string (syntax->datum x))) arg)))
  2654. (if (syntax->datum keyword) (cons keyword operands) #f)))
  2655. tmp)
  2656. (let ((tmp ($sc-dispatch tmp-1 '(_ any . each-any))))
  2657. (if (if tmp
  2658. (apply (lambda (message arg) (string? (syntax->datum message))) tmp)
  2659. #f)
  2660. (apply (lambda (message arg)
  2661. (cons '#(syntax-object
  2662. syntax-error
  2663. ((top)
  2664. #(ribcage
  2665. #(syntax-error)
  2666. #((top))
  2667. #(((hygiene guile)
  2668. .
  2669. #(syntax-object syntax-error ((top)) (hygiene guile))))))
  2670. (hygiene guile))
  2671. (cons '(#f) (cons message arg))))
  2672. tmp)
  2673. (syntax-violation
  2674. #f
  2675. "source expression failed to match any pattern"
  2676. tmp-1)))))))))
  2677. (define syntax-rules
  2678. (make-syntax-transformer
  2679. 'syntax-rules
  2680. 'macro
  2681. (lambda (xx)
  2682. (letrec*
  2683. ((expand-clause
  2684. (lambda (clause)
  2685. (let ((tmp-1 clause))
  2686. (let ((tmp ($sc-dispatch
  2687. tmp-1
  2688. '((any . any)
  2689. (#(free-id #(syntax-object syntax-error ((top)) (hygiene guile)))
  2690. any
  2691. .
  2692. each-any)))))
  2693. (if (if tmp
  2694. (apply (lambda (keyword pattern message arg)
  2695. (string? (syntax->datum message)))
  2696. tmp)
  2697. #f)
  2698. (apply (lambda (keyword pattern message arg)
  2699. (list (cons '#(syntax-object dummy ((top)) (hygiene guile)) pattern)
  2700. (list '#(syntax-object syntax ((top)) (hygiene guile))
  2701. (cons '#(syntax-object syntax-error ((top)) (hygiene guile))
  2702. (cons (cons '#(syntax-object dummy ((top)) (hygiene guile)) pattern)
  2703. (cons message arg))))))
  2704. tmp)
  2705. (let ((tmp ($sc-dispatch tmp-1 '((any . any) any))))
  2706. (if tmp
  2707. (apply (lambda (keyword pattern template)
  2708. (list (cons '#(syntax-object dummy ((top)) (hygiene guile)) pattern)
  2709. (list '#(syntax-object syntax ((top)) (hygiene guile)) template)))
  2710. tmp)
  2711. (syntax-violation
  2712. #f
  2713. "source expression failed to match any pattern"
  2714. tmp-1))))))))
  2715. (expand-syntax-rules
  2716. (lambda (dots keys docstrings clauses)
  2717. (let ((tmp-1 (list keys docstrings clauses (map expand-clause clauses))))
  2718. (let ((tmp ($sc-dispatch
  2719. tmp-1
  2720. '(each-any each-any #(each ((any . any) any)) each-any))))
  2721. (if tmp
  2722. (apply (lambda (k docstring keyword pattern template clause)
  2723. (let ((tmp (cons '#(syntax-object lambda ((top)) (hygiene guile))
  2724. (cons '(#(syntax-object x ((top)) (hygiene guile)))
  2725. (append
  2726. docstring
  2727. (list (vector
  2728. '(#(syntax-object macro-type ((top)) (hygiene guile))
  2729. .
  2730. #(syntax-object
  2731. syntax-rules
  2732. ((top)
  2733. #(ribcage
  2734. #(syntax-rules)
  2735. #((top))
  2736. #(((hygiene guile)
  2737. .
  2738. #(syntax-object
  2739. syntax-rules
  2740. ((top))
  2741. (hygiene guile))))))
  2742. (hygiene guile)))
  2743. (cons '#(syntax-object patterns ((top)) (hygiene guile))
  2744. pattern))
  2745. (cons '#(syntax-object syntax-case ((top)) (hygiene guile))
  2746. (cons '#(syntax-object x ((top)) (hygiene guile))
  2747. (cons k clause)))))))))
  2748. (let ((form tmp))
  2749. (if dots
  2750. (let ((tmp dots))
  2751. (let ((dots tmp))
  2752. (list '#(syntax-object with-ellipsis ((top)) (hygiene guile))
  2753. dots
  2754. form)))
  2755. form))))
  2756. tmp)
  2757. (syntax-violation
  2758. #f
  2759. "source expression failed to match any pattern"
  2760. tmp-1)))))))
  2761. (let ((tmp xx))
  2762. (let ((tmp-1 ($sc-dispatch tmp '(_ each-any . #(each ((any . any) any))))))
  2763. (if tmp-1
  2764. (apply (lambda (k keyword pattern template)
  2765. (expand-syntax-rules
  2766. #f
  2767. k
  2768. '()
  2769. (map (lambda (tmp-2 tmp-1 tmp) (list (cons tmp tmp-1) tmp-2))
  2770. template
  2771. pattern
  2772. keyword)))
  2773. tmp-1)
  2774. (let ((tmp-1 ($sc-dispatch tmp '(_ each-any any . #(each ((any . any) any))))))
  2775. (if (if tmp-1
  2776. (apply (lambda (k docstring keyword pattern template)
  2777. (string? (syntax->datum docstring)))
  2778. tmp-1)
  2779. #f)
  2780. (apply (lambda (k docstring keyword pattern template)
  2781. (expand-syntax-rules
  2782. #f
  2783. k
  2784. (list docstring)
  2785. (map (lambda (tmp-2 tmp-1 tmp) (list (cons tmp tmp-1) tmp-2))
  2786. template
  2787. pattern
  2788. keyword)))
  2789. tmp-1)
  2790. (let ((tmp-1 ($sc-dispatch tmp '(_ any each-any . #(each ((any . any) any))))))
  2791. (if (if tmp-1
  2792. (apply (lambda (dots k keyword pattern template) (identifier? dots))
  2793. tmp-1)
  2794. #f)
  2795. (apply (lambda (dots k keyword pattern template)
  2796. (expand-syntax-rules
  2797. dots
  2798. k
  2799. '()
  2800. (map (lambda (tmp-2 tmp-1 tmp) (list (cons tmp tmp-1) tmp-2))
  2801. template
  2802. pattern
  2803. keyword)))
  2804. tmp-1)
  2805. (let ((tmp-1 ($sc-dispatch tmp '(_ any each-any any . #(each ((any . any) any))))))
  2806. (if (if tmp-1
  2807. (apply (lambda (dots k docstring keyword pattern template)
  2808. (if (identifier? dots) (string? (syntax->datum docstring)) #f))
  2809. tmp-1)
  2810. #f)
  2811. (apply (lambda (dots k docstring keyword pattern template)
  2812. (expand-syntax-rules
  2813. dots
  2814. k
  2815. (list docstring)
  2816. (map (lambda (tmp-2 tmp-1 tmp) (list (cons tmp tmp-1) tmp-2))
  2817. template
  2818. pattern
  2819. keyword)))
  2820. tmp-1)
  2821. (syntax-violation
  2822. #f
  2823. "source expression failed to match any pattern"
  2824. tmp))))))))))))))
  2825. (define define-syntax-rule
  2826. (make-syntax-transformer
  2827. 'define-syntax-rule
  2828. 'macro
  2829. (lambda (x)
  2830. (let ((tmp-1 x))
  2831. (let ((tmp ($sc-dispatch tmp-1 '(_ (any . any) any))))
  2832. (if tmp
  2833. (apply (lambda (name pattern template)
  2834. (list '#(syntax-object define-syntax ((top)) (hygiene guile))
  2835. name
  2836. (list '#(syntax-object syntax-rules ((top)) (hygiene guile))
  2837. '()
  2838. (list (cons '#(syntax-object _ ((top)) (hygiene guile)) pattern)
  2839. template))))
  2840. tmp)
  2841. (let ((tmp ($sc-dispatch tmp-1 '(_ (any . any) any any))))
  2842. (if (if tmp
  2843. (apply (lambda (name pattern docstring template)
  2844. (string? (syntax->datum docstring)))
  2845. tmp)
  2846. #f)
  2847. (apply (lambda (name pattern docstring template)
  2848. (list '#(syntax-object define-syntax ((top)) (hygiene guile))
  2849. name
  2850. (list '#(syntax-object syntax-rules ((top)) (hygiene guile))
  2851. '()
  2852. docstring
  2853. (list (cons '#(syntax-object _ ((top)) (hygiene guile)) pattern)
  2854. template))))
  2855. tmp)
  2856. (syntax-violation
  2857. #f
  2858. "source expression failed to match any pattern"
  2859. tmp-1)))))))))
  2860. (define let*
  2861. (make-syntax-transformer
  2862. 'let*
  2863. 'macro
  2864. (lambda (x)
  2865. (let ((tmp-1 x))
  2866. (let ((tmp ($sc-dispatch tmp-1 '(any #(each (any any)) any . each-any))))
  2867. (if (if tmp
  2868. (apply (lambda (let* x v e1 e2) (and-map identifier? x)) tmp)
  2869. #f)
  2870. (apply (lambda (let* x v e1 e2)
  2871. (let f ((bindings (map list x v)))
  2872. (if (null? bindings)
  2873. (cons '#(syntax-object let ((top)) (hygiene guile))
  2874. (cons '() (cons e1 e2)))
  2875. (let ((tmp-1 (list (f (cdr bindings)) (car bindings))))
  2876. (let ((tmp ($sc-dispatch tmp-1 '(any any))))
  2877. (if tmp
  2878. (apply (lambda (body binding)
  2879. (list '#(syntax-object let ((top)) (hygiene guile))
  2880. (list binding)
  2881. body))
  2882. tmp)
  2883. (syntax-violation
  2884. #f
  2885. "source expression failed to match any pattern"
  2886. tmp-1)))))))
  2887. tmp)
  2888. (syntax-violation
  2889. #f
  2890. "source expression failed to match any pattern"
  2891. tmp-1)))))))
  2892. (define quasiquote
  2893. (make-syntax-transformer
  2894. 'quasiquote
  2895. 'macro
  2896. (letrec*
  2897. ((quasi (lambda (p lev)
  2898. (let ((tmp p))
  2899. (let ((tmp-1 ($sc-dispatch
  2900. tmp
  2901. '(#(free-id #(syntax-object unquote ((top)) (hygiene guile))) any))))
  2902. (if tmp-1
  2903. (apply (lambda (p)
  2904. (if (= lev 0)
  2905. (list "value" p)
  2906. (quasicons
  2907. '("quote" #(syntax-object unquote ((top)) (hygiene guile)))
  2908. (quasi (list p) (- lev 1)))))
  2909. tmp-1)
  2910. (let ((tmp-1 ($sc-dispatch
  2911. tmp
  2912. '(#(free-id
  2913. #(syntax-object
  2914. quasiquote
  2915. ((top)
  2916. #(ribcage
  2917. #(quasiquote)
  2918. #((top))
  2919. #(((hygiene guile)
  2920. .
  2921. #(syntax-object quasiquote ((top)) (hygiene guile))))))
  2922. (hygiene guile)))
  2923. any))))
  2924. (if tmp-1
  2925. (apply (lambda (p)
  2926. (quasicons
  2927. '("quote"
  2928. #(syntax-object
  2929. quasiquote
  2930. ((top)
  2931. #(ribcage
  2932. #(quasiquote)
  2933. #((top))
  2934. #(((hygiene guile)
  2935. .
  2936. #(syntax-object quasiquote ((top)) (hygiene guile))))))
  2937. (hygiene guile)))
  2938. (quasi (list p) (+ lev 1))))
  2939. tmp-1)
  2940. (let ((tmp-1 ($sc-dispatch tmp '(any . any))))
  2941. (if tmp-1
  2942. (apply (lambda (p q)
  2943. (let ((tmp-1 p))
  2944. (let ((tmp ($sc-dispatch
  2945. tmp-1
  2946. '(#(free-id #(syntax-object unquote ((top)) (hygiene guile)))
  2947. .
  2948. each-any))))
  2949. (if tmp
  2950. (apply (lambda (p)
  2951. (if (= lev 0)
  2952. (quasilist*
  2953. (map (lambda (tmp) (list "value" tmp)) p)
  2954. (quasi q lev))
  2955. (quasicons
  2956. (quasicons
  2957. '("quote" #(syntax-object unquote ((top)) (hygiene guile)))
  2958. (quasi p (- lev 1)))
  2959. (quasi q lev))))
  2960. tmp)
  2961. (let ((tmp ($sc-dispatch
  2962. tmp-1
  2963. '(#(free-id
  2964. #(syntax-object unquote-splicing ((top)) (hygiene guile)))
  2965. .
  2966. each-any))))
  2967. (if tmp
  2968. (apply (lambda (p)
  2969. (if (= lev 0)
  2970. (quasiappend
  2971. (map (lambda (tmp) (list "value" tmp)) p)
  2972. (quasi q lev))
  2973. (quasicons
  2974. (quasicons
  2975. '("quote"
  2976. #(syntax-object
  2977. unquote-splicing
  2978. ((top))
  2979. (hygiene guile)))
  2980. (quasi p (- lev 1)))
  2981. (quasi q lev))))
  2982. tmp)
  2983. (quasicons (quasi p lev) (quasi q lev))))))))
  2984. tmp-1)
  2985. (let ((tmp-1 ($sc-dispatch tmp '#(vector each-any))))
  2986. (if tmp-1
  2987. (apply (lambda (x) (quasivector (vquasi x lev))) tmp-1)
  2988. (let ((p tmp)) (list "quote" p)))))))))))))
  2989. (vquasi
  2990. (lambda (p lev)
  2991. (let ((tmp p))
  2992. (let ((tmp-1 ($sc-dispatch tmp '(any . any))))
  2993. (if tmp-1
  2994. (apply (lambda (p q)
  2995. (let ((tmp-1 p))
  2996. (let ((tmp ($sc-dispatch
  2997. tmp-1
  2998. '(#(free-id #(syntax-object unquote ((top)) (hygiene guile)))
  2999. .
  3000. each-any))))
  3001. (if tmp
  3002. (apply (lambda (p)
  3003. (if (= lev 0)
  3004. (quasilist* (map (lambda (tmp) (list "value" tmp)) p) (vquasi q lev))
  3005. (quasicons
  3006. (quasicons
  3007. '("quote" #(syntax-object unquote ((top)) (hygiene guile)))
  3008. (quasi p (- lev 1)))
  3009. (vquasi q lev))))
  3010. tmp)
  3011. (let ((tmp ($sc-dispatch
  3012. tmp-1
  3013. '(#(free-id #(syntax-object unquote-splicing ((top)) (hygiene guile)))
  3014. .
  3015. each-any))))
  3016. (if tmp
  3017. (apply (lambda (p)
  3018. (if (= lev 0)
  3019. (quasiappend
  3020. (map (lambda (tmp) (list "value" tmp)) p)
  3021. (vquasi q lev))
  3022. (quasicons
  3023. (quasicons
  3024. '("quote" #(syntax-object unquote-splicing ((top)) (hygiene guile)))
  3025. (quasi p (- lev 1)))
  3026. (vquasi q lev))))
  3027. tmp)
  3028. (quasicons (quasi p lev) (vquasi q lev))))))))
  3029. tmp-1)
  3030. (let ((tmp-1 ($sc-dispatch tmp '())))
  3031. (if tmp-1
  3032. (apply (lambda () '("quote" ())) tmp-1)
  3033. (syntax-violation
  3034. #f
  3035. "source expression failed to match any pattern"
  3036. tmp))))))))
  3037. (quasicons
  3038. (lambda (x y)
  3039. (let ((tmp-1 (list x y)))
  3040. (let ((tmp ($sc-dispatch tmp-1 '(any any))))
  3041. (if tmp
  3042. (apply (lambda (x y)
  3043. (let ((tmp y))
  3044. (let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") any))))
  3045. (if tmp-1
  3046. (apply (lambda (dy)
  3047. (let ((tmp x))
  3048. (let ((tmp ($sc-dispatch tmp '(#(atom "quote") any))))
  3049. (if tmp
  3050. (apply (lambda (dx) (list "quote" (cons dx dy))) tmp)
  3051. (if (null? dy) (list "list" x) (list "list*" x y))))))
  3052. tmp-1)
  3053. (let ((tmp-1 ($sc-dispatch tmp '(#(atom "list") . any))))
  3054. (if tmp-1
  3055. (apply (lambda (stuff) (cons "list" (cons x stuff))) tmp-1)
  3056. (let ((tmp ($sc-dispatch tmp '(#(atom "list*") . any))))
  3057. (if tmp
  3058. (apply (lambda (stuff) (cons "list*" (cons x stuff))) tmp)
  3059. (list "list*" x y)))))))))
  3060. tmp)
  3061. (syntax-violation
  3062. #f
  3063. "source expression failed to match any pattern"
  3064. tmp-1))))))
  3065. (quasiappend
  3066. (lambda (x y)
  3067. (let ((tmp y))
  3068. (let ((tmp ($sc-dispatch tmp '(#(atom "quote") ()))))
  3069. (if tmp
  3070. (apply (lambda ()
  3071. (if (null? x)
  3072. '("quote" ())
  3073. (if (null? (cdr x))
  3074. (car x)
  3075. (let ((tmp-1 x))
  3076. (let ((tmp ($sc-dispatch tmp-1 'each-any)))
  3077. (if tmp
  3078. (apply (lambda (p) (cons "append" p)) tmp)
  3079. (syntax-violation
  3080. #f
  3081. "source expression failed to match any pattern"
  3082. tmp-1)))))))
  3083. tmp)
  3084. (if (null? x)
  3085. y
  3086. (let ((tmp-1 (list x y)))
  3087. (let ((tmp ($sc-dispatch tmp-1 '(each-any any))))
  3088. (if tmp
  3089. (apply (lambda (p y) (cons "append" (append p (list y)))) tmp)
  3090. (syntax-violation
  3091. #f
  3092. "source expression failed to match any pattern"
  3093. tmp-1))))))))))
  3094. (quasilist*
  3095. (lambda (x y)
  3096. (let f ((x x)) (if (null? x) y (quasicons (car x) (f (cdr x)))))))
  3097. (quasivector
  3098. (lambda (x)
  3099. (let ((tmp x))
  3100. (let ((tmp ($sc-dispatch tmp '(#(atom "quote") each-any))))
  3101. (if tmp
  3102. (apply (lambda (x) (list "quote" (list->vector x))) tmp)
  3103. (let f ((y x)
  3104. (k (lambda (ls)
  3105. (let ((tmp-1 ls))
  3106. (let ((tmp ($sc-dispatch tmp-1 'each-any)))
  3107. (if tmp
  3108. (apply (lambda (t) (cons "vector" t)) tmp)
  3109. (syntax-violation
  3110. #f
  3111. "source expression failed to match any pattern"
  3112. tmp-1)))))))
  3113. (let ((tmp y))
  3114. (let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") each-any))))
  3115. (if tmp-1
  3116. (apply (lambda (y) (k (map (lambda (tmp) (list "quote" tmp)) y)))
  3117. tmp-1)
  3118. (let ((tmp-1 ($sc-dispatch tmp '(#(atom "list") . each-any))))
  3119. (if tmp-1
  3120. (apply (lambda (y) (k y)) tmp-1)
  3121. (let ((tmp-1 ($sc-dispatch tmp '(#(atom "list*") . #(each+ any (any) ())))))
  3122. (if tmp-1
  3123. (apply (lambda (y z) (f z (lambda (ls) (k (append y ls))))) tmp-1)
  3124. (let ((else tmp))
  3125. (let ((tmp x)) (let ((t tmp)) (list "list->vector" t)))))))))))))))))
  3126. (emit (lambda (x)
  3127. (let ((tmp x))
  3128. (let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") any))))
  3129. (if tmp-1
  3130. (apply (lambda (x) (list '#(syntax-object quote ((top)) (hygiene guile)) x))
  3131. tmp-1)
  3132. (let ((tmp-1 ($sc-dispatch tmp '(#(atom "list") . each-any))))
  3133. (if tmp-1
  3134. (apply (lambda (x)
  3135. (let ((tmp-1 (map emit x)))
  3136. (let ((tmp ($sc-dispatch tmp-1 'each-any)))
  3137. (if tmp
  3138. (apply (lambda (t) (cons '#(syntax-object list ((top)) (hygiene guile)) t))
  3139. tmp)
  3140. (syntax-violation
  3141. #f
  3142. "source expression failed to match any pattern"
  3143. tmp-1)))))
  3144. tmp-1)
  3145. (let ((tmp-1 ($sc-dispatch tmp '(#(atom "list*") . #(each+ any (any) ())))))
  3146. (if tmp-1
  3147. (apply (lambda (x y)
  3148. (let f ((x* x))
  3149. (if (null? x*)
  3150. (emit y)
  3151. (let ((tmp-1 (list (emit (car x*)) (f (cdr x*)))))
  3152. (let ((tmp ($sc-dispatch tmp-1 '(any any))))
  3153. (if tmp
  3154. (apply (lambda (t-1 t)
  3155. (list '#(syntax-object cons ((top)) (hygiene guile)) t-1 t))
  3156. tmp)
  3157. (syntax-violation
  3158. #f
  3159. "source expression failed to match any pattern"
  3160. tmp-1)))))))
  3161. tmp-1)
  3162. (let ((tmp-1 ($sc-dispatch tmp '(#(atom "append") . each-any))))
  3163. (if tmp-1
  3164. (apply (lambda (x)
  3165. (let ((tmp-1 (map emit x)))
  3166. (let ((tmp ($sc-dispatch tmp-1 'each-any)))
  3167. (if tmp
  3168. (apply (lambda (t)
  3169. (cons '#(syntax-object append ((top)) (hygiene guile)) t))
  3170. tmp)
  3171. (syntax-violation
  3172. #f
  3173. "source expression failed to match any pattern"
  3174. tmp-1)))))
  3175. tmp-1)
  3176. (let ((tmp-1 ($sc-dispatch tmp '(#(atom "vector") . each-any))))
  3177. (if tmp-1
  3178. (apply (lambda (x)
  3179. (let ((tmp-1 (map emit x)))
  3180. (let ((tmp ($sc-dispatch tmp-1 'each-any)))
  3181. (if tmp
  3182. (apply (lambda (t)
  3183. (cons '#(syntax-object vector ((top)) (hygiene guile)) t))
  3184. tmp)
  3185. (syntax-violation
  3186. #f
  3187. "source expression failed to match any pattern"
  3188. tmp-1)))))
  3189. tmp-1)
  3190. (let ((tmp-1 ($sc-dispatch tmp '(#(atom "list->vector") any))))
  3191. (if tmp-1
  3192. (apply (lambda (x)
  3193. (let ((tmp (emit x)))
  3194. (let ((t tmp))
  3195. (list '#(syntax-object list->vector ((top)) (hygiene guile)) t))))
  3196. tmp-1)
  3197. (let ((tmp-1 ($sc-dispatch tmp '(#(atom "value") any))))
  3198. (if tmp-1
  3199. (apply (lambda (x) x) tmp-1)
  3200. (syntax-violation
  3201. #f
  3202. "source expression failed to match any pattern"
  3203. tmp)))))))))))))))))))
  3204. (lambda (x)
  3205. (let ((tmp-1 x))
  3206. (let ((tmp ($sc-dispatch tmp-1 '(_ any))))
  3207. (if tmp
  3208. (apply (lambda (e) (emit (quasi e 0))) tmp)
  3209. (syntax-violation
  3210. #f
  3211. "source expression failed to match any pattern"
  3212. tmp-1))))))))
  3213. (define include
  3214. (make-syntax-transformer
  3215. 'include
  3216. 'macro
  3217. (lambda (x)
  3218. (letrec*
  3219. ((read-file
  3220. (lambda (fn dir k)
  3221. (let ((p (open-input-file
  3222. (if (absolute-file-name? fn)
  3223. fn
  3224. (if dir
  3225. (in-vicinity dir fn)
  3226. (syntax-violation
  3227. 'include
  3228. "relative file name only allowed when the include form is in a file"
  3229. x))))))
  3230. (let ((enc (file-encoding p)))
  3231. (set-port-encoding! p (let ((t enc)) (if t t "UTF-8")))
  3232. (let f ((x (read p)) (result '()))
  3233. (if (eof-object? x)
  3234. (begin (close-input-port p) (reverse result))
  3235. (f (read p) (cons (datum->syntax k x) result)))))))))
  3236. (let ((src (syntax-source x)))
  3237. (let ((file (if src (assq-ref src 'filename) #f)))
  3238. (let ((dir (if (string? file) (dirname file) #f)))
  3239. (let ((tmp-1 x))
  3240. (let ((tmp ($sc-dispatch tmp-1 '(any any))))
  3241. (if tmp
  3242. (apply (lambda (k filename)
  3243. (let ((fn (syntax->datum filename)))
  3244. (let ((tmp-1 (read-file fn dir filename)))
  3245. (let ((tmp ($sc-dispatch tmp-1 'each-any)))
  3246. (if tmp
  3247. (apply (lambda (exp)
  3248. (cons '#(syntax-object begin ((top)) (hygiene guile)) exp))
  3249. tmp)
  3250. (syntax-violation
  3251. #f
  3252. "source expression failed to match any pattern"
  3253. tmp-1))))))
  3254. tmp)
  3255. (syntax-violation
  3256. #f
  3257. "source expression failed to match any pattern"
  3258. tmp-1)))))))))))
  3259. (define include-from-path
  3260. (make-syntax-transformer
  3261. 'include-from-path
  3262. 'macro
  3263. (lambda (x)
  3264. (let ((tmp-1 x))
  3265. (let ((tmp ($sc-dispatch tmp-1 '(any any))))
  3266. (if tmp
  3267. (apply (lambda (k filename)
  3268. (let ((fn (syntax->datum filename)))
  3269. (let ((tmp (datum->syntax
  3270. filename
  3271. (let ((t (%search-load-path fn)))
  3272. (if t
  3273. t
  3274. (syntax-violation
  3275. 'include-from-path
  3276. "file not found in path"
  3277. x
  3278. filename))))))
  3279. (let ((fn tmp))
  3280. (list '#(syntax-object include ((top)) (hygiene guile)) fn)))))
  3281. tmp)
  3282. (syntax-violation
  3283. #f
  3284. "source expression failed to match any pattern"
  3285. tmp-1)))))))
  3286. (define unquote
  3287. (make-syntax-transformer
  3288. 'unquote
  3289. 'macro
  3290. (lambda (x)
  3291. (syntax-violation
  3292. 'unquote
  3293. "expression not valid outside of quasiquote"
  3294. x))))
  3295. (define unquote-splicing
  3296. (make-syntax-transformer
  3297. 'unquote-splicing
  3298. 'macro
  3299. (lambda (x)
  3300. (syntax-violation
  3301. 'unquote-splicing
  3302. "expression not valid outside of quasiquote"
  3303. x))))
  3304. (define make-variable-transformer
  3305. (lambda (proc)
  3306. (if (procedure? proc)
  3307. (let ((trans (lambda (x) (proc x))))
  3308. (set-procedure-property! trans 'variable-transformer #t)
  3309. trans)
  3310. (error "variable transformer not a procedure" proc))))
  3311. (define identifier-syntax
  3312. (make-syntax-transformer
  3313. 'identifier-syntax
  3314. 'macro
  3315. (lambda (xx)
  3316. (let ((tmp-1 xx))
  3317. (let ((tmp ($sc-dispatch tmp-1 '(_ any))))
  3318. (if tmp
  3319. (apply (lambda (e)
  3320. (list '#(syntax-object lambda ((top)) (hygiene guile))
  3321. '(#(syntax-object x ((top)) (hygiene guile)))
  3322. '#((#(syntax-object macro-type ((top)) (hygiene guile))
  3323. .
  3324. #(syntax-object
  3325. identifier-syntax
  3326. ((top)
  3327. #(ribcage
  3328. #(identifier-syntax)
  3329. #((top))
  3330. #(((hygiene guile)
  3331. .
  3332. #(syntax-object identifier-syntax ((top)) (hygiene guile))))))
  3333. (hygiene guile))))
  3334. (list '#(syntax-object syntax-case ((top)) (hygiene guile))
  3335. '#(syntax-object x ((top)) (hygiene guile))
  3336. '()
  3337. (list '#(syntax-object id ((top)) (hygiene guile))
  3338. '(#(syntax-object identifier? ((top)) (hygiene guile))
  3339. (#(syntax-object syntax ((top)) (hygiene guile))
  3340. #(syntax-object id ((top)) (hygiene guile))))
  3341. (list '#(syntax-object syntax ((top)) (hygiene guile)) e))
  3342. (list '(#(syntax-object _ ((top)) (hygiene guile))
  3343. #(syntax-object x ((top)) (hygiene guile))
  3344. #(syntax-object ... ((top)) (hygiene guile)))
  3345. (list '#(syntax-object syntax ((top)) (hygiene guile))
  3346. (cons e
  3347. '(#(syntax-object x ((top)) (hygiene guile))
  3348. #(syntax-object ... ((top)) (hygiene guile)))))))))
  3349. tmp)
  3350. (let ((tmp ($sc-dispatch
  3351. tmp-1
  3352. '(_ (any any)
  3353. ((#(free-id #(syntax-object set! ((top)) (hygiene guile))) any any)
  3354. any)))))
  3355. (if (if tmp
  3356. (apply (lambda (id exp1 var val exp2)
  3357. (if (identifier? id) (identifier? var) #f))
  3358. tmp)
  3359. #f)
  3360. (apply (lambda (id exp1 var val exp2)
  3361. (list '#(syntax-object make-variable-transformer ((top)) (hygiene guile))
  3362. (list '#(syntax-object lambda ((top)) (hygiene guile))
  3363. '(#(syntax-object x ((top)) (hygiene guile)))
  3364. '#((#(syntax-object macro-type ((top)) (hygiene guile))
  3365. .
  3366. #(syntax-object variable-transformer ((top)) (hygiene guile))))
  3367. (list '#(syntax-object syntax-case ((top)) (hygiene guile))
  3368. '#(syntax-object x ((top)) (hygiene guile))
  3369. '(#(syntax-object set! ((top)) (hygiene guile)))
  3370. (list (list '#(syntax-object set! ((top)) (hygiene guile)) var val)
  3371. (list '#(syntax-object syntax ((top)) (hygiene guile)) exp2))
  3372. (list (cons id
  3373. '(#(syntax-object x ((top)) (hygiene guile))
  3374. #(syntax-object ... ((top)) (hygiene guile))))
  3375. (list '#(syntax-object syntax ((top)) (hygiene guile))
  3376. (cons exp1
  3377. '(#(syntax-object x ((top)) (hygiene guile))
  3378. #(syntax-object ... ((top)) (hygiene guile))))))
  3379. (list id
  3380. (list '#(syntax-object identifier? ((top)) (hygiene guile))
  3381. (list '#(syntax-object syntax ((top)) (hygiene guile)) id))
  3382. (list '#(syntax-object syntax ((top)) (hygiene guile)) exp1))))))
  3383. tmp)
  3384. (syntax-violation
  3385. #f
  3386. "source expression failed to match any pattern"
  3387. tmp-1)))))))))
  3388. (define define*
  3389. (make-syntax-transformer
  3390. 'define*
  3391. 'macro
  3392. (lambda (x)
  3393. (let ((tmp-1 x))
  3394. (let ((tmp ($sc-dispatch tmp-1 '(_ (any . any) any . each-any))))
  3395. (if tmp
  3396. (apply (lambda (id args b0 b1)
  3397. (list '#(syntax-object define ((top)) (hygiene guile))
  3398. id
  3399. (cons '#(syntax-object lambda* ((top)) (hygiene guile))
  3400. (cons args (cons b0 b1)))))
  3401. tmp)
  3402. (let ((tmp ($sc-dispatch tmp-1 '(_ any any))))
  3403. (if (if tmp (apply (lambda (id val) (identifier? id)) tmp) #f)
  3404. (apply (lambda (id val)
  3405. (list '#(syntax-object define ((top)) (hygiene guile)) id val))
  3406. tmp)
  3407. (syntax-violation
  3408. #f
  3409. "source expression failed to match any pattern"
  3410. tmp-1)))))))))