1: \ quote: S\" and .\" words
2:
3: \ Copyright (C) 2002,2003,2005 Free Software Foundation, Inc.
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., 59 Temple Place, Suite 330, Boston, MA 02111, USA.
20:
21: : char/ ; immediate
22:
23: : parse-num-x ( c-addr1 umax -- c-addr2 c )
24: >r 0. rot source chars + over - char/ r> umin >number
25: drop rot rot drop ;
26:
27: : parse-num ( c-addr1 umax base -- c-addr2 c )
28: ['] parse-num-x swap base-execute ;
29:
30: create \-escape-table
31: 7 c, #bs c, 'c c, 'd c, #esc c, #ff c, 'g c,
32: 'h c, 'i c, 'j c, 'k c, #lf c, #lf c, #lf c,
33: 'o c, 'p c, '" c, #cr c, 's c, #tab c, 'u c,
34: 11 c, 'w c, 'x c, 'y c, 0 c,
35:
36: : \-escape ( c-addr1 -- c-addr2 c )
37: \ c-addr1 points at a char right after a '\', c-addr2 points right
38: \ after the whole sequence, c is the translated char
39: dup c@
40: dup 'x = if
41: drop char+ 2 16 parse-num exit
42: endif
43: dup '0 '8 within if
44: drop 3 8 parse-num exit
45: endif
46: dup 'n = if
47: \ \-escapes were designed to translate to one character, so
48: \ this is quite ugly: copy all but the last char right away
49: drop newline 1-
50: 2dup here swap chars dup allot move
51: chars + c@
52: else
53: dup 'm = if \ crlf; ugly, because it's two characters
54: #cr c, \ first half, the rest follows below
55: endif
56: dup 'a '{ within if
57: 'a - chars \-escape-table + c@
58: endif
59: endif
60: 1 chars under+ ;
61:
62: : \"-parse ( "string"<"> -- c-addr u ) \ gforth-internal backslash-quote-parse
63: \G parses string, translating @code{\}-escapes to characters (as in
64: \G C). The resulting string resides at @code{here}. See @code{S\"}
65: \G for the supported @code{\-escapes}.
66: here >r
67: >in @ chars source chars over + >r + begin ( parse-area R: here parse-end )
68: dup r@ < while
69: dup c@ '" <> while
70: dup c@ dup '\ = if ( parse-area c R: here parse-end )
71: drop char+ dup r@ = abort" unfinished \-escape"
72: \-escape c,
73: else
74: c, char+
75: endif
76: repeat then
77: char+ source >r - r> min char/ >in !
78: r> drop
79: here r> - dup negate allot
80: here swap char/ ;
81:
82: :noname \"-parse save-mem ;
83: :noname \"-parse save-mem 2dup postpone sliteral drop free throw ;
84: interpret/compile: s\" ( compilation 'ccc"' -- ; run-time -- c-addr u ) \ gforth s-backslash-quote
85: \G Like @code{S"}, but translates C-like \-escape-sequences, as
86: \G follows: @code{\a} BEL (alert), @code{\b} BS, @code{\e} ESC (not in
87: \G C99), @code{\f} FF, @code{\n} newline, @code{\r} CR, @code{\t} HT,
88: \G @code{\v} VT, @code{\"} ", @code{\\} \, @code{\}[0-7]@{1,3@} octal
89: \G numerical character value (non-standard), @code{\x}[0-9a-f]@{0,2@}
90: \G hex numerical character value (standard only with two digits); a
91: \G @code{\} before any other character is reserved.
92:
93: :noname \"-parse type ;
94: :noname postpone s\" postpone type ;
95: interpret/compile: .\" ( compilation 'ccc"' -- ; run-time -- ) \ gforth dot-backslash-quote
96: \G Like @code{."}, but translates C-like \-escape-sequences (see
97: \G @code{S\"}).
98:
99: 0 [if] \ test
100: s" 123" drop 10 parse-num-x 123 <> throw drop .s
101: s" 123a" drop 10 parse-num 123 <> throw drop .s
102: s" x1fg" drop \-escape 31 <> throw drop .s
103: s" 00129" drop \-escape 10 <> throw drop .s
104: s" a" drop \-escape 7 <> throw drop .s
105: \"-parse " s" " str= 0= throw .s
106: \"-parse \a\b\c\e\f\n\r\t\v\100\x40xabcde" dump
107: s\" \a\bcd\e\fghijklm\12op\"\rs\tu\v" \-escape-table over str= 0= throw
108: s\" \w\0101\x041\"\\" name wAA"\ str= 0= throw
109: s\" s\\\" \\" ' evaluate catch 0= throw
110: [endif]
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>