File:  [gforth] / gforth / prims2x.fs
Revision 1.4: download - view: text, annotated - select for diffs
Wed Jul 13 19:21:07 1994 UTC (29 years, 8 months ago) by pazsan
Branches: MAIN
CVS tags: HEAD
Moved setjmp from engine to go_forth, because the socalled "globbered"
variables where saved in memory (and this slows down everything).
Added global up0 for security (up is globbered).

Added restrict's functionalitz to cross.fs

removed all occurency of cell+ name>, because the bug in name> is
fixed.

Added a dusty workaround at the end of prims2x.fs, because of
strange exceptions.

    1: \ This is not very nice (hard limits, no checking, assumes 1 chars = 1)
    2: 
    3: \ Optimizations:
    4: \ superfluous stores are removed. GCC removes the superfluous loads by itself
    5: \ TOS and FTOS can be kept in register( variable)s.
    6: \ 
    7: \ Problems:
    8: \ The TOS optimization is somewhat hairy. The problems by example:
    9: \ 1) dup ( w -- w w ): w=TOS; sp-=1; sp[1]=w; TOS=w;
   10: \    The store is not superfluous although the earlier opt. would think so
   11: \    Alternatively:    sp[0]=TOS; w=TOS; sp-=1; TOS=w;
   12: \ 2) ( -- .. ): sp[0] = TOS; ... /* This additional store is necessary */
   13: \ 3) ( .. -- ): ... TOS = sp[0]; /* as well as this load */
   14: \ 4) ( -- ): /* but here they are unnecessary */
   15: \ 5) Words that call NEXT themselves have to be done very carefully.
   16: \
   17: \ To do:
   18: \ add the store optimization for doubles
   19: \ regarding problem 1 above: It would be better (for over) to implement
   20: \ 	the alternative
   21: 
   22: warnings off
   23: 
   24: include gray.fs
   25: include search-order.fs
   26: 
   27: 100 constant max-effect \ number of things on one side of a stack effect
   28: 4096 constant batch-size \ no meaning, just make sure it's >0
   29: 255 constant maxchar
   30: maxchar 1+ constant eof-char
   31: 9 constant tab-char
   32: 10 constant nl-char
   33: 
   34: : read-whole-file ( c-addr1 file-id -- c-addr2 )
   35: \ reads the contents of the file file-id puts it into memory at c-addr1
   36: \ c-addr2 is the first address after the file block
   37:   begin ( c-addr file-id )
   38:     2dup batch-size swap read-file 
   39:     if
   40:       abort" I/O error"
   41:     endif
   42:     ( c-addr file-id actual-size ) rot over + -rot
   43:     batch-size <>
   44:   until
   45:   drop ;
   46: 
   47: variable input \ pointer to next character to be parsed
   48: variable endinput \ pointer to the end of the input (the char after the last)
   49: 
   50: : start ( -- addr )
   51:  input @ ;
   52: 
   53: : end ( addr -- addr u )
   54:  input @ over - ;
   55: 
   56: variable output \ xt ( -- ) of output word
   57: 
   58: : printprim ( -- )
   59:  output @ execute ;
   60: 
   61: : field
   62:  <builds-field ( n1 n2 -- n3 )
   63:  does>         ( addr1 -- addr2 )
   64:    @ + ;
   65: 
   66: : const-field
   67:  <builds-field ( n1 n2 -- n3 )
   68:  does>         ( addr -- w )
   69:    @ + @ ;
   70: 
   71: struct
   72:  2 cells field item-name
   73:  cell field item-d-offset
   74:  cell field item-f-offset
   75:  cell field item-type
   76: constant item-descr
   77: 
   78: 2variable forth-name
   79: 2variable wordset
   80: 2variable c-name
   81: 2variable doc
   82: 2variable c-code
   83: 2variable forth-code
   84: 2variable stack-string
   85: create effect-in  max-effect item-descr * allot
   86: create effect-out max-effect item-descr * allot
   87: variable effect-in-end ( pointer )
   88: variable effect-out-end ( pointer )
   89: 2variable effect-in-size
   90: 2variable effect-out-size
   91: 
   92: variable primitive-number -8 primitive-number !
   93: 
   94: \ for several reasons stack items of a word are stored in a wordlist
   95: \ since neither forget nor marker are implemented yet, we make a new
   96: \ wordlist for every word and store it in the variable items
   97: variable items
   98: 
   99: \ a few more set ops
  100: 
  101: : bit-equivalent ( w1 w2 -- w3 )
  102:  xor invert ;
  103: 
  104: : complement ( set1 -- set2 )
  105:  empty ['] bit-equivalent binary-set-operation ;
  106: 
  107: \ the parser
  108: 
  109: eof-char max-member \ the whole character set + EOF
  110: 
  111: : getinput ( -- n )
  112:  input @
  113:  dup endinput @ =
  114:  if
  115:    drop eof-char
  116:  else
  117:    c@
  118:  endif ;
  119: 
  120: :noname ( n -- )
  121:  dup bl > if
  122:   emit space
  123:  else
  124:   .
  125:  endif ;
  126: print-token !
  127: 
  128: : testchar? ( set -- f )
  129:  getinput member? ;
  130: ' testchar? test-vector !
  131: 
  132: : ?nextchar ( f -- )
  133:  ?not? if
  134:    ." syntax error" cr
  135:    getinput . cr
  136:    input @ endinput @ over - 100 min type cr
  137:    abort
  138:  endif
  139:  input @ endinput @ <> if
  140:    1 input +!
  141:  endif ;
  142: 
  143: : charclass ( set "name" -- )
  144:  ['] ?nextchar terminal ;
  145: 
  146: : .. ( c1 c2 -- set )
  147:  ( creates a set that includes the characters c, c1<=c<=c2 )
  148:  empty copy-set
  149:  swap 1+ rot do
  150:   i over add-member
  151:  loop ;
  152: 
  153: : ` ( -- terminal ) ( use: ` c )
  154:  ( creates anonymous terminal for the character c )
  155:  [compile] ascii singleton ['] ?nextchar make-terminal ;
  156: 
  157: char a char z ..  char A char Z ..  union char _ singleton union  charclass letter
  158: char 0 char 9 ..					charclass digit
  159: bl singleton						charclass blank
  160: tab-char singleton					charclass tab
  161: nl-char singleton eof-char over add-member complement	charclass nonl
  162: nl-char singleton eof-char over add-member char : over add-member complement  charclass nocolonnl
  163: bl 1+ maxchar ..					charclass nowhite
  164: char " singleton eof-char over add-member complement	charclass noquote
  165: nl-char singleton					charclass nl
  166: eof-char singleton					charclass eof
  167: 
  168: 
  169: (( letter (( letter || digit )) **
  170: )) <- c-name ( -- )
  171: 
  172: nowhite ++
  173: <- name ( -- )
  174: 
  175: (( ` \ nonl ** nl
  176: )) <- comment ( -- )
  177: 
  178: (( {{ effect-in }} (( {{ start }} c-name {{ end 2 pick item-name 2! item-descr + }} blank ** )) ** {{ effect-in-end ! }}
  179:    ` - ` - blank **
  180:    {{ effect-out }} (( {{ start }} c-name {{ end 2 pick item-name 2! item-descr + }} blank ** )) ** {{ effect-out-end ! }}
  181: )) <- stack-effect ( -- )
  182: 
  183: (( {{ s" " doc 2! s" " forth-code 2! }}
  184:    (( comment || nl )) **
  185:    (( {{ start }} name {{ end 2dup forth-name 2! c-name 2! }}  tab ++
  186:       {{ start }} stack-effect {{ end stack-string 2! }} tab ++
  187:         {{ start }} name {{ end wordset 2! }} tab **
  188:         (( {{ start }}  c-name {{ end c-name 2! }} )) ??  nl
  189:    ))
  190:    (( ` " ` "  {{ start }} (( noquote ++ ` " )) ++ {{ end 1- doc 2! }} ` " nl )) ??
  191:    {{ start }} (( nocolonnl nonl **  nl )) ** {{ end c-code 2! }}
  192:    (( ` :  nl
  193:       {{ start }} (( nonl ++  nl )) ++ {{ end forth-code 2! }}
  194:    )) ??
  195:    (( nl || eof ))
  196: )) <- primitive ( -- )
  197: 
  198: (( (( primitive {{ printprim }} )) **  eof ))
  199: parser primitives2something
  200: warnings @ [IF]
  201: .( parser generated ok ) cr
  202: [THEN]
  203: 
  204: : primfilter ( file-id xt -- )
  205: \ fileid is for the input file, xt ( -- ) is for the output word
  206:  output !
  207:  here input !
  208:  here swap read-whole-file
  209:  dup endinput !
  210:  here - allot
  211:  align
  212:  primitives2something ;
  213: 
  214: \ types
  215: 
  216: struct
  217:  2 cells field type-c-name
  218:  cell const-field type-d-size
  219:  cell const-field type-f-size
  220:  cell const-field type-fetch-handler
  221:  cell const-field type-store-handler
  222: constant type-description
  223: 
  224: : data-stack-access ( n1 n2 n3 -- )
  225: \ n1 is the offset of the accessed item, n2, n3 are effect-*-size
  226:  drop swap - 1- dup
  227:  if
  228:    ." sp[" 0 .r ." ]"
  229:  else
  230:    drop ." TOS"
  231:  endif ;
  232: 
  233: : fp-stack-access ( n1 n2 n3 -- )
  234: \ n1 is the offset of the accessed item, n2, n3 are effect-*-size
  235:  nip swap - 1- dup
  236:  if
  237:    ." fp[" 0 .r ." ]"
  238:  else
  239:    drop ." FTOS"
  240:  endif ;
  241: 
  242: : fetch-single ( item -- )
  243:  >r
  244:  r@ item-name 2@ type ."  = (" 
  245:  r@ item-type @ type-c-name 2@ type ." ) "
  246:  r@ item-d-offset @ effect-in-size 2@ data-stack-access ." ;" cr
  247:  rdrop ; 
  248: 
  249: : fetch-double ( item -- )
  250:  >r
  251:  ." {Double_Store _d; _d.cells.low = "
  252:  r@ item-d-offset @ dup    effect-in-size 2@ data-stack-access
  253:  ." ; _d.cells.high = " 1+ effect-in-size 2@ data-stack-access ." ; "
  254:  r@ item-name 2@ type ."  = _d.dcell;}" cr
  255:  rdrop ;
  256: 
  257: : fetch-float ( item -- )
  258:  >r
  259:  r@ item-name 2@ type ."  = "
  260:  \ ." (" r@ item-type @ type-c-name 2@ type ." ) "
  261:  r@ item-f-offset @ effect-in-size 2@ fp-stack-access ." ;" cr
  262:  rdrop ;
  263: 
  264: : d-same-as-in? ( item -- f )
  265: \ f is true iff the offset of item is the same as on input
  266:  >r
  267:  r@ item-name 2@ items @ search-wordlist 0=
  268:  if
  269:    ." bug" cr abort
  270:  endif
  271:  execute @
  272:  dup r@ =
  273:  if \ item first appeared in output
  274:    drop false
  275:  else
  276:    item-d-offset @ r@ item-d-offset @ =
  277:  endif
  278:  rdrop ;
  279: 
  280: : is-in-tos? ( item -- f )
  281: \ true if item has the same offset as the input TOS
  282:  item-d-offset @ 1+ effect-in-size 2@ drop = ;
  283: 
  284: : really-store-single ( item -- )
  285:  >r
  286:  r@ item-d-offset @ effect-out-size 2@ data-stack-access ."  = (Cell)"
  287:  r@ item-name 2@ type ." ;"
  288:  rdrop ;
  289: 
  290: : store-single ( item -- )
  291:  >r
  292:  r@ d-same-as-in?
  293:  if
  294:    r@ is-in-tos?
  295:    if
  296:      ." IF_TOS(" r@ really-store-single ." );" cr
  297:    endif
  298:  else
  299:    r@ really-store-single cr
  300:  endif
  301:  rdrop ;
  302: 
  303: : store-double ( item -- )
  304: \ !! store optimization is not performed, because it is not yet needed
  305:  >r
  306:  ." {Double_Store _d; _d.dcell = " r@ item-name 2@ type ." ; "
  307:  r@ item-d-offset @ dup    effect-out-size 2@ data-stack-access 
  308:  ."  = _d.cells.low; " 1+ effect-out-size 2@ data-stack-access
  309:  ." = _d.cells.high;}" cr
  310:  rdrop ;
  311: 
  312: : f-same-as-in? ( item -- f )
  313: \ f is true iff the offset of item is the same as on input
  314:  >r
  315:  r@ item-name 2@ items @ search-wordlist 0=
  316:  if
  317:    ." bug" cr abort
  318:  endif
  319:  execute @
  320:  dup r@ =
  321:  if \ item first appeared in output
  322:    drop false
  323:  else
  324:    item-f-offset @ r@ item-f-offset @ =
  325:  endif
  326:  rdrop ;
  327: 
  328: : is-in-ftos? ( item -- f )
  329: \ true if item has the same offset as the input TOS
  330:  item-f-offset @ 1+ effect-in-size 2@ nip = ;
  331: 
  332: : really-store-float ( item -- )
  333:  >r
  334:  r@ item-f-offset @ effect-out-size 2@ fp-stack-access ."  = "
  335:  r@ item-name 2@ type ." ;"
  336:  rdrop ;
  337: 
  338: : store-float ( item -- )
  339:  >r
  340:  r@ f-same-as-in?
  341:  if
  342:    r@ is-in-ftos?
  343:    if
  344:      ." IF_FTOS(" r@ really-store-float ." );" cr
  345:    endif
  346:  else
  347:    r@ really-store-float cr
  348:  endif
  349:  rdrop ;
  350:  
  351: : single-type ( -- xt n1 n2 )
  352:  ['] fetch-single ['] store-single 1 0 ;
  353: 
  354: : double-type ( -- xt n1 n2 )
  355:  ['] fetch-double ['] store-double 2 0 ;
  356: 
  357: : float-type ( -- xt n1 n2 )
  358:  ['] fetch-float ['] store-float 0 1 ;
  359: 
  360: : s, ( addr u -- )
  361: \ allocate a string
  362:  here swap dup allot move ;
  363: 
  364: : starts-with ( addr u xt1 xt2 n1 n2 "prefix" -- )
  365: \ describes a type
  366: \ addr u specifies the C type name
  367: \ n1 is the size of the type on the data stack
  368: \ n2 is the size of the type on the FP stack
  369: \ stack effect entries of the type start with prefix
  370:  >r >r >r >r
  371:  dup >r here >r s,
  372:  create
  373:  r> r> 2,
  374:  r> r> r> , r> , swap , , ;
  375: 
  376: wordlist constant types
  377: get-current
  378: types set-current
  379: 
  380: s" Bool"	single-type starts-with f
  381: s" Char"	single-type starts-with c
  382: s" Cell"	single-type starts-with n
  383: s" Cell"	single-type starts-with w
  384: s" UCell"	single-type starts-with u
  385: s" DCell"	double-type starts-with d
  386: s" UDCell"	double-type starts-with ud
  387: s" Float"	float-type  starts-with r
  388: s" Cell *"	single-type starts-with a_
  389: s" Char *"	single-type starts-with c_
  390: s" Float *"	single-type starts-with f_
  391: s" DFloat *"	single-type starts-with df_
  392: s" SFloat *"	single-type starts-with sf_
  393: s" Xt"		single-type starts-with xt
  394: s" WID"		single-type starts-with wid
  395: s" F83Name *"	single-type starts-with f83name
  396: 
  397: set-current
  398: 
  399: : get-type ( addr1 u1 -- type-descr )
  400: \ get the type of the name in addr1 u1
  401: \ type-descr is a pointer to a type-descriptor
  402:  0 swap ?do
  403:    dup i types search-wordlist
  404:    if \ ok, we have the type ( addr1 xt )
  405:      execute nip
  406:      UNLOOP EXIT
  407:    endif
  408:  -1 s+loop
  409:  \ we did not find a type, abort
  410:  ." unknown type prefix" cr ABORT ;
  411: 
  412: : declare ( addr "name" -- )
  413: \ remember that there is a stack item at addr called name
  414:  create , ;
  415: 
  416: : declaration ( item -- )
  417:  dup item-name 2@ items @ search-wordlist
  418:  if \ already declared ( item xt )
  419:    execute @ item-type @ swap item-type !
  420:  else ( addr )
  421:    dup item-name 2@ nextname dup declare ( addr )
  422:    dup >r item-name 2@ 2dup get-type ( addr1 u type-descr )
  423:    dup r> item-type ! ( addr1 u type-descr )
  424:    type-c-name 2@ type space type ." ;" cr
  425:  endif ;
  426: 
  427: : declaration-list ( addr1 addr2 -- )
  428:  swap ?do
  429:   i declaration
  430:  item-descr +loop ;
  431: 
  432: : declarations ( -- )
  433:  wordlist dup items ! set-current
  434:  effect-in effect-in-end @ declaration-list
  435:  effect-out effect-out-end @ declaration-list ;
  436: 
  437: \ offset computation
  438: \ the leftmost (i.e. deepest) item has offset 0
  439: \ the rightmost item has the highest offset
  440: 
  441: : compute-offset ( n1 n2 item -- n3 n4 )
  442: \ n1, n3 are data-stack-offsets
  443: \ n2, n4 are the fp-stack-offsets
  444:  >r
  445:  swap dup r@ item-d-offset !
  446:  r@ item-type @ type-d-size +
  447:  swap dup r@ item-f-offset !
  448:  r@ item-type @ type-f-size +
  449:  rdrop ;
  450: 
  451: : compute-list ( addr1 addr2 -- n1 n2 )
  452: \ n1, n2 are the final offsets
  453:  0 0 2swap swap ?do
  454:   i compute-offset
  455:  item-descr +loop ;
  456: 
  457: : compute-offsets ( -- )
  458:  effect-in effect-in-end @ compute-list effect-in-size 2!
  459:  effect-out effect-out-end @ compute-list effect-out-size 2! ;
  460: 
  461: : flush-tos ( -- )
  462:  effect-in-size 2@ effect-out-size 2@
  463:  0<> rot 0= and
  464:  if
  465:    ." IF_FTOS(fp[0] = FTOS);" cr
  466:  endif
  467:  0<> swap 0= and
  468:  if
  469:    ." IF_TOS(sp[0] = TOS);" cr
  470:  endif ;
  471: 
  472: : fill-tos ( -- )
  473:  effect-in-size 2@ effect-out-size 2@
  474:  0= rot 0<> and
  475:  if
  476:    ." IF_FTOS(FTOS = fp[0]);" cr
  477:  endif
  478:  0= swap 0<> and
  479:  if
  480:    ." IF_TOS(TOS = sp[0]);" cr
  481:  endif ;
  482: 
  483: : fetch ( addr -- )
  484:  dup item-type @ type-fetch-handler execute ;
  485: 
  486: : fetches ( -- )
  487:  effect-in-end @ effect-in ?do
  488:    i fetch
  489:  item-descr +loop ; 
  490: 
  491: : stack-pointer-updates ( -- )
  492: \ we do not check if an update is a noop; gcc does this for us
  493:  effect-in-size 2@
  494:  effect-out-size 2@
  495:  rot swap - ( d-in d-out f-diff )
  496:  rot rot - ( f-diff d-diff )
  497:  ?dup IF  ." sp += " 0 .r ." ;" cr  THEN
  498:  ?dup IF  ." fp += " 0 .r ." ;" cr  THEN ;
  499: 
  500: : store ( item -- )
  501: \ f is true if the item should be stored
  502: \ f is false if the store is probably not necessary
  503:  dup item-type @ type-store-handler execute ;
  504: 
  505: : stores ( -- )
  506:  effect-out-end @ effect-out ?do
  507:    i store
  508:  item-descr +loop ; 
  509: 
  510: : output-c ( -- )
  511:  ." I_" c-name 2@ type ." :	/* " forth-name 2@ type ."  ( " stack-string 2@ type ."  ) */" cr
  512:  ." /* " doc 2@ type ."  */" cr
  513:  ." {" cr
  514:  ." DEF_CA" cr
  515:  declarations
  516:  compute-offsets \ for everything else
  517:  flush-tos
  518:  fetches
  519:  stack-pointer-updates cr
  520:  ." NAME(" [char] " emit forth-name 2@ type [char] " emit ." )" cr \ debugging
  521:  ." {" cr
  522:  c-code 2@ type
  523:  ." }" cr
  524:  ." NEXT_P1;" cr
  525:  stores
  526:  fill-tos
  527:  ." NEXT1_P2;" cr
  528:  ." }" cr
  529:  cr
  530: ;
  531: 
  532: : output-label ( -- )
  533:  ." &&I_" c-name 2@ type ." ," cr ;
  534: 
  535: : output-alias ( -- )
  536:  primitive-number @ . ." alias " forth-name 2@ type cr
  537:  -1 primitive-number +! ;
  538: 
  539: : process-file ( addr u xt -- )
  540:  >r r/o open-file
  541:  if
  542:    ." cannot open file" cr abort
  543:  endif
  544:  warnings @ if
  545:  ." ------------ CUT HERE -------------" cr  endif
  546:  r> [ ] primfilter [ 0 ] ;

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>