File:  [gforth] / gforth / prims2x.fs
Revision 1.15: download - view: text, annotated - select for diffs
Mon Oct 16 18:33:12 1995 UTC (28 years, 5 months ago) by anton
Branches: MAIN
CVS tags: HEAD
added answords.fs and strsignal.c
added checking of documenetation of ANS Forth words
Fixed many documentation errors and added some documentation
signal handling now uses strsignal and can handle signals not present on all machines

    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: [IFUNDEF] vocabulary    include search-order.fs [THEN]
   25: [IFUNDEF] environment?  include environ.fs      [THEN]
   26: include gray.fs
   27: 
   28: 100 constant max-effect \ number of things on one side of a stack effect
   29: 4096 constant batch-size \ no meaning, just make sure it's >0
   30: 255 constant maxchar
   31: maxchar 1+ constant eof-char
   32: 9 constant tab-char
   33: 10 constant nl-char
   34: 
   35: : read-whole-file ( c-addr1 file-id -- c-addr2 )
   36: \ reads the contents of the file file-id puts it into memory at c-addr1
   37: \ c-addr2 is the first address after the file block
   38:   begin ( c-addr file-id )
   39:     2dup batch-size swap read-file 
   40:     if
   41:       true abort" I/O error"
   42:     endif
   43:     ( c-addr file-id actual-size ) rot over + -rot
   44:     batch-size <>
   45:   until
   46:   drop ;
   47: 
   48: variable input \ pointer to next character to be parsed
   49: variable endinput \ pointer to the end of the input (the char after the last)
   50: 
   51: : start ( -- addr )
   52:  input @ ;
   53: 
   54: : end ( addr -- addr u )
   55:  input @ over - ;
   56: 
   57: variable output \ xt ( -- ) of output word
   58: 
   59: : printprim ( -- )
   60:  output @ execute ;
   61: 
   62: : field
   63:  <builds-field ( n1 n2 -- n3 )
   64:  does>         ( addr1 -- addr2 )
   65:    @ + ;
   66: 
   67: : const-field
   68:  <builds-field ( n1 n2 -- n3 )
   69:  does>         ( addr -- w )
   70:    @ + @ ;
   71: 
   72: struct
   73:  2 cells field item-name
   74:  cell field item-d-offset
   75:  cell field item-f-offset
   76:  cell field item-type
   77: constant item-descr
   78: 
   79: 2variable forth-name
   80: 2variable wordset
   81: 2variable c-name
   82: 2variable doc
   83: 2variable c-code
   84: 2variable forth-code
   85: 2variable stack-string
   86: create effect-in  max-effect item-descr * allot
   87: create effect-out max-effect item-descr * allot
   88: variable effect-in-end ( pointer )
   89: variable effect-out-end ( pointer )
   90: 2variable effect-in-size
   91: 2variable effect-out-size
   92: 
   93: variable primitive-number -10 primitive-number !
   94: 
   95: \ for several reasons stack items of a word are stored in a wordlist
   96: \ since neither forget nor marker are implemented yet, we make a new
   97: \ wordlist for every word and store it in the variable items
   98: variable items
   99: 
  100: \ a few more set ops
  101: 
  102: : bit-equivalent ( w1 w2 -- w3 )
  103:  xor invert ;
  104: 
  105: : complement ( set1 -- set2 )
  106:  empty ['] bit-equivalent binary-set-operation ;
  107: 
  108: \ the parser
  109: 
  110: eof-char max-member \ the whole character set + EOF
  111: 
  112: : getinput ( -- n )
  113:  input @
  114:  dup endinput @ =
  115:  if
  116:    drop eof-char
  117:  else
  118:    c@
  119:  endif ;
  120: 
  121: :noname ( n -- )
  122:  dup bl > if
  123:   emit space
  124:  else
  125:   .
  126:  endif ;
  127: print-token !
  128: 
  129: : testchar? ( set -- f )
  130:  getinput member? ;
  131: ' testchar? test-vector !
  132: 
  133: : ?nextchar ( f -- )
  134:  ?not? if
  135:    ." syntax error" cr
  136:    getinput . cr
  137:    input @ endinput @ over - 100 min type cr
  138:    abort
  139:  endif
  140:  input @ endinput @ <> if
  141:    1 input +!
  142:  endif ;
  143: 
  144: : charclass ( set "name" -- )
  145:  ['] ?nextchar terminal ;
  146: 
  147: : .. ( c1 c2 -- set )
  148:  ( creates a set that includes the characters c, c1<=c<=c2 )
  149:  empty copy-set
  150:  swap 1+ rot do
  151:   i over add-member
  152:  loop ;
  153: 
  154: : ` ( -- terminal ) ( use: ` c )
  155:  ( creates anonymous terminal for the character c )
  156:  [compile] ascii singleton ['] ?nextchar make-terminal ;
  157: 
  158: char a char z ..  char A char Z ..  union char _ singleton union  charclass letter
  159: char 0 char 9 ..					charclass digit
  160: bl singleton						charclass blank
  161: tab-char singleton					charclass tab
  162: nl-char singleton eof-char over add-member complement	charclass nonl
  163: nl-char singleton eof-char over add-member char : over add-member complement  charclass nocolonnl
  164: bl 1+ maxchar ..					charclass nowhite
  165: char " singleton eof-char over add-member complement	charclass noquote
  166: nl-char singleton					charclass nl
  167: eof-char singleton					charclass eof
  168: 
  169: 
  170: (( letter (( letter || digit )) **
  171: )) <- c-name ( -- )
  172: 
  173: nowhite ++
  174: <- name ( -- )
  175: 
  176: (( ` \ nonl ** nl
  177: )) <- comment ( -- )
  178: 
  179: (( {{ effect-in }} (( {{ start }} c-name {{ end 2 pick item-name 2! item-descr + }} blank ** )) ** {{ effect-in-end ! }}
  180:    ` - ` - blank **
  181:    {{ effect-out }} (( {{ start }} c-name {{ end 2 pick item-name 2! item-descr + }} blank ** )) ** {{ effect-out-end ! }}
  182: )) <- stack-effect ( -- )
  183: 
  184: (( {{ s" " doc 2! s" " forth-code 2! }}
  185:    (( comment || nl )) **
  186:    (( {{ start }} name {{ end 2dup forth-name 2! c-name 2! }}  tab ++
  187:       {{ start }} stack-effect {{ end stack-string 2! }} tab ++
  188:         {{ start }} name {{ end wordset 2! }} tab **
  189:         (( {{ start }}  c-name {{ end c-name 2! }} )) ??  nl
  190:    ))
  191:    (( ` " ` "  {{ start }} (( noquote ++ ` " )) ++ {{ end 1- doc 2! }} ` " nl )) ??
  192:    {{ start }} (( nocolonnl nonl **  nl )) ** {{ end c-code 2! }}
  193:    (( ` :  nl
  194:       {{ start }} (( nonl ++  nl )) ++ {{ end forth-code 2! }}
  195:    )) ??
  196:    (( nl || eof ))
  197: )) <- primitive ( -- )
  198: 
  199: (( (( primitive {{ printprim }} )) **  eof ))
  200: parser primitives2something
  201: warnings @ [IF]
  202: .( parser generated ok ) cr
  203: [THEN]
  204: 
  205: : primfilter ( file-id xt -- )
  206: \ fileid is for the input file, xt ( -- ) is for the output word
  207:  output !
  208:  here input !
  209:  here swap read-whole-file
  210:  dup endinput !
  211:  here - allot
  212:  align
  213:  primitives2something ;
  214: 
  215: \ types
  216: 
  217: struct
  218:  2 cells field type-c-name
  219:  cell const-field type-d-size
  220:  cell const-field type-f-size
  221:  cell const-field type-fetch-handler
  222:  cell const-field type-store-handler
  223: constant type-description
  224: 
  225: : data-stack-access ( n1 n2 n3 -- )
  226: \ n1 is the offset of the accessed item, n2, n3 are effect-*-size
  227:  drop swap - 1- dup
  228:  if
  229:    ." sp[" 0 .r ." ]"
  230:  else
  231:    drop ." TOS"
  232:  endif ;
  233: 
  234: : fp-stack-access ( n1 n2 n3 -- )
  235: \ n1 is the offset of the accessed item, n2, n3 are effect-*-size
  236:  nip swap - 1- dup
  237:  if
  238:    ." fp[" 0 .r ." ]"
  239:  else
  240:    drop ." FTOS"
  241:  endif ;
  242: 
  243: : fetch-single ( item -- )
  244:  >r
  245:  r@ item-name 2@ type
  246:  ."  = (" 
  247:  r@ item-type @ type-c-name 2@ type ." ) "
  248:  r@ item-d-offset @ effect-in-size 2@ data-stack-access ." ;" cr
  249:  rdrop ; 
  250: 
  251: : fetch-double ( item -- )
  252:  >r
  253:  r@ item-name 2@ type 
  254:  ." = ({Double_Store _d; _d.cells.low = "
  255:  r@ item-d-offset @ dup    effect-in-size 2@ data-stack-access
  256:  ." ; _d.cells.high = " 1+ effect-in-size 2@ data-stack-access
  257:  ." ; _d.dcell;});" cr
  258:  rdrop ;
  259: 
  260: : fetch-float ( item -- )
  261:  >r
  262:  r@ item-name 2@ type
  263:  ."  = "
  264:  \ ." (" r@ item-type @ type-c-name 2@ type ." ) "
  265:  r@ item-f-offset @ effect-in-size 2@ fp-stack-access ." ;" cr
  266:  rdrop ;
  267: 
  268: : d-same-as-in? ( item -- f )
  269: \ f is true iff the offset of item is the same as on input
  270:  >r
  271:  r@ item-name 2@ items @ search-wordlist 0=
  272:  abort" bug"
  273:  execute @
  274:  dup r@ =
  275:  if \ item first appeared in output
  276:    drop false
  277:  else
  278:    item-d-offset @ r@ item-d-offset @ =
  279:  endif
  280:  rdrop ;
  281: 
  282: : is-in-tos? ( item -- f )
  283: \ true if item has the same offset as the input TOS
  284:  item-d-offset @ 1+ effect-in-size 2@ drop = ;
  285: 
  286: : really-store-single ( item -- )
  287:  >r
  288:  r@ item-d-offset @ effect-out-size 2@ data-stack-access ."  = (Cell)"
  289:  r@ item-name 2@ type ." ;"
  290:  rdrop ;
  291: 
  292: : store-single ( item -- )
  293:  >r
  294:  r@ d-same-as-in?
  295:  if
  296:    r@ is-in-tos?
  297:    if
  298:      ." IF_TOS(" r@ really-store-single ." );" cr
  299:    endif
  300:  else
  301:    r@ really-store-single cr
  302:  endif
  303:  rdrop ;
  304: 
  305: : store-double ( item -- )
  306: \ !! store optimization is not performed, because it is not yet needed
  307:  >r
  308:  ." {Double_Store _d; _d.dcell = " r@ item-name 2@ type ." ; "
  309:  r@ item-d-offset @ dup    effect-out-size 2@ data-stack-access 
  310:  ."  = _d.cells.low; " 1+ effect-out-size 2@ data-stack-access
  311:  ." = _d.cells.high;}" cr
  312:  rdrop ;
  313: 
  314: : f-same-as-in? ( item -- f )
  315: \ f is true iff the offset of item is the same as on input
  316:  >r
  317:  r@ item-name 2@ items @ search-wordlist 0=
  318:  abort" bug"
  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 ( -- xt1 xt2 n1 n2 )
  352:  ['] fetch-single ['] store-single 1 0 ;
  353: 
  354: : double-type ( -- xt1 xt2 n1 n2 )
  355:  ['] fetch-double ['] store-double 2 0 ;
  356: 
  357: : float-type ( -- xt1 xt2 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:  true abort" unknown type prefix" ;
  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: : fetch ( addr -- )
  433:  dup item-type @ type-fetch-handler execute ;
  434: 
  435: : declarations ( -- )
  436:  wordlist dup items ! set-current
  437:  effect-in effect-in-end @ declaration-list
  438:  effect-out effect-out-end @ declaration-list ;
  439: 
  440: \ offset computation
  441: \ the leftmost (i.e. deepest) item has offset 0
  442: \ the rightmost item has the highest offset
  443: 
  444: : compute-offset ( n1 n2 item -- n3 n4 )
  445: \ n1, n3 are data-stack-offsets
  446: \ n2, n4 are the fp-stack-offsets
  447:  >r
  448:  swap dup r@ item-d-offset !
  449:  r@ item-type @ type-d-size +
  450:  swap dup r@ item-f-offset !
  451:  r@ item-type @ type-f-size +
  452:  rdrop ;
  453: 
  454: : compute-list ( addr1 addr2 -- n1 n2 )
  455: \ n1, n2 are the final offsets
  456:  0 0 2swap swap ?do
  457:   i compute-offset
  458:  item-descr +loop ;
  459: 
  460: : compute-offsets ( -- )
  461:  effect-in effect-in-end @ compute-list effect-in-size 2!
  462:  effect-out effect-out-end @ compute-list effect-out-size 2! ;
  463: 
  464: : flush-tos ( -- )
  465:  effect-in-size 2@ effect-out-size 2@
  466:  0<> rot 0= and
  467:  if
  468:    ." IF_FTOS(fp[0] = FTOS);" cr
  469:  endif
  470:  0<> swap 0= and
  471:  if
  472:    ." IF_TOS(sp[0] = TOS);" cr
  473:  endif ;
  474: 
  475: : fill-tos ( -- )
  476:  effect-in-size 2@ effect-out-size 2@
  477:  0= rot 0<> and
  478:  if
  479:    ." IF_FTOS(FTOS = fp[0]);" cr
  480:  endif
  481:  0= swap 0<> and
  482:  if
  483:    ." IF_TOS(TOS = sp[0]);" cr
  484:  endif ;
  485: 
  486: : fetches ( -- )
  487:  effect-in-end @ effect-in ?do
  488:    i fetch
  489:  item-descr +loop ; 
  490: 
  491: : stack-pointer-updates ( -- )
  492: \ we need 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: : .stack-list ( start end -- )
  511:  swap ?do
  512:    i item-name 2@ type space
  513:  item-descr +loop ; 
  514: 
  515: : output-c ( -- )
  516:  ." I_" c-name 2@ type ." :	/* " forth-name 2@ type ."  ( " stack-string 2@ type ."  ) */" cr
  517:  ." /* " doc 2@ type ."  */" cr
  518:  ." NAME(" [char] " emit forth-name 2@ type [char] " emit ." )" cr \ debugging
  519:  ." {" cr
  520:  ." DEF_CA" cr
  521:  declarations
  522:  compute-offsets \ for everything else
  523:  ." NEXT_P0;" cr
  524:  flush-tos
  525:  fetches
  526:  stack-pointer-updates
  527:  ." {" cr
  528:  c-code 2@ type
  529:  ." }" cr
  530:  ." NEXT_P1;" cr
  531:  stores
  532:  fill-tos
  533:  ." NEXT_P2;" cr
  534:  ." }" cr
  535:  cr
  536: ;
  537: 
  538: : output-label ( -- )
  539:  ." &&I_" c-name 2@ type ." ," cr ;
  540: 
  541: : output-alias ( -- )
  542:  primitive-number @ . ." alias " forth-name 2@ type cr
  543:  -1 primitive-number +! ;
  544: 
  545: : output-forth ( -- )
  546:  forth-code @ 0=
  547:  IF    output-alias
  548:  ELSE  ." : " forth-name 2@ type ."   ( "
  549:        effect-in effect-in-end @ .stack-list ." -- "
  550:        effect-out effect-out-end @ .stack-list ." )" cr
  551:        forth-code 2@ type cr
  552:        -1 primitive-number +!
  553:  THEN ;
  554: 
  555: [IFDEF] documentation
  556: : register-doc ( -- )
  557:     get-current documentation set-current
  558:     forth-name 2@ nextname create
  559:     forth-name 2@ 2,
  560:     stack-string 2@ condition-stack-effect 2,
  561:     wordset 2@ 2,
  562:     c-name 2@ condition-pronounciation 2,
  563:     doc 2@ 2,
  564:     set-current ;
  565: [THEN]
  566: 
  567: : process-file ( addr u xt -- )
  568:  >r r/o open-file abort" cannot open file"
  569:  warnings @ if
  570:  ." ------------ CUT HERE -------------" cr  endif
  571:  r> primfilter ;
  572: 

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