Return to args.fs CVS log

Up to [gforth] / gforth

Started to merge in changes made for gforth-EC project.

    1: \ argument expansion
    2: 
    3: : cstring>sstring  ( cstring -- addr n ) \ gforth	cstring-to-sstring
    4:     -1 0 scan 0 swap 1+ /string ;
    5: : arg ( n -- addr count ) \ gforth
    6:     cells argv @ + @ cstring>sstring ;
    7: : #!       postpone \ ;  immediate
    8: 
    9: Create pathstring 2 cells allot \ string
   10: Create pathdirs   2 cells allot \ dir string array, pointer and count
   11: Variable argv
   12: Variable argc
   13: 
   14: 0 Value script? ( -- flag )
   15: 
   16: : process-path ( addr1 u1 -- addr2 u2 )
   17:     \ addr1 u1 is a path string, addr2 u2 is an array of dir strings
   18:     align here >r
   19:     BEGIN
   20: 	over >r 0 scan
   21: 	over r> tuck - ( rest-str this-str )
   22: 	dup
   23: 	IF
   24: 	    2dup 1- chars + c@ [char] / <>
   25: 	    IF
   26: 		2dup chars + [char] / swap c!
   27: 		1+
   28: 	    THEN
   29: 	    2,
   30: 	ELSE
   31: 	    2drop
   32: 	THEN
   33: 	dup
   34:     WHILE
   35: 	1 /string
   36:     REPEAT
   37:     2drop
   38:     here r> tuck - 2 cells / ;
   39: 
   40: : do-option ( addr1 len1 addr2 len2 -- n )
   41:     2swap
   42:     2dup s" -e"         compare  0= >r
   43:     2dup s" --evaluate" compare  0= r> or
   44:     IF  2drop dup >r ['] evaluate catch
   45: 	?dup IF  dup >r DoError r> negate (bye)  THEN
   46: 	r> >tib +!  2 EXIT  THEN
   47:     ." Unknown option: " type cr 2drop 1 ;
   48: 
   49: : process-args ( -- )
   50:     true to script?
   51:     >tib @ >r
   52:     argc @ 1
   53:     ?DO
   54: 	I arg over c@ [char] - <>
   55: 	IF
   56: 	    required 1
   57: 	ELSE
   58: 	    I 1+ argc @ =  IF  s" "  ELSE  I 1+ arg  THEN
   59: 	    do-option
   60: 	THEN
   61:     +LOOP
   62:     r> >tib !
   63:     false to script?
   64: ;
   65: