misc.fth revision 7c478bd95313f5f23a4c958a745db2134aa03244
\ #ident "%Z%%M% %I% %E% SMI"
\ purpose:
\ copyright: Copyright 2005 Sun Microsystems, Inc. All rights reserved.
\ copyright: Use is subject to license terms.
\ copyright:
\ copyright: CDDL HEADER START
\ copyright:
\ copyright: The contents of this file are subject to the terms of the
\ copyright: Common Development and Distribution License, Version 1.0 only
\ copyright: (the "License"). You may not use this file except in compliance
\ copyright: with the License.
\ copyright:
\ copyright: You can obtain a copy of the license at usr/src/OPENSOLARIS.LICENSE
\ copyright: or http://www.opensolaris.org/os/licensing.
\ copyright: See the License for the specific language governing permissions
\ copyright: and limitations under the License.
\ copyright:
\ copyright: When distributing Covered Code, include this CDDL HEADER in each
\ copyright: file and include the License file at usr/src/OPENSOLARIS.LICENSE.
\ copyright: If applicable, add the following below this CDDL HEADER, with the
\ copyright: fields enclosed by brackets "[]" replaced with your own identifying
\ copyright: information: Portions Copyright [yyyy] [name of copyright owner]
\ copyright:
\ copyright: CDDL HEADER END
\ copyright:
." Buffer: "
h# 20 buffer: my-unit-str
" abcd" my-unit-str pack drop
" pack.1" my-unit-str c@ 4 = .passed?
" pack.2" my-unit-str 1 + c@ ascii a = .passed?
" pack.3" my-unit-str 2 + c@ ascii b = .passed?
" pack.4" my-unit-str 3 + c@ ascii c = .passed?
" pack.5" my-unit-str 4 + c@ ascii d = .passed?
" count.1" my-unit-str count " abcd" $= .passed?
cr
." Formatting: "
" fmt.1" 1 h# 23 <# #s #> " 2300000001" $= .passed?
" fmt.2" 1 h# 23 <# # # #> " 01" $= .passed?
" fmt.3" h# 123 <# u#s u#> " 123" $= .passed?
" fmt.4" h# 123 <# u# ascii X hold u# u#> " 2X3" $= .passed?
d# 10 base !
" fmt.5" d# -123 <# dup abs u#s swap sign u#> " -123" $= .passed?
" fmt.6" d# 123 <# dup abs u#s swap sign u#> " 123" $= .passed?
" fmt.7" " -123" $number invert swap d# -123 = and .passed?
d# 16 base !
" fmt.8" " 32a" $number invert swap h# 32a = and .passed?
" fmt.9" " xyzzy" $number .passed?
: dnumber ( n -- str len )
base @ >r d# 10 base !
<# dup abs u#s swap sign u#>
r> base !
;
" fmt.10" d# 12345678 dnumber " 12345678" $= .passed?
" fmt.11" d# -87654321 dnumber " -87654321" $= .passed?
" fmt.12" #out @ space #out @ 1 - = .passed?
" fmt.13" #line @ cr #out @ #line @ rot 1 + = swap 0= and .passed?
" fmt.14" #line @ (cr #out @ #line @ rot = swap 0= and .passed?
" fmt.15" bs h# 8 = .passed?
" fmt.16" bell h# 7 = .passed?
" fmt.17" bl h# 20 = .passed?
" fmt.18" ascii 5 d# 10 digit swap 5 = and .passed?
" fmt.19" ascii x d# 16 digit invert swap ascii x = and .passed?
cr
." (is-user-word): "
: xyzzy 1 2 3 ;
" xx" ' xyzzy (is-user-word)
" xx" $find if .passed space execute else .failed then
" iuw.1" 2 pick 3 = .passed?
" iuw.2" 3 pick 2 = .passed?
" iuw.3" 4 pick 1 = .passed?
drop drop drop
cr
" xyzzy" my-unit-str swap move
" move.1" my-unit-str " xyzzy" comp 0= .passed?
my-unit-str 9 ascii A fill
my-unit-str 6 ascii X fill
" fill.1" my-unit-str " XXXXXXAAA" comp 0= .passed?
9 0 do my-unit-str i + dup c@ lcc swap c! loop
" lcc.1" my-unit-str " xxxxxxaaa" comp 0= .passed?
9 0 do my-unit-str i + dup c@ upc swap c! loop
" upc.1" my-unit-str " XXXXXXAAA" comp 0= .passed?
cr
." >body/body>: "
external
: xx 1 2 3 ;
headers
" >body" ' xx >body ' xx /n + = .passed?
" body>" ' xx dup >body body> = .passed?
cr
." Fcode-revision: "
" Fcode-revision" fcode-revision h# 30000 = .passed?
cr
." Defer/Behavior: "
defer defer-word
' xx to defer-word
" defer.1" defer-word 3 = swap 2 = and swap 1 = and .passed?
" behavior.1" ' defer-word behavior ' xx = .passed?
cr
." Aligned: "
variable alvar
" align.1" alvar aligned alvar = .passed?
" align.2" alvar /c - aligned alvar = .passed?
" align.3" alvar char+ aligned alvar la1+ = .passed?
cr
." Field: "
struct
/n field >x1
/l field >x2
/w field >x3
/c field >x4
constant /field-test
" field.1" /field-test /n /l /w /c + + + = .passed?
" field.2" 0 >x1 0 = .passed?
" field.3" 0 >x2 /n = .passed?
" field.4" 0 >x3 /n /l + = .passed?
" field.5" 0 >x4 /n /l /w + + = .passed?
cr
." Properties: "
0 value root-phandle
" use-fake-handles" $find if execute else 2drop then
" /" " (cd)" $find if execute else 2drop then
" /" find-package if to root-phandle then
1 encode-int " int-prop" property
1 2 encode-phys " phys-prop" property
1 2 3 reg
" XYZZY" model
1 encode-int 2 encode-int encode+ " 2int-prop" property
" abcd" encode-string " string-prop" property
" wxyz" encode-bytes " bytes-prop" property
" prop.1" " bytes-prop" root-phandle get-package-property if
.failed
else
" wxyz" $= .passed?
then
" prop.2" " string-prop" root-phandle get-package-property if
.failed
else
decode-string " abcd" $= nip nip .passed?
then
" prop.3" " int-prop" root-phandle get-package-property if
.failed
else
decode-int 1 = nip nip .passed?
then
" prop.4" " phys-prop" root-phandle get-package-property if
.failed
else
decode-phys 2 = swap 1 = and nip nip .passed?
then
" prop.5" 0 0 root-phandle next-property if
" bytes-prop" $= .passed?
else
.failed
then
" prop.6" " string-prop" root-phandle next-property if
" 2int-prop" $= .passed?
else
.failed
then
cr
" .properties" $find if execute else 2drop then
cr
." Timing/Alarm: "
" ms.1" get-msecs h# 100 ms get-msecs swap - h# 80 h# 150 between .passed?
\ 0 value alarm-happened
\ : alarm-word 1 to alarm-happened ." OK " ;
\ ' alarm-word 10 alarm
\ 0
\ begin
\ 1 + dup 1000000 > alarm-happened 0<> or
\ until
\ drop
\ 0 0 alarm
\ " alarm.1" alarm-happened .passed?
cr