Check-in [bfdb6f7821]
Not logged in

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:Replace rectype-name with recognizer rev. D suggested rectype-nt
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: bfdb6f7821155c7a7454bcc1c523481c861eb7cc
User & Date: bernd 2020-07-06 12:48:55
Context
2020-07-06
13:53
Snap card broken on Chromium? check-in: b795abe718 user: bernd tags: trunk
12:48
Replace rectype-name with recognizer rev. D suggested rectype-nt check-in: bfdb6f7821 user: bernd tags: trunk
2020-06-28
22:32
jni-based volume control only on Android check-in: 2a562578fe user: bernd tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to gui.fs.

10
11
12
13
14
15
16


17
18
19
20
21
22
23
\ This program is distributed in the hope that it will be useful,
\ but WITHOUT ANY WARRANTY; without even the implied warranty of
\ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
\ GNU Affero General Public License for more details.

\ You should have received a copy of the GNU Affero General Public License
\ along with this program.  If not, see <http://www.gnu.org/licenses/>.



require minos2/widgets.fs

also minos

ctx 0= [IF]  window-init  [THEN]








>
>







10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
\ This program is distributed in the hope that it will be useful,
\ but WITHOUT ANY WARRANTY; without even the implied warranty of
\ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
\ GNU Affero General Public License for more details.

\ You should have received a copy of the GNU Affero General Public License
\ along with this program.  If not, see <http://www.gnu.org/licenses/>.

utf-8 set-encoding

require minos2/widgets.fs

also minos

ctx 0= [IF]  window-init  [THEN]

Changes to msg.fs.

2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
....
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
    last->in ?dup-0=-IF  source drop  THEN
    tuck - dup IF
	\ ." text: '" forth:type ''' forth:emit forth:cr
	$, msg-text
    ELSE  2drop  THEN ;

: text-rec ( addr u -- )
    2drop ['] noop rectype-name ;
: tag-rec ( addr u -- )
    over c@ '#' = IF
	over ?flush-text 2dup + to last->in
	[: 1 /string
	    \ ." tag: '" forth:type ''' forth:emit forth:cr
	    $, msg-tag
	;] rectype-name
    ELSE  2drop rectype-null  THEN ;
