usr/src/lib/efcode/fcode_test/misc.fth

   1 \ #ident        "%Z%%M% %I%     %E% SMI"
   2 \ purpose:
   3 \ copyright: Copyright 2005 Sun Microsystems, Inc.  All rights reserved.
   4 \ copyright: Use is subject to license terms.
   5 \ copyright:
   6 \ copyright: CDDL HEADER START
   7 \ copyright:
   8 \ copyright: The contents of this file are subject to the terms of the
   9 \ copyright: Common Development and Distribution License, Version 1.0 only
  10 \ copyright: (the "License").  You may not use this file except in compliance
  11 \ copyright: with the License.
  12 \ copyright:
  13 \ copyright: You can obtain a copy of the license at usr/src/OPENSOLARIS.LICENSE
  14 \ copyright: or http://www.opensolaris.org/os/licensing.
  15 \ copyright: See the License for the specific language governing permissions
  16 \ copyright: and limitations under the License.
  17 \ copyright:
  18 \ copyright: When distributing Covered Code, include this CDDL HEADER in each
  19 \ copyright: file and include the License file at usr/src/OPENSOLARIS.LICENSE.
  20 \ copyright: If applicable, add the following below this CDDL HEADER, with the
  21 \ copyright: fields enclosed by brackets "[]" replaced with your own identifying
  22 \ copyright: information: Portions Copyright [yyyy] [name of copyright owner]
  23 \ copyright:
  24 \ copyright: CDDL HEADER END
  25 \ copyright:
  26
  27 ." Buffer: "
  28  h# 20 buffer: my-unit-str
  29  " abcd" my-unit-str pack drop
  30  " pack.1" my-unit-str     c@ 4       = .passed?
  31  " pack.2" my-unit-str 1 + c@ ascii a = .passed?
  32  " pack.3" my-unit-str 2 + c@ ascii b = .passed?
  33  " pack.4" my-unit-str 3 + c@ ascii c = .passed?
  34  " pack.5" my-unit-str 4 + c@ ascii d = .passed?
  35  " count.1" my-unit-str count " abcd" $= .passed?
  36 cr
  37
  38 ." Formatting: "
  39  " fmt.1" 1 h# 23 <# #s #>        " 2300000001" $= .passed?
  40  " fmt.2" 1 h# 23 <# # # #>               " 01" $= .passed?
  41  " fmt.3" h# 123  <# u#s u#>             " 123" $= .passed?
  42  " fmt.4" h# 123  <# u# ascii X hold u# u#> " 2X3" $= .passed?
  43  d# 10 base !
  44  " fmt.5" d# -123 <# dup abs u#s swap sign u#> " -123" $= .passed?
  45  " fmt.6" d# 123  <# dup abs u#s swap sign u#>  " 123" $= .passed?
  46  " fmt.7" " -123" $number invert swap d# -123 = and .passed?
  47  d# 16 base !
  48  " fmt.8" " 32a" $number invert swap h# 32a = and .passed?
  49  " fmt.9" " xyzzy" $number                        .passed?
  50  : dnumber   ( n -- str len )
  51     base @ >r d# 10 base !
  52     <# dup abs u#s swap sign u#>
  53     r> base !
  54  ;
  55  " fmt.10" d# 12345678 dnumber " 12345678"     $= .passed?
  56  " fmt.11" d# -87654321 dnumber " -87654321"   $= .passed?
  57  " fmt.12" #out @ space #out @ 1 - = .passed?
  58  " fmt.13" #line @ cr #out @ #line @ rot 1 + = swap 0= and .passed?
  59  " fmt.14" #line @ (cr #out @ #line @ rot = swap 0= and .passed?
  60  " fmt.15" bs h# 8                              = .passed?
  61  " fmt.16" bell h# 7                            = .passed?
  62  " fmt.17" bl h# 20                             = .passed?
  63  " fmt.18" ascii 5 d# 10 digit swap 5 = and       .passed?
  64  " fmt.19" ascii x d# 16 digit invert swap ascii x = and .passed?
  65 cr
  66
  67 ." (is-user-word): "
  68  : xyzzy 1 2 3 ;
  69  " xx" ' xyzzy (is-user-word)
  70  " xx" $find if .passed space execute else .failed then
  71  " iuw.1"  2 pick 3               = .passed?
  72  " iuw.2"  3 pick 2               = .passed?
  73  " iuw.3"  4 pick 1               = .passed?
  74  drop drop drop
  75 cr
  76
  77 ." Move/Fill/Upper/Lower:"
  78  " xyzzy" my-unit-str swap move
  79  " move.1" my-unit-str " xyzzy" comp          0= .passed?
  80  my-unit-str 9 ascii A fill
  81  my-unit-str 6 ascii X fill
  82  " fill.1" my-unit-str " XXXXXXAAA" comp      0= .passed?
  83  9 0 do my-unit-str i + dup c@ lcc swap c! loop
  84  " lcc.1"  my-unit-str " xxxxxxaaa" comp      0= .passed?
  85  9 0 do my-unit-str i + dup c@ upc swap c! loop
  86  " upc.1"  my-unit-str " XXXXXXAAA" comp      0= .passed?
  87 cr
  88
  89 ." >body/body>: "
  90 external
  91  : xx 1 2 3 ;
  92 headers
  93  " >body" ' xx >body ' xx /n + = .passed?
  94  " body>" ' xx dup >body body> = .passed?
  95 cr
  96
  97 ." Fcode-revision: "
  98  " Fcode-revision" fcode-revision h# 30000 = .passed?
  99 cr
 100
 101 ." Defer/Behavior: "
 102  defer defer-word
 103  ' xx to defer-word
 104  " defer.1" defer-word 3 = swap 2 = and swap 1 = and .passed?
 105  " behavior.1" ' defer-word behavior ' xx = .passed?
 106 cr
 107
 108 ." Aligned: "
 109  variable alvar
 110  " align.1" alvar aligned alvar = .passed?
 111  " align.2" alvar /c - aligned alvar = .passed?
 112  " align.3" alvar char+ aligned alvar la1+ = .passed?
 113 cr
 114
 115 ." Field: "
 116 struct
 117  /n field >x1
 118  /l field >x2
 119  /w field >x3
 120  /c field >x4
 121 constant /field-test
 122  " field.1" /field-test /n /l /w /c + + + = .passed?
 123  " field.2" 0 >x1 0 = .passed?
 124  " field.3" 0 >x2 /n = .passed?
 125  " field.4" 0 >x3 /n /l + = .passed?
 126  " field.5" 0 >x4 /n /l /w + + = .passed?
 127 cr
 128
 129
 130 ." Properties: "
 131  0 value root-phandle
 132  " use-fake-handles" $find if execute else 2drop then
 133  " /" " (cd)" $find if execute else 2drop then
 134  " /" find-package if to root-phandle then
 135  1 encode-int " int-prop" property
 136  1 2 encode-phys " phys-prop" property
 137  1 2 3 reg
 138  " XYZZY" model
 139  1 encode-int 2 encode-int encode+ " 2int-prop" property
 140  " abcd" encode-string " string-prop" property
 141  " wxyz" encode-bytes " bytes-prop" property
 142  " prop.1" " bytes-prop" root-phandle get-package-property if
 143     .failed
 144  else
 145     " wxyz" $= .passed?
 146  then
 147  " prop.2" " string-prop" root-phandle get-package-property if
 148     .failed
 149  else
 150    decode-string " abcd" $= nip nip .passed?
 151  then
 152  " prop.3" " int-prop" root-phandle get-package-property if
 153     .failed
 154  else
 155    decode-int 1 = nip nip .passed?
 156  then
 157  " prop.4" " phys-prop" root-phandle get-package-property if
 158     .failed
 159  else
 160    decode-phys 2 = swap 1 = and nip nip .passed?
 161  then
 162  " prop.5" 0 0 root-phandle next-property if
 163     " bytes-prop" $= .passed?
 164  else
 165     .failed
 166  then
 167  " prop.6" " string-prop" root-phandle next-property if
 168     " 2int-prop" $= .passed?
 169  else
 170     .failed
 171  then
 172 cr
 173  " .properties" $find if execute else 2drop then
 174 cr
 175
 176 ." Timing/Alarm: "
 177  " ms.1" get-msecs h# 100 ms get-msecs swap - h# 80 h# 150 between .passed?
 178 \ 0 value alarm-happened
 179 \ : alarm-word 1 to alarm-happened ." OK " ;
 180 \ ' alarm-word 10 alarm
 181 \ 0
 182 \ begin
 183 \    1 + dup 1000000 > alarm-happened 0<> or
 184 \ until
 185 \ drop
 186 \ 0 0 alarm
 187 \ " alarm.1" alarm-happened .passed?
 188 cr