git.debu.gs Git - pez/blob - typegen.pez

   1 #! /usr/bin/env pez
   2 # A big, ugly file that generates a bigger, uglier C file to generate the
   3 # primitive words for accessing the variously sized bits of memory that are
   4 # needed in order to talk across the FFI with C structs.
   5 #
   6 # TODO:  Handling for types larger than a cell.  See pez.c's SIZE_FUNCS macro.
   7
   8 variable funcs "" funcs !
   9 variable decls "" decls !
  10
  11 variable cname
  12 variable pezname
  13 variable ctype
  14
  15 variable fname
  16 variable #funcs 0 #funcs !
  17
  18 variable floaty?
  19
  20 "\t*([^\t\n]+)(\t*|$)" 0 regex constant tabtok-rx
  21 : tabtok ( str -- str+n word|0 )
  22         dup tabtok-rx rmatch
  23         0= if 0 exit then
  24         dup $1 rot substr ( str word )
  25         swap $2 nip + ( word str+n )
  26         swap ;
  27
  28 : fl ( s -- s' )
  29         "\t" swap s+ "\n" s+ s+ ;
  30
  31 : add-func ( s -- )
  32         #funcs 1+!
  33         funcs @ swap s+ funcs ! ;
  34
  35 : add-decl ( suffix -- )
  36         "{\"0" pezname @ s+ swap s+ "\", " s+ fname @ s+ "},\n" s+
  37         decls @ swap s+ decls ! ;
  38
  39 : fn-prelude ( -- prelude )
  40         "prim " fname @ s+ "(pez_instance *p)\n{\n" s+ ;
  41
  42 : reader-fn ( -- )
  43         "P_" cname @ s+ "_at" s+ fname !
  44         "@" add-decl
  45
  46         fn-prelude
  47         "\tSl(1);\n" s+
  48         "\tHpc(S0);\n" s+
  49
  50         floaty? @ if
  51                 "\tFSo(1);\n" s+
  52                 "\tRealpush(*(" s+ ctype @ s+ " *)S0);\n" s+
  53                 "\tPop;\n}\n\n" s+
  54         else
  55                 "\tS0 = *(" s+ ctype @ s+ " *)S0;\n}\n\n" s+
  56         then
  57
  58         add-func ;
  59
  60 : writer-fn ( -- )
  61         "P_" cname @ s+ "_bang" s+ fname !
  62         "!" add-decl
  63
  64         fn-prelude
  65         floaty? @ if
  66                 "\tSl(1);\n" s+
  67                 "\tFSl(1);\n" s+
  68                 "\tHpc(S0);\n" s+
  69                 "\t*(" s+ ctype @ s+ " *)S0 = (" s+ ctype @ s+ ")REAL0;\n" s+
  70                 "\tPop;\n\tRealpop;\n}\n\n" s+
  71         else
  72                 "\tSl(2);\n" s+
  73                 "\tHpc(S0);\n" s+
  74                 "\t*(" s+ ctype @ s+ " *)S0 = (" s+ ctype @ s+ ")S1;\n" s+
  75                 "\tNpop(2);\n}\n\n" s+
  76         then
  77         add-func ;
  78
  79 : size-fn ( -- )
  80         "P_" cname @ s+ "_size" s+ fname !
  81         "-size" add-decl
  82
  83         fn-prelude
  84         "\tSo(1);\n" s+
  85         "\tPush = sizeof(" s+ ctype @ s+ ");\n}\n\n" s+
  86         add-func ;
  87
  88 : size-mult ( -- )
  89         "P_" cname @ s+ "s" s+ fname !
  90         "s" add-decl
  91
  92         fn-prelude
  93         "\tSl(1);\n" s+
  94         "\tS0 *= sizeof(" s+ ctype @ s+ ");\n}\n\n" s+
  95         add-func ;
  96
  97 # If you're reading along, be careful, because it's about to get uglier.
  98 : struct-member ( -- )
  99         "P_" cname @ s+ "_colon" s+ fname !
 100         ":" add-decl
 101         fn-prelude
 102         "pez_dictword *offsetw = (pez_dictword *)p->hptr, *w;" fl
 103         "pez_stackitem plus;" fl
 104         "int namelen, token;" fl
 105         "char *name, *buf;" fl
 106         "" fl
 107         "if(!p->createstruct) {" fl
 108         "\ttrouble(p, \"Tried to define struct member outside struct \"" fl
 109         "\t\t\"definition\");" fl
 110         "\treturn;" fl
 111         "}" fl
 112         "plus = (pez_stackitem)lookup(p, \"+\");" fl
 113         "" fl
 114         "name = alloc(TOK_BUF_SZ);" fl
 115         "token = lex(p, &p->instream, name);" fl
 116         "if(token != TokWord) {" fl
 117         "\ttrouble(p, \"Expected a word to follow '" pezname @ s+
 118                 ":'\");" s+ fl
 119         "\treturn;" fl
 120         "}" fl
 121         "namelen = strlen(name);" fl
 122         "" fl
 123         "// ( struct-addr -- member-addr ) The offset-adder:" fl
 124         "Ho(Dictwordl);" fl
 125         "p->hptr += Dictwordl;" fl
 126         "buf = alloc(namelen + 2);" fl
 127         "memcpy(buf + 1, name, namelen);" fl
 128         "offsetw->wname = buf;" fl
 129         "offsetw->wcode = P_nest;" fl
 130         "offsetw->wnext = p->dict;" fl
 131         "p->dict = offsetw;" fl
 132         "if(p->createstruct->size) { // No point in adding zero." fl
 133         "\tHsingle(s_lit);" fl
 134         "\tHsingle(p->createstruct->size);" fl
 135         "\tHsingle(plus);" fl
 136         "}" fl
 137         "Hsingle(s_exit);" fl
 138         "" fl
 139
 140         "// ( struct-addr -- member ) The reader:" fl
 141         "Ho(Dictwordl);" fl
 142         "buf = alloc(namelen + 3);" fl
 143         "sprintf(buf + 1, \"%s@\", name);" fl
 144         "w = (pez_dictword *)p->hptr;" fl
 145         "p->hptr += Dictwordl;" fl
 146         "w->wname = buf;" fl
 147         "w->wcode = P_nest;" fl
 148         "w->wnext = p->dict;" fl
 149         "p->dict = w;" fl
 150         "if(p->createstruct->size) {" fl
 151         "\tHsingle(s_lit);" fl
 152         "\tHsingle(p->createstruct->size);" fl
 153         "\tHsingle(plus);" fl
 154         "}" fl
 155         "Hsingle((pez_stackitem)lookup(p, \"" pezname @ s+ "@\"));" s+ fl
 156         "Hsingle(s_exit);" fl
 157         "" fl
 158
 159         "// ( val struct-addr -- ) The writer:" fl
 160         "Ho(Dictwordl);" fl
 161         "w = (pez_dictword *)p->hptr;" fl
 162         "p->hptr += Dictwordl;" fl
 163         "buf = alloc(namelen + 3);" fl
 164         "sprintf(buf + 1, \"%s!\", name);" fl
 165         "w->wname = buf;" fl
 166         "w->wcode = P_nest;" fl
 167         "w->wnext = p->dict;" fl
 168         "p->dict = w;" fl
 169         "if(p->createstruct->size) {" fl
 170         "\tHsingle(s_lit);" fl
 171         "\tHsingle(p->createstruct->size);" fl
 172         "\tHsingle(plus);" fl
 173         "}" fl
 174         "Hsingle((pez_stackitem)lookup(p, \"" pezname @ s+ "!\"));" s+ fl
 175         "Hsingle(s_exit);" fl
 176         "" fl
 177
 178         "// And, finally, we add the size of a " pezname @ s+
 179                 " to the size of the struct." s+ fl
 180         "p->createstruct->size += sizeof(" ctype @ s+ ");" s+ fl
 181
 182         "}\n\n" s+
 183
 184         add-func ;
 185
 186 : plural-struct-member
 187         "P_" cname @ s+ "s_colon" s+ fname !
 188         "s:" add-decl
 189         fn-prelude
 190
 191         "pez_dictword *w = (pez_dictword *)p->hptr;" fl
 192         "pez_stackitem plus;" fl
 193         "int namelen, token;" fl
 194         "char *name, *buf;" fl
 195         "" fl
 196
 197         "if(!p->createstruct) {" fl
 198         "\ttrouble(p, \"Tried to define struct member outside struct \"" fl
 199         "\t\t\"definition\");" fl
 200         "\treturn;" fl
 201         "}" fl
 202         "Sl(1);" fl
 203         "" fl
 204
 205         "plus = (pez_stackitem)lookup(p, \"+\");" fl
 206         "" fl
 207
 208         "name = alloc(TOK_BUF_SZ);" fl
 209         "token = lex(p, &p->instream, name);" fl
 210         "if(token != TokWord) {" fl
 211         "\ttrouble(p, \"Expected a word to follow '" pezname @ s+
 212                 "s:'\");" s+ fl
 213         "\treturn;" fl
 214         "}" fl
 215         "namelen = strlen(name);" fl
 216         "" fl
 217
 218         "Ho(Dictwordl);" fl
 219         "p->hptr += Dictwordl;" fl
 220         "buf = alloc(namelen + 2);" fl
 221         "memcpy(buf + 1, name, namelen);" fl
 222         "w->wname = buf;" fl
 223         "w->wcode = P_nest;" fl
 224         "w->wnext = p->dict;" fl
 225         "p->dict = w;" fl
 226         "if(p->createstruct->size) { // No point in adding zero." fl
 227         "\tHsingle(s_lit);" fl
 228         "\tHsingle(p->createstruct->size);" fl
 229         "\tHsingle(plus);" fl
 230         "}" fl
 231         "Hsingle(s_exit);" fl
 232         "" fl
 233
 234         "p->createstruct->size += S0 * sizeof(" ctype @ s+ ");" s+ fl
 235         "Pop;" fl
 236
 237         "}\n\n" s+
 238
 239         add-func ;
 240
 241 : pline ( l -- )
 242         tabtok swap tabtok swap tabtok nip ( ctype pezname cname )
 243         cname !
 244         pezname !
 245         dup ctype !
 246         dup "float" strcmp 0= swap "double" strcmp 0= or floaty? !
 247
 248         reader-fn
 249         writer-fn
 250         size-fn
 251         size-mult
 252         struct-member
 253         plural-struct-member
 254 ;
 255
 256 : process ( -- )
 257         begin gets dup while
 258                 pline
 259         repeat drop ;
 260
 261 : write-file ( str fn -- )
 262         o_creat o_wronly or 0666 open
 263         dup 0< if drop 1 "Couldn't open file!" die! then
 264         >output print output> close drop ;
 265
 266 # Figures out what file has the types
 267 : types-fn ( -- fn )
 268         argc 1 < if "type_names" exit then
 269         argv @ ;
 270
 271 : type_primitives.c ( -- fn )
 272         argc 2 < if "type_primitives.c" exit then
 273         argv cell-size + @ ;
 274
 275 types-fn o_rdonly 0 open >input
 276         process
 277 input> close drop
 278
 279 "/* " type_primitives.c s+ "\n" s+
 280 "   This file has been automatically generated as part of the Pez build\n" s+
 281 "   process, by typegen.pez.  It defines a number of primitive functions\n" s+
 282 "   that help out with dealing with the variously sized types presented by\n" s+
 283 "   C, and including them in structs.\n" s+
 284 "\n" s+
 285 "   So editing this file is going to be unhelpful; you'd be better off\n" s+
 286 "   editing typegen.pez.  So that Pez can be built on machines that don't\n" s+
 287 "   already have Pez, this file is included in the repository and with\n" s+
 288 "   distribution tarballs.\n" s+
 289 "*/\n\n" s+
 290 funcs @ s+
 291 "struct primfcn memory_primitives[] = {" s+
 292 decls @ s+
 293 "{NULL, (pez_wordp)0}\n};" s+
 294 type_primitives.c write-file
 295 "Generated " print #funcs @ . "functions." puts