: pk-rec ( addr u -- )
    over c@ '@' = IF  2dup 1 /string ':' -skip nick>pk
	2dup d0= IF  2drop 2drop rectype-null
	ELSE
	    2>r over ?flush-text + to last->in  2r>
	    [:
		\ ." signal: '" 85type ''' forth:emit forth:cr
		$, msg-signal
	    ;] rectype-name
	THEN
    ELSE  2drop rectype-null  THEN ;
: chain-rec ( addr u -- )
    over c@ '!' = IF
	2dup 1 /string dup 0= IF  2drop 2drop rectype-null  EXIT  THEN
	snumber?
	case
	    0 of  endof
	    -1 of
		msg-group-o .msg:log[] $[]#
		over abs over u< IF  over 0< IF  +  ELSE  drop  THEN
		    >r over ?flush-text + to last->in  r>
		    [: msg-group-o .msg:log[] $[]@ chain, ;]
		    rectype-name  EXIT  THEN
	    endof
	    2drop
	endcase
    THEN  2drop  rectype-null  ;
: http-rec ( addr u -- )
    2dup "https://" string-prefix? >r
    2dup "http://" string-prefix? r> or IF
	over ?flush-text 2dup + to last->in
	[: $, msg-url ;] rectype-name
    ELSE  2drop rectype-null  THEN ;

forward hash-in

: jpeg? ( addr u -- flag )
    dup 4 - 0 max safe/string ".jpg" str= ;

................................................................................
		    r> free throw  THEN
	    ELSE  #0.  THEN
	    2swap file-in
	    2swap dup IF   >have+group  THEN
	    [:  dup IF  $, msg:thumbnail# ulit, msg-object  ELSE  2drop  THEN
		$, msg:image# ulit, msg-object ;]
	    r> free throw  r> to last->in ;]
	catch 0= IF  rectype-name  EXIT  THEN  THEN
    2drop rectype-null ;
: audio-rec ( addr u -- .. token )
    2dup "audio:" string-prefix? IF
	over ?flush-text
	[:  2dup + >r
	    6 /string save-mem over >r
	    2dup [: forth:type ." .aidx" ;] $tmp file-in save-mem 2>r
	    [: forth:type ." .opus" ;] $tmp file-in save-mem 2r>
	    [:  over >r $, msg:audio-idx# ulit, msg-object r> free throw
		over >r $, msg:audio# ulit, msg-object r> free throw ;]
	    r> free throw  r> to last->in ;]
	catch 0= IF  rectype-name  EXIT  THEN  THEN
    2drop rectype-null ;

$Variable msg-recognizer
depth >r
' text-rec ' audio-rec ' img-rec ' http-rec ' chain-rec ' tag-rec ' pk-rec
depth r> - msg-recognizer set-stack








|






|









|













|








|







 







|











|







2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
....
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
    last->in ?dup-0=-IF  source drop  THEN
    tuck - dup IF
	\ ." text: '" forth:type ''' forth:emit forth:cr
	$, msg-text
    ELSE  2drop  THEN ;

: text-rec ( addr u -- )
    2drop ['] noop rectype-nt ;
: tag-rec ( addr u -- )
    over c@ '#' = IF
	over ?flush-text 2dup + to last->in
	[: 1 /string
	    \ ." tag: '" forth:type ''' forth:emit forth:cr
	    $, msg-tag
	;] rectype-nt
    ELSE  2drop rectype-null  THEN ;
: pk-rec ( addr u -- )
    over c@ '@' = IF  2dup 1 /string ':' -skip nick>pk
	2dup d0= IF  2drop 2drop rectype-null
	ELSE
	    2>r over ?flush-text + to last->in  2r>
	    [:
		\ ." signal: '" 85type ''' forth:emit forth:cr
		$, msg-signal
	    ;] rectype-nt
	THEN
    ELSE  2drop rectype-null  THEN ;
: chain-rec ( addr u -- )
    over c@ '!' = IF
	2dup 1 /string dup 0= IF  2drop 2drop rectype-null  EXIT  THEN
	snumber?
	case
	    0 of  endof
	    -1 of
		msg-group-o .msg:log[] $[]#
		over abs over u< IF  over 0< IF  +  ELSE  drop  THEN
		    >r over ?flush-text + to last->in  r>
		    [: msg-group-o .msg:log[] $[]@ chain, ;]
		    rectype-nt  EXIT  THEN
	    endof
	    2drop
	endcase
    THEN  2drop  rectype-null  ;
: http-rec ( addr u -- )
    2dup "https://" string-prefix? >r
    2dup "http://" string-prefix? r> or IF
	over ?flush-text 2dup + to last->in
	[: $, msg-url ;] rectype-nt
    ELSE  2drop rectype-null  THEN ;

forward hash-in

: jpeg? ( addr u -- flag )
    dup 4 - 0 max safe/string ".jpg" str= ;

................................................................................
		    r> free throw  THEN
	    ELSE  #0.  THEN
	    2swap file-in
	    2swap dup IF   >have+group  THEN
	    [:  dup IF  $, msg:thumbnail# ulit, msg-object  ELSE  2drop  THEN
		$, msg:image# ulit, msg-object ;]
	    r> free throw  r> to last->in ;]
	catch 0= IF  rectype-nt  EXIT  THEN  THEN
    2drop rectype-null ;
: audio-rec ( addr u -- .. token )
    2dup "audio:" string-prefix? IF
	over ?flush-text
	[:  2dup + >r
	    6 /string save-mem over >r
	    2dup [: forth:type ." .aidx" ;] $tmp file-in save-mem 2>r
	    [: forth:type ." .opus" ;] $tmp file-in save-mem 2r>
	    [:  over >r $, msg:audio-idx# ulit, msg-object r> free throw
		over >r $, msg:audio# ulit, msg-object r> free throw ;]
	    r> free throw  r> to last->in ;]
	catch 0= IF  rectype-nt  EXIT  THEN  THEN
    2drop rectype-null ;

$Variable msg-recognizer
depth >r
' text-rec ' audio-rec ' img-rec ' http-rec ' chain-rec ' tag-rec ' pk-rec
depth r> - msg-recognizer set-stack

Changes to n2o.fs.

68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
    0 old-recs  !@ recs-backlog  >stack
    0 old-order !@ order-backlog >stack
    get-recognizers old-recs  set-stack
    also get-current context !
    get-order       old-order set-stack  previous ;
: set-net2o-cmds ( -- )
    ['] n2o >body 1 set-order
    ['] rec-word 1 set-recognizers ;
: reset-net2o-cmds ( -- )
    old-recs  get-stack ?dup-IF  set-recognizers                 THEN
    old-order get-stack ?dup-IF  set-order definitions previous  THEN
    old-recs $free  old-order $free
    recs-backlog  stack# IF  recs-backlog  stack> old-recs  !  THEN
    order-backlog stack# IF  order-backlog stack> old-order !  THEN ;








|







68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
    0 old-recs  !@ recs-backlog  >stack
    0 old-order !@ order-backlog >stack
    get-recognizers old-recs  set-stack
    also get-current context !
    get-order       old-order set-stack  previous ;
: set-net2o-cmds ( -- )
    ['] n2o >body 1 set-order
    ['] rec-nt 1 set-recognizers ;
: reset-net2o-cmds ( -- )
    old-recs  get-stack ?dup-IF  set-recognizers                 THEN
    old-order get-stack ?dup-IF  set-order definitions previous  THEN
    old-recs $free  old-order $free
    recs-backlog  stack# IF  recs-backlog  stack> old-recs  !  THEN
    order-backlog stack# IF  order-backlog stack> old-order !  THEN ;

Changes to tools.fs.

369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
    hash-sanitize? IF  fn-sanitize  THEN ;

\ utf8 sanitizer

: utf8-sanitize ( addr u -- )
    bounds ?DO
	I ['] xc@+ catch IF
	    '�' xemit
	    drop  I I' over -
	    ['] x-size catch IF  2drop  1  THEN
	ELSE  xemit I -  THEN
    +LOOP  nothrow ;

\ config stuff








|







369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
    hash-sanitize? IF  fn-sanitize  THEN ;

\ utf8 sanitizer

: utf8-sanitize ( addr u -- )
    bounds ?DO
	I ['] xc@+ catch IF
	    [ xc-vector @ fixed-width = ] [IF] '?' [ELSE] '�' [THEN] xemit
	    drop  I I' over -
	    ['] x-size catch IF  2drop  1  THEN
	ELSE  xemit I -  THEN
    +LOOP  nothrow ;

\ config stuff