Return to args.fs CVS log

Up to [gforth] / gforth

Annotation of gforth/args.fs, revision 1.4

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
1.4     ! anton      24:     \g returns the string for the @var{n}th command-line argument.
1.1       pazsan     25:     cells argv @ + @ cstring>sstring ;
1.4     ! anton      26: : #! ( -- ) \ gforth   hash-bang
        !            27:     \g an alias for @code{\}
        !            28:     postpone \ ;  immediate
1.1       pazsan     29: 
                     30: Create pathstring 2 cells allot \ string
                     31: Create pathdirs   2 cells allot \ dir string array, pointer and count
1.4     ! anton      32: Variable argv ( -- addr ) \ gforth
        !            33: \ \g contains a pointer to a vector of pointers to the command-line
        !            34: \ \g arguments (including the command-name). Each argument is
        !            35: \ \g represented as a C-style string.
        !            36: Variable argc ( -- addr ) \ gforth
        !            37: \ \g contains the number of command-line arguments (including the command name)
1.1       pazsan     38: 
                     39: 0 Value script? ( -- flag )
                     40: 
                     41: : process-path ( addr1 u1 -- addr2 u2 )
                     42:     \ addr1 u1 is a path string, addr2 u2 is an array of dir strings
                     43:     align here >r
                     44:     BEGIN
                     45:        over >r 0 scan
                     46:        over r> tuck - ( rest-str this-str )
                     47:        dup
                     48:        IF
                     49:            2dup 1- chars + c@ [char] / <>
                     50:            IF
                     51:                2dup chars + [char] / swap c!
                     52:                1+
                     53:            THEN
                     54:            2,
                     55:        ELSE
                     56:            2drop
                     57:        THEN
                     58:        dup
                     59:     WHILE
                     60:        1 /string
                     61:     REPEAT
                     62:     2drop
                     63:     here r> tuck - 2 cells / ;
                     64: 
                     65: : do-option ( addr1 len1 addr2 len2 -- n )
                     66:     2swap
                     67:     2dup s" -e"         compare  0= >r
                     68:     2dup s" --evaluate" compare  0= r> or
                     69:     IF  2drop dup >r ['] evaluate catch
                     70:        ?dup IF  dup >r DoError r> negate (bye)  THEN
                     71:        r> >tib +!  2 EXIT  THEN
                     72:     ." Unknown option: " type cr 2drop 1 ;
                     73: 
                     74: : process-args ( -- )
                     75:     true to script?
                     76:     >tib @ >r
                     77:     argc @ 1
                     78:     ?DO
                     79:        I arg over c@ [char] - <>
                     80:        IF
                     81:            required 1
                     82:        ELSE
                     83:            I 1+ argc @ =  IF  s" "  ELSE  I 1+ arg  THEN
                     84:            do-option
                     85:        THEN
                     86:     +LOOP
                     87:     r> >tib !
                     88:     false to script?
                     89: ;
                     90: