Return to args.fs CVS log

Up to [gforth] / gforth

Annotation of gforth/args.fs, revision 1.3

1.1       pazsan      1: \ argument expansion
                      2: 
1.3     ! anton       3: \ Copyright (C) 1995-1997 Free Software Foundation, Inc.
1.2       pazsan      4: 
                      5: \ This file is part of Gforth.
                      6: 
                      7: \ Gforth is free software; you can redistribute it and/or
                      8: \ modify it under the terms of the GNU General Public License
                      9: \ as published by the Free Software Foundation; either version 2
                     10: \ of the License, or (at your option) any later version.
                     11: 
                     12: \ This program is distributed in the hope that it will be useful,
                     13: \ but WITHOUT ANY WARRANTY; without even the implied warranty of
                     14: \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
                     15: \ GNU General Public License for more details.
                     16: 
                     17: \ You should have received a copy of the GNU General Public License
                     18: \ along with this program; if not, write to the Free Software
                     19: \ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
                     20: 
1.1       pazsan     21: : cstring>sstring  ( cstring -- addr n ) \ gforth      cstring-to-sstring
                     22:     -1 0 scan 0 swap 1+ /string ;
                     23: : arg ( n -- addr count ) \ gforth
                     24:     cells argv @ + @ cstring>sstring ;
                     25: : #!       postpone \ ;  immediate
                     26: 
                     27: Create pathstring 2 cells allot \ string
                     28: Create pathdirs   2 cells allot \ dir string array, pointer and count
                     29: Variable argv
                     30: Variable argc
                     31: 
                     32: 0 Value script? ( -- flag )
                     33: 
                     34: : process-path ( addr1 u1 -- addr2 u2 )
                     35:     \ addr1 u1 is a path string, addr2 u2 is an array of dir strings
                     36:     align here >r
                     37:     BEGIN
                     38:        over >r 0 scan
                     39:        over r> tuck - ( rest-str this-str )
                     40:        dup
                     41:        IF
                     42:            2dup 1- chars + c@ [char] / <>
                     43:            IF
                     44:                2dup chars + [char] / swap c!
                     45:                1+
                     46:            THEN
                     47:            2,
                     48:        ELSE
                     49:            2drop
                     50:        THEN
                     51:        dup
                     52:     WHILE
                     53:        1 /string
                     54:     REPEAT
                     55:     2drop
                     56:     here r> tuck - 2 cells / ;
                     57: 
                     58: : do-option ( addr1 len1 addr2 len2 -- n )
                     59:     2swap
                     60:     2dup s" -e"         compare  0= >r
                     61:     2dup s" --evaluate" compare  0= r> or
                     62:     IF  2drop dup >r ['] evaluate catch
                     63:        ?dup IF  dup >r DoError r> negate (bye)  THEN
                     64:        r> >tib +!  2 EXIT  THEN
                     65:     ." Unknown option: " type cr 2drop 1 ;
                     66: 
                     67: : process-args ( -- )
                     68:     true to script?
                     69:     >tib @ >r
                     70:     argc @ 1
                     71:     ?DO
                     72:        I arg over c@ [char] - <>
                     73:        IF
                     74:            required 1
                     75:        ELSE
                     76:            I 1+ argc @ =  IF  s" "  ELSE  I 1+ arg  THEN
                     77:            do-option
                     78:        THEN
                     79:     +LOOP
                     80:     r> >tib !
                     81:     false to script?
                     82: ;
                     83: