09b0bc5 · rowtype-yoga/purescm

git.iko.soy/rowtype-yoga/purescm

on bytevector help sign in

Integrate SRFIs to runtime (#138)

* Add missing private modules * Use SRFIs for arrays and objects * Handle accessors for properties and indices * Implement the Update case

commit09b0bc58d3752b5aa29548ca3da482f1cb4914d7 authorJustin Garcia <purefunctor@gmail.com> dateWed 31 May 2023, 03:48 (3 years ago) parent279cc70

15 files changed+248−58

compare with bytevector

unifiedsplit

src/PureScript/Backend/Chez/Convert.purs+6−9

@@ -21,7 +21,7 @@ import Data.String.Regex.Unsafe as R.Unsafe

2121import Data.Tuple (Tuple(..), uncurry)

2222import Data.Tuple as Tuple

2323import Partial.Unsafe (unsafeCrashWith)

24−import PureScript.Backend.Chez.Constants (libChezSchemePrefix, moduleForeign, moduleLib, runtimePrefix, scmPrefixed, undefinedSymbol)

24+import PureScript.Backend.Chez.Constants (libChezSchemePrefix, moduleForeign, moduleLib, rtPrefixed, runtimePrefix, scmPrefixed, undefinedSymbol)

2525import PureScript.Backend.Chez.Syntax (ChezDefinition(..), ChezExport(..), ChezExpr, ChezImport(..), ChezImportSet(..), ChezLibrary, recordTypeAccessor, recordTypeCurriedConstructor, recordTypePredicate, recordTypeUncurriedConstructor)

2626import PureScript.Backend.Chez.Syntax as S

2727import PureScript.Backend.Optimizer.Convert (BackendModule, BackendBindingGroup)

@@ -172,19 +172,16 @@ codegenExpr codegenEnv@{ currentModule } s = case unwrap s of

172172

173173 Accessor e (GetProp i) ->

174174 S.runUncurriedFn

175− (S.Identifier $ scmPrefixed "hashtable-ref")

176− [ codegenExpr codegenEnv e

177− , S.StringExpr $ Json.stringify $ Json.fromString i

178− , S.Bool false

179− ]

175+ (S.Identifier $ rtPrefixed "object-ref")

176+ [ codegenExpr codegenEnv e, S.StringExpr $ Json.stringify $ Json.fromString i ]

180177 Accessor e (GetIndex i) ->

181178 S.runUncurriedFn

182− (S.Identifier $ scmPrefixed "vector-ref")

179+ (S.Identifier $ rtPrefixed "array-ref")

183180 [ codegenExpr codegenEnv e, S.Integer $ wrap $ show i ]

184181 Accessor e (GetCtorField qi _ _ _ field _) ->

185182 S.recordAccessor (codegenExpr codegenEnv e) (flattenQualified currentModule qi) field

186− Update _ _ ->

187− S.Identifier "object-update"

183+ Update e f ->

184+ S.recordUpdate (codegenExpr codegenEnv e) (map (codegenExpr codegenEnv) <$> f)

188185

189186 CtorSaturated qi _ _ _ xs ->

190187 S.runUncurriedFn

src/PureScript/Backend/Chez/Runtime.purs+63

@@ -26,6 +26,12 @@ makeExportedFunction name args expr = do

2626 modify_ $ Array.cons $ ExportIdentifier name

2727 pure $ Define name $ S.mkCurriedFn args expr

2828

29+makeExportedValue

30+ :: forall m. Monad m => MonadState (Array ChezExport) m => String -> ChezExpr -> m ChezDefinition

31+makeExportedValue name value = do

32+ modify_ $ Array.cons $ ExportIdentifier name

33+ pure $ S.Define name $ value

34+

2935makeBooleanComparison

3036 :: forall m. Monad m => MonadState (Array ChezExport) m => String -> m ChezDefinition

3137makeBooleanComparison suffix =

@@ -36,6 +42,47 @@ makeBooleanComparison suffix =

3642 , S.List [ S.Identifier "boolean->integer", S.Identifier "y" ]

3743 ]

3844

45+createMakeArrayFn :: forall m. Monad m => MonadState (Array ChezExport) m => m ChezDefinition

46+createMakeArrayFn = makeExportedValue "make-array" $ S.Identifier "srfi:214:flexvector"

47+

48+createArrayRefFn :: forall m. Monad m => MonadState (Array ChezExport) m => m ChezDefinition

49+createArrayRefFn = makeExportedValue "array-ref" $ S.Identifier "srfi:214:flexvector-ref"

50+

51+createMakeObjectFn :: forall m. Monad m => MonadState (Array ChezExport) m => m ChezDefinition

52+createMakeObjectFn = makeExportedValue "make-object" $ S.List

53+ [ S.Identifier $ scmPrefixed "lambda"

54+ , S.Identifier "args"

55+ , S.List

56+ [ S.Identifier $ scmPrefixed "apply"

57+ , S.Identifier "srfi:125:hash-table"

58+ , S.List

59+ [ S.Identifier $ scmPrefixed "cons"

60+ , S.Identifier "string-comparator"

61+ , S.Identifier "args"

62+ ]

63+ ]

64+ ]

65+

66+createObjectRefFn :: forall m. Monad m => MonadState (Array ChezExport) m => m ChezDefinition

67+createObjectRefFn = makeExportedValue "object-ref" $ S.Identifier "srfi:125:hash-table-ref"

68+

69+createObjectSetFn :: forall m. Monad m => MonadState (Array ChezExport) m => m ChezDefinition

70+createObjectSetFn = makeExportedValue "object-set!" $ S.Identifier "srfi:125:hash-table-set!"

71+

72+createObjectCopyFn :: forall m. Monad m => MonadState (Array ChezExport) m => m ChezDefinition

73+createObjectCopyFn = makeExportedFunction "object-copy" (NEA.singleton "v") $ S.List

74+ [ S.Identifier "srfi:125:hash-table-copy"

75+ , S.Identifier "v"

76+ , S.Bool true

77+ ]

78+

79+importSRFI :: String -> ChezImport

80+importSRFI srfi = ImportSet $ ImportPrefix

81+ ( ImportLibrary

82+ { identifiers: NEA.cons' "purs" [ "runtime", "srfi", ":" <> srfi ], version: Nothing }

83+ )

84+ ("srfi:" <> srfi <> ":")

85+

3986runtimeModule :: ChezLibrary

4087runtimeModule = do

4188 let

@@ -46,10 +93,23 @@ runtimeModule = do

4693 , S.Integer $ S.LiteralDigit "1"

4794 , S.Integer $ S.LiteralDigit "0"

4895 ]

96+ , pure $ S.Define "string-comparator" $ S.List

97+ [ S.Identifier "srfi:128:make-comparator"

98+ , S.Identifier $ scmPrefixed "string?"

99+ , S.Identifier $ scmPrefixed "string=?"

100+ , S.Identifier $ scmPrefixed "string<?"

101+ , S.Identifier $ scmPrefixed "string-hash"

102+ ]

49103 , makeBooleanComparison ">?"

50104 , makeBooleanComparison ">=?"

51105 , makeBooleanComparison "<=?"

52106 , makeBooleanComparison "<?"

107+ , createMakeArrayFn

108+ , createArrayRefFn

109+ , createMakeObjectFn

110+ , createObjectRefFn

111+ , createObjectSetFn

112+ , createObjectCopyFn

53113 ]

54114 { "#!chezscheme": true

55115 , "#!r6rs": true

@@ -62,6 +122,9 @@ runtimeModule = do

62122 [ ImportSet $ ImportPrefix

63123 (ImportLibrary { identifiers: NEA.singleton "chezscheme", version: Nothing })

64124 libChezSchemePrefix

125+ , importSRFI "125"

126+ , importSRFI "128"

127+ , importSRFI "214"

65128 ]

66129 , body:

67130 { definitions

src/PureScript/Backend/Chez/Syntax.purs+22−26

@@ -8,8 +8,8 @@ import Data.Array.NonEmpty (NonEmptyArray)

88import Data.Array.NonEmpty as NonEmptyArray

99import Data.Maybe (Maybe)

1010import Data.Newtype (class Newtype)

11−import Data.Tuple (Tuple)

12−import PureScript.Backend.Chez.Constants (scmPrefixed)

11+import Data.Tuple (Tuple(..))

12+import PureScript.Backend.Chez.Constants (rtPrefixed, scmPrefixed)

1313import PureScript.Backend.Optimizer.CoreFn (Prop(..))

1414

1515type ChezLibrary =

@@ -122,30 +122,11 @@ app :: ChezExpr -> ChezExpr -> ChezExpr

122122app f x = List [ f, x ]

123123

124124record :: Array (Prop ChezExpr) -> ChezExpr

125−record r =

125+record r = do

126126 let

127− field :: Prop ChezExpr -> ChezExpr

128− field (Prop k v) =

129− List

130− [ Identifier $ scmPrefixed "hashtable-set!"

131− , Identifier "$record"

132− , StringExpr $ Json.stringify $ Json.fromString k

133− , v

134− ]

135− in

136− List $

137− [ Identifier $ scmPrefixed "letrec*"

138− , List

139− [ List

140− [ Identifier "$record"

141− , List

142− [ Identifier $ scmPrefixed "make-hashtable"

143− , Identifier $ scmPrefixed "string-hash"

144− , Identifier $ scmPrefixed "string=?"

145− ]

146− ]

147− ]

148− ] <> (field <$> r) <> [ Identifier "$record" ]

127+ field :: Prop ChezExpr -> Array ChezExpr

128+ field (Prop k v) = [ StringExpr $ Json.stringify $ Json.fromString k, v ]

129+ List $ [ Identifier $ rtPrefixed "make-object" ] <> Array.foldMap field r

149130

150131quote :: ChezExpr -> ChezExpr

151132quote e = app (Identifier $ scmPrefixed "quote") e

@@ -154,7 +135,7 @@ eqQ :: ChezExpr -> ChezExpr -> ChezExpr

154135eqQ x y = runUncurriedFn (Identifier $ scmPrefixed "eq?") [ x, y ]

155136

156137vector :: Array ChezExpr -> ChezExpr

157−vector = List <<< Array.cons (Identifier $ scmPrefixed "vector")

138+vector = List <<< Array.cons (Identifier $ rtPrefixed "make-array")

158139

159140recordTypeName :: String -> String

160141recordTypeName i = i <> "$"

@@ -174,3 +155,18 @@ recordTypeAccessor i field = i <> "-" <> field

174155recordAccessor :: ChezExpr -> String -> String -> ChezExpr

175156recordAccessor expr name field =

176157 runUncurriedFn (Identifier $ recordTypeAccessor name field) [ expr ]

158+

159+recordUpdate :: ChezExpr -> Array (Prop ChezExpr) -> ChezExpr

160+recordUpdate h f = do

161+ let

162+ field :: Prop ChezExpr -> ChezExpr

163+ field (Prop k v) =

164+ List

165+ [ Identifier $ rtPrefixed "object-set!"

166+ , Identifier "$record"

167+ , StringExpr $ Json.stringify $ Json.fromString k

168+ , v

169+ ]

170+ Let false

171+ (NonEmptyArray.singleton (Tuple "$record" (List [ Identifier $ rtPrefixed "object-copy", h ])))

172+ (List $ [ Identifier $ scmPrefixed "begin" ] <> (field <$> f))

test-snapshots/spago.yaml+12

@@ -7,6 +7,7 @@ package:

77 - functions

88 - partial

99 - prelude

10+ - record

1011 - refs

1112workspace:

1213 package_set:

@@ -49,3 +50,14 @@ workspace:

4950 dependencies:

5051 - effect

5152 - prelude

53+ record:

54+ git: https://github.com/purescm/purescript-record.git

55+ ref: 8a993da0d328f72167a4742e0e2a428a790510bc

56+ dependencies:

57+ - functions

58+ - prelude

59+ - unsafe-coerce

60+ unsafe-coerce:

61+ git: https://github.com/purescm/purescript-unsafe-coerce.git

62+ ref: 20dbd7797e985b631459b8dbd4072cf3096ee1da

63+ dependencies: []

test-snapshots/src/snapshots-input/Snapshot.Literals.Record.purs+28

@@ -1,4 +1,32 @@

1+-- @inline Snapshot.Literals.Record.recordAccess never

2+-- @inline Snapshot.Literals.Record.recordUpdate never

3+-- @inline Snapshot.Literals.Record.recordAddField never

14module Snapshot.Literals.Record where

6+import Prelude

8+import Effect (Effect)

9+import Prim.Row (class Lacks)

10+import Record as Record

11+import Test.Assert (assert)

12+import Type.Proxy (Proxy(..))

13+

314recordAccess :: forall a r. { fooBarBaz :: a | r } -> a

415recordAccess = _.fooBarBaz

16+

17+recordUpdate :: forall r. { fooBarBaz :: Int | r } -> { fooBarBaz :: Int | r }

18+recordUpdate = _ { fooBarBaz = 10 }

19+

20+recordAddField :: forall r. Lacks "anotherField" r => { fooBarBaz :: Int | r } -> { fooBarBaz :: Int, anotherField :: Int | r }

21+recordAddField = Record.insert (Proxy :: _ "anotherField") 42

22+

23+main :: Effect Unit

24+main = do

25+ let r = { fooBarBaz: 5 }

26+ let s = recordUpdate r

27+ let t = recordAddField s

28+

29+ assert $ recordAccess t == 10

30+ assert $ t.anotherField == 42

31+ assert $ recordAccess s == 10

32+ assert $ recordAccess r == 5

test-snapshots/src/snapshots-output/Snapshot.ArrayIndex.ss+1−1

@@ -11,5 +11,5 @@

1111 (scm:define testAccessorGetIndex

1212 (scm:lambda (v0)

1313 (scm:cond

14− [(scm:fx=? (scm:vector-length v0) 1) (scm:vector-ref v0 0)]

14+ [(scm:fx=? (scm:vector-length v0) 1) (rt:array-ref v0 0)]

1515 [scm:else 0]))))

test-snapshots/src/snapshots-output/Snapshot.Comparison.ss+5−5

@@ -15,24 +15,24 @@

1515 (scm:define stringComparison

1616 (scm:lambda (x0)

1717 (scm:lambda (y1)

18− (scm:vector (scm:string=? x0 y1) (scm:not (scm:string=? x0 y1)) (scm:string<? x0 y1) (scm:string<=? x0 y1) (scm:string>=? x0 y1) (scm:string>? x0 y1)))))

18+ (rt:make-array (scm:string=? x0 y1) (scm:not (scm:string=? x0 y1)) (scm:string<? x0 y1) (scm:string<=? x0 y1) (scm:string>=? x0 y1) (scm:string>? x0 y1)))))

1919

2020 (scm:define numberComparison

2121 (scm:lambda (x0)

2222 (scm:lambda (y1)

23− (scm:vector (scm:fl=? x0 y1) (scm:not (scm:fl=? x0 y1)) (scm:fl<? x0 y1) (scm:fl<=? x0 y1) (scm:fl>=? x0 y1) (scm:fl>? x0 y1)))))

23+ (rt:make-array (scm:fl=? x0 y1) (scm:not (scm:fl=? x0 y1)) (scm:fl<? x0 y1) (scm:fl<=? x0 y1) (scm:fl>=? x0 y1) (scm:fl>? x0 y1)))))

2424

2525 (scm:define integerComparison

2626 (scm:lambda (x0)

2727 (scm:lambda (y1)

28− (scm:vector (scm:fx=? x0 y1) (scm:not (scm:fx=? x0 y1)) (scm:fx<? x0 y1) (scm:fx<=? x0 y1) (scm:fx>=? x0 y1) (scm:fx>? x0 y1)))))

28+ (rt:make-array (scm:fx=? x0 y1) (scm:not (scm:fx=? x0 y1)) (scm:fx<? x0 y1) (scm:fx<=? x0 y1) (scm:fx>=? x0 y1) (scm:fx>? x0 y1)))))

2929

3030 (scm:define charComparison

3131 (scm:lambda (x0)

3232 (scm:lambda (y1)

33− (scm:vector (scm:char=? x0 y1) (scm:not (scm:char=? x0 y1)) (scm:char<? x0 y1) (scm:char<=? x0 y1) (scm:char>=? x0 y1) (scm:char>? x0 y1)))))

33+ (rt:make-array (scm:char=? x0 y1) (scm:not (scm:char=? x0 y1)) (scm:char<? x0 y1) (scm:char<=? x0 y1) (scm:char>=? x0 y1) (scm:char>? x0 y1)))))

3434

3535 (scm:define booleanComparison

3636 (scm:lambda (x0)

3737 (scm:lambda (y1)

38− (scm:vector (scm:boolean=? x0 y1) (scm:not (scm:boolean=? x0 y1)) (rt:boolean<? x0 y1) (rt:boolean<=? x0 y1) (rt:boolean>=? x0 y1) (rt:boolean>? x0 y1))))))

38+ (rt:make-array (scm:boolean=? x0 y1) (scm:not (scm:boolean=? x0 y1)) (rt:boolean<? x0 y1) (rt:boolean<=? x0 y1) (rt:boolean>=? x0 y1) (rt:boolean>? x0 y1))))))

test-snapshots/src/snapshots-output/Snapshot.Function.ss+1−1

@@ -12,7 +12,7 @@

1212 (scm:define f

1313 (scm:lambda (x0)

1414 (scm:lambda (y1)

15− (scm:vector x0 y1 x0 y1 x0))))

15+ (rt:make-array x0 y1 x0 y1 x0))))

1616

1717 (scm:define g

1818 (scm:lambda (x0)

test-snapshots/src/snapshots-output/Snapshot.Literals.Record.ss+36−3

@@ -3,11 +3,44 @@

33(library

44 (Snapshot.Literals.Record lib)

55 (export

6− recordAccess)

6+ insert

7+ main

8+ recordAccess

9+ recordAddField

10+ recordUpdate)

711 (import

812 (prefix (chezscheme) scm:)

9− (prefix (purs runtime lib) rt:))

13+ (prefix (purs runtime lib) rt:)

14+ (prefix (Record lib) Record.)

15+ (prefix (Test.Assert lib) Test.Assert.)

16+ (prefix (Type.Proxy lib) Type.Proxy.))

17+

18+ (scm:define insert

19+ (((Record.insert (rt:make-object "reflectSymbol" (scm:lambda (_)

20+ "anotherField"))) (scm:gensym "purs-undefined")) (scm:gensym "purs-undefined")))

21+

22+ (scm:define recordUpdate

23+ (scm:lambda (v0)

24+ (scm:let ([$record (rt:object-copy v0)])

25+ (scm:begin (rt:object-set! $record "fooBarBaz" 10)))))

26+

27+ (scm:define recordAddField

28+ (scm:lambda (_)

29+ ((insert Type.Proxy.Proxy) 42)))

1030

1131 (scm:define recordAccess

1232 (scm:lambda (v0)

13− (scm:hashtable-ref v0 "fooBarBaz" #f))))

33+ (rt:object-ref v0 "fooBarBaz")))

34+

35+ (scm:define main

36+ (scm:let*

37+ ([r0 (rt:make-object "fooBarBaz" 5)]

38+ [s1 (recordUpdate r0)]

39+ [t2 ((recordAddField (scm:gensym "purs-undefined")) s1)]

40+ [_3 (Test.Assert.assert (scm:fx=? (recordAccess t2) 10))])

41+ (scm:lambda ()

42+ (scm:let*

43+ ([_ (_3)]

44+ [_ ((Test.Assert.assert (scm:fx=? (rt:object-ref t2 "anotherField") 42)))]

45+ [_ ((Test.Assert.assert (scm:fx=? (recordAccess s1) 10)))])

46+ ((Test.Assert.assert (scm:fx=? (recordAccess r0) 5))))))))

test-snapshots/src/snapshots-output/Snapshot.Literals.ss+4−4

@@ -21,10 +21,10 @@

2121 "string")

2222

2323 (scm:define record2

24− (scm:letrec* (($record (scm:make-hashtable scm:string-hash scm:string=?))) (scm:hashtable-set! $record "foo" "bar") $record))

24+ (rt:make-object "foo" "bar"))

2525

2626 (scm:define record

27− (scm:letrec* (($record (scm:make-hashtable scm:string-hash scm:string=?))) $record))

27+ (rt:make-object))

2828

2929 (scm:define number

3030 2.0)

@@ -42,7 +42,7 @@

4242 #t)

4343

4444 (scm:define array2

45− (scm:vector 1 2 3))

45+ (rt:make-array 1 2 3))

4646

4747 (scm:define array

48− (scm:vector)))

48+ (rt:make-array)))

test-snapshots/src/snapshots-output/Snapshot.PrimUndefined.ss+1−1

@@ -13,7 +13,7 @@

1313

1414 (scm:define testCase

1515 (scm:lambda (dictRing0)

16− (scm:hashtable-ref ((scm:hashtable-ref dictRing0 "Semiring0" #f) (scm:gensym "purs-undefined")) "add" #f)))

16+ (rt:object-ref ((rt:object-ref dictRing0 "Semiring0") (scm:gensym "purs-undefined")) "add")))

1717

1818 (scm:define main

1919 (Test.Assert.assert (scm:fx=? (((testCase Data.Ring.ringInt) 1) 1) 2))))

test-snapshots/src/snapshots-output/Snapshot.Prime.ss+8−8

@@ -94,32 +94,32 @@

9494

9595 (scm:define normal

9696 (scm:lambda (dict0)

97− (scm:hashtable-ref dict0 "normal" #f)))

97+ (rt:object-ref dict0 "normal")))

9898

9999 (scm:define useNormal

100100 (scm:lambda (dictNormal0)

101101 (scm:lambda (dictNormal11)

102102 (scm:lambda (a2)

103103 (scm:lambda (b3)

104− (scm:string-append ((scm:hashtable-ref dictNormal0 "normal" #f) a2) ((scm:hashtable-ref dictNormal11 "normal" #f) b3)))))))

104+ (scm:string-append ((rt:object-ref dictNormal0 "normal") a2) ((rt:object-ref dictNormal11 "normal") b3)))))))

105105

106106 (scm:define instanceName$p

107− (scm:letrec* (($record (scm:make-hashtable scm:string-hash scm:string=?))) (scm:hashtable-set! $record "normal" (scm:lambda (v0)

107+ (rt:make-object "normal" (scm:lambda (v0)

108108 (scm:cond

109109 [(F1? v0) "F1"]

110110 [(F2? v0) "F2"]

111− [scm:else (scm:raise (scm:condition (scm:make-error) (scm:make-message-condition "Failed pattern match")))]))) $record))

111+ [scm:else (scm:raise (scm:condition (scm:make-error) (scm:make-message-condition "Failed pattern match")))]))))

112112

113113 (scm:define useInstance

114114 "F1F2")

115115

116116 (scm:define ignore

117117 (scm:lambda (dict0)

118− (scm:hashtable-ref dict0 "ignore" #f)))

118+ (rt:object-ref dict0 "ignore")))

119119

120120 (scm:define useClass

121121 (scm:lambda (dictClassName$p0)

122− (scm:hashtable-ref dictClassName$p0 "ignore" #f)))

122+ (rt:object-ref dictClassName$p0 "ignore")))

123123

124124 (scm:define foo$poo

125125 "foo'oo")

@@ -144,8 +144,8 @@

144144

145145 (scm:define classMember$p

146146 (scm:lambda (dict0)

147− (scm:hashtable-ref dict0 "classMember'" #f)))

147+ (rt:object-ref dict0 "classMember'")))

148148

149149 (scm:define useMember

150150 (scm:lambda (dictClassMember0)

151− (scm:hashtable-ref dictClassMember0 "classMember'" #f))))

151+ (rt:object-ref dictClassMember0 "classMember'"))))

vendor/purs/runtime/srfi/private/check-arg.slsnew file+23

@@ -0,0 +1,23 @@

1+#!r6rs

3+;; LICENSE from the original collection this file is distributed with.

5+;; If your Scheme system doesn't have a stack-tracing debugger, you can change

6+;; this to use the version which actually does check.

8+(library (purs runtime srfi private check-arg)

9+ (export

10+ check-arg)

11+ (import

12+ (rnrs))

13+

14+#;(define (check-arg pred val who)

15+ (if (pred val)

16+ val

17+ (assertion-violation #F "check-arg failed" who pred val)))

18+

19+ (define-syntax check-arg

20+ (syntax-rules ()

21+ ((_ pred val who)

22+ val)))

23+)

vendor/purs/runtime/srfi/private/define-values.chezscheme.slsnew file+3

@@ -0,0 +1,3 @@

1+(library (purs runtime srfi private define-values)

2+ (export define-values)

3+ (import (chezscheme)))

vendor/purs/runtime/srfi/private/vanish.slsnew file+35

@@ -0,0 +1,35 @@

1+#!r6rs

3+;; LICENSE from the original collection this file is distributed with.

5+(library (purs runtime srfi private vanish)

6+ (export

7+ vanish-define)

8+ (import

9+ (rnrs)

10+ (for (only (rnrs base) begin) (meta -1)))

11+

12+ (define-syntax vanish-define

13+ (lambda (stx)

14+ (syntax-case stx ()

15+ ((_ def (vanish ...))

16+ (for-all identifier? #'(def vanish ...))

17+ #'(make-vanish-define (syntax def) (syntax vanish) ...)))))

18+

19+ (define (make-vanish-define def . to-vanish)

20+ (lambda (stx)

21+ (define (vanish? id)

22+ (memp (lambda (x) (free-identifier=? id x))

23+ to-vanish))

24+ (syntax-case stx ()

25+ ((_ name . _)

26+ (and (identifier? #'name)

27+ (vanish? #'name))

28+ #'(begin))

29+ ((_ (name . _) . _)

30+ (and (identifier? #'name)

31+ (vanish? #'name))

32+ #'(begin))

33+ ((_ . r)

34+ (cons def #'r)))))

35+)