![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to slof.bin CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Qemu by Fabrice Bellard] / qemu / pc-bios|
Return to slof.bin CVS log | Up to [Qemu by Fabrice Bellard] / qemu / pc-bios |
1.1 root 1: � � (header magic123 � HEAD qemu0 #U 1 1J]��������� È �X & (stage1 H ? ޭ�� @< |C�| �|C�|�|C�� `| �8 N� B |C�| �|C�|�|C�� �| �8 �N� B |C�| �|C�|�|C�� `| �8 N� B |C�| �|C�|�|C�� �| �8 �N� B |C�| �|C�|�|C�� `| �8 N� B |C�| �|C�|�|C�� �| �8 �N� B |C�| �|C�|�|C�� `| �8 N� B |C�| �|C�|�|C�� `| �8 N� B |C�| �|C�|�|C�� `| �8 N� B |C�| �|C�|�|C�� `| �8 N� B |C�| �|C�|�|C�� `| �8 N� B |C�| �|C�|�|C��
2: `| �8
3: N� B |C�| �|C�|�|C�� `| �8 N� B |C�| �|C�|�|C�� `| �8 N� B |C�| �|C�|�|C��
`| �8
N� B |C�| �|C�|�|C�� `| �8 N� B |C�| �|C�|�|C�� `| �8 N� B |C�| �|C�|�|C�� `| �8 N� B |C�| �|C�|�|C�� `| �8 N� B |C�| �|C�|�|C�� `| �8 N� B |C�| �|C�|�|C�� `| �8 N� B |C�| �|C�|�|C�� `| �8 N� B |C�| �|C�|�|C�� `| �8 N� B |C�| �|C�|�|C�� `| �8 N� B |C�| �|C�|�|C�� `| �8 N� B |C�| �|C�|�|C�� `| �8 N� B |C�| �|C�|�|C�� `| �8 N� B |C�| �|C�|�|C�� `| �8 N� B |C�| �|C�|�|C�� `| �8 N� B |C�| �|C�|�|C�� `| �8 N� B |C�| �|C�|�|C�� `| �8 N� B |C�| �|C�|�|C�� `| �8 N� B |C�| �|C�|�|C�� `| �8 N� B |C�| �|C�|�|C�� `| �8 N� B |C�| �|C�|�|C�� !`| �8 ! N� B |C�| �|C�|�|C�� "`| �8 " N� B |C�| �|C�|�|C�� #`| �8 # N� B |C�| �|C�|�|C�� $`| �8 $ N� B |C�| �|C�|�|C�� %`| �8 % N� B |C�| �|C�|�|C�� &`| �8 & N� B |C�| �|C�|�|C�� '`| �8 ' N� B |C�| �|C�|�|C�� (`| �8 ( N� B |C�| �|C�|�|C�� )`| �8 ) N� B |C�| �|C�|�|C�� *`| �8 * N� B |C�| �|C�|�|C�� +`| �8 + N� B |C�| �|C�|�|C�� ,`| �8 , N� B |C�| �|C�|�|C�� -`| �8 - N� B |C�| �|C�|�|C�� .`| �8 . N� B |C�| �|C�|�|C�� /`| �8 / N� B |x}` �9�� y���}kcx}`&dL &,8`
4: H &8`
H �8`
5: H �8` SH �8` LH �8` OH �8` FH �H �[0m[?25l **********************************************************************
6: [1mQEMU Starting
7: [0m Build Date = Mar 23 2011 15:55:48
8: FW Version = dgibson@(private build)
9: |h�H �8`I|i�N�!xf��8` X8� 8� &D "N� dgibson@(private build) �b��# �A @�a H� P� X�� `�� h�& p�! x�A ��a �� �� ��� ��� ��& ��! ��A ��a �� �� ��� ��� ��& ��! ��A& �a&�&�&��& ��&(��&8}����&@}����&H}�� � /�| ��& 0�! 8N� |)�< �!���A @�a H�� P�� X�� `�� h�& p�! x�A ��a ��� ��� ��� ��� ��& ��! ��A ��a ��� ��� ��� ��� ��& ��! ��A& �a&��&��&��& ��&(�& 0}���� 8}����&8}����&@}� &��&H}����&PH ��b��# |xH
10: 1��&8}����&@}����&H}�� ��&P}���A @�a H� P� X�� `�� h�& p�! x�A ��a �� �� ��� ��� ��& ��! ��A ��a �� �� ��� ��� ��& ��! ��A& �a&�&�&��& ��&(�! 8|B�| �|B�|�|B�L $� �� `N� [1m[41m[37m
11:
12:
E1001 - Boot ROM CRC failure
13:
[0m [1m[41m[37m
14:
15:
E1002 - Memory could not be initialized
16:
[0m [1m[41m[37m
17:
18:
E1003 - Firmware image incomplete[0m
19:
internal FLS1-FFS-0. [1m[41m[37m
20:
21:
E1004 - Unspecified Internal Firmware Error[0m
22:
internal FLSX-SE-0. |x|�#x|�+x|�3x9@ &s�
23: @� (��x|�J�|c#xH &���x;� |#� A� H �H }��|�#x8� |#8 A� H �}B�, A� 4H x�� }B�8� |'0 A� 8� � |' 8` &A� P|�#x|qB�� � 8� |' A� |��� � �� � �� � |��� (8� �� 8` ~�x}��N� }��|�+x|�+xH 9, &@� }��N� |��:��8����E &�P &B ��~%�x}��N� }(�|�#x|jx|�#x8� |�+xH E, &@� � , |�*@���8` &}(�N� 8` � �� �� |�B}(�N� 9J��9k��� �� |-p 9� &A� N� q� �@���9� N� �!��|��& 0�� 8�� @�� H|�+xK��Y�& 0|��� �� �� �� � H�� @�� 88! PN� }�|ix�i , A� H 9) &K���}�N� }�|ixy#' pc ,
24: A� 8c 8c 0H &�y#F pc ,
25: A� 8c 8c 0H &�y#e pc ,
26: A� 8c 8c 0H &�y#� pc ,
27: A� 8c 8c 0H &�y#� pc ,
28: A� 8c 8c 0H &ey#� pc ,
29: A� 8c 8c 0H &Iy#� pc ,
30: A� 8c 8c 0H &-y# "pc ,
31: A� 8c 8c 0H &y#'pc ,
32: A� 8c 8c 0H �y#Fpc ,
33: A� 8c 8c 0H �y#epc ,
34: A� 8c 8c 0H �y#�pc ,
35: A� 8c 8c 0H �y#�pc ,
36: A� 8c 8c 0H �y#�pc ,
37: A� 8c 8c 0H iy#�pc ,
38: A� 8c 8c 0H My# pc ,
39: A� 8c 8c 0H 1}�N� }�|ixK��}�|ixK��t}�|ixK���xf��8` X8� 8� &D "N� |jx8` T8� D "|�#yA� x�F �j N� <` `c xc�dc `cf�<� `� x��d� `�]T���A� 8� |���� B ��< `! x!�d! `!� 8a �|�� H 58` ��xH �< `! x!�d! `!� 8! ��a |h�N� <@ `B xB�dB `BØ8B@ 8B@ N� |fx8` &8� &<� `�DTK���|`>p�"�| �x $|�&*N� ` ` ` 8` `cޭxc��`c��N� N� 8` N� ` ` ` |���������<� @||x�& ����<`�|�#x�����!�!8� H �` �"��b� 8 ;� �� H e` �b�(<����xK���` |dy@�&T�! �뢀8<��8� ���x�� K���` /� A� ��b�@��xH ` �b�H<����xK��]` |dyA� �b�0H �` �a �;� p��xH �` �b�P肀X袀`H �` �& p�& xL &,| ��A (�& p��x<��8� 8� �a �8� | ��_ N�!�A (L &,| �8! ��& ����������|�����N� � ��� �8`& H
40: E` 9 & �a �}kJ9k U) 0Uk 0}iXPUk��}i�| Hl| �| O�| �L &,9) �B ��K���` ` �b�0H
41: �` K��� &� ` |�9 /��& �!��� /� @� |�"�p�b�h� H
42: �` |���b�x|�#xx� "H
43: �` |���b��|�#xx� "H
44: y` |�B��b��|�#xx� "H
45: a` |�B��b��|�#xx� "H
46: I` H K��` K��� &� ` |��"��b�p�& �!��x`��x $�k }) */� A� 8� �A (| ��i �I N�!�A (8! p�& |�N� ` ` 8! p�& |�K��� &� |��& �����!��|? x|`x� �� �x |xK��E` 8? ��& |�����N� &�& &|��& �����!�q|? x|ix�� �|�+x�? �� �� �� p� �/� &A� � �/� A� 8 H x8 � xH T� p| x� x /�
47: @� 8`
K��9� p| x� x �? p9) &�? p|xK��� x0 &� x�? x� �� @A���� xx |x8? ��& |�����N� &�& &|��& �����!�q|? x|`x� �K���` |`xx �����| x �� pH <� px |xK��A` K��` |`x| �/� @��� �0 ��� �� �/� @���8? ��& |�����N� &�& & |����p���x|�#x�& �&��|`x�!���A���!�&|x}CxK��y` 8!& �& ���p���x�&��|��!���A��N� &� 8� �� 8���|�*�� 8�� |�*�� <� `� x��d�ib`�m,|�(P|�*� <�CP`�U0x��d�lo`�g |�(P|�*�� 8���|�*�� 8� |�*+� A� 8� &|ex|�#x|�+xN� }�|dx8` 8� /� A� 8� |�#xH �� &�0 A� `� &/� @� `� &|�#xK��-/� A� `� |�;x}�N� }(�K���}(�/� |�#x@� |8` N� }(�8� � |�28� Q8� �� �� 8� @8� �� �� 8� &<�ib`�m,�� �� <�CP`�U1x��d�lo`�g �� |�3xH &]�f &}(�N� }�|gxH m8� Q8� �� �� 8� @8� �� �� 8� &<�ib`�m,�� �� <�CP`�U0x��d�lo`�g �� H ��g &K��1|�;x8` &}�N� <� `� x��d� &`� x���|��8� <� `� x��d� `� |�)*8� B ��N� <� `� x��d� `� �� x�&�8����0 A� 8� 8� &�� 8���|�*�f @N� 8� � |�"<� `� x��d� `� �� x�&�8����0 A� 8� 8� &�� 8���|�*�f @N� |fx�f <� `� x��d� `� |�0�8� &|�x� �@+$ @� 8� &x� |�+xA���|�3xN� |�= E�a������|�#x�& ����a)LF|x��������;����!�a� �H A� ,8! ���x�& �a��������|���������N� � ;���/� @��̠ ;���/� @���� ;���0 ��T >+� &A����� /� &A�&(/� @����� ;� ��H ,` ` ` � 8;� &���� � 6A� ��� /� &@���� �� $�~ |�"H y` � � (8� �~ |�(P|`x� H &�` �~ (/� A����> }kJ9k U) 0Uk 0}iXPUk��}i�| Hl| �| O�| �L &,9) �B �� 8;� &���� � 6@��X` ` ` 8! �� ��x� �& �a��������|���������N� �� ;� ��H � ,;� &���� � *A� ��� /� &@��܀� �� �~ |�"H &i` � �� 8� �~ |�(P|`x� H �` �~ /� A����> }kJ9k U) 0Uk 0}iXPUk��}i�| Hl| �| O�| �L &,9) �B �� ,;� &���� � *@��X` ` ` 8! �� ��x� �& �a��������|���������N� &� ,% M� 8���x� x� |ix8� &|���� 9) &B ��N� ,% M� 8���|ixx� 8� &|��` � 8� &� 9) &B ��N� �@@� \|*� @A� P/� M� 9%��8���y) |�*9) &|�*})�9 ` |H�|I�9)��B ��N� ` ` ` /� M� 8���|ixx� 8� &|��` � 8� &� 9) &B ��N� |��& �!��|`x�b���� ��� �|x�� ��� ��& ��! ��A �8� �H )` 8! p�& |�N� &� |���������|�+x|~x�& ����|�#x8�&@�!�1;� p��xH �` ��x|}x�~ {� K��` 8!&���x�& �����������|�N� &� |��"������|�#x�& ����8��|�+x��������T >|x�!�a+�
�I �) 8 �! p�A xA� X� @@� |�"��� /� A� ��c 8 -� 8 �c 9k &�c � ��8 &�= p�+ �? 9) &�? 8! �|x�& ����������|�����N� ` ` �+������x��PK��!���? 8! �8 &|x�} p�i �& �? ������|�9) &�����? ����N� ` ` �c K��T &� ` ` ` |��a������}Cx|�;x�& ����|�3x��������|~x|�+x�!�a|�#x8�
48: 8� H �` /� 9 8 &|c�A� ` ��9) &/� })�@���y | �| �� @� @| P| �/� @� 0x �> | �` ` ` �� �> 9) &�> B ��8! �8` �& �a��������|���������N� &� ` ` |����p���x9� x9� 0�& �&��: &��������:� �����&��|�#x|xx�!���A��; �a�������!���A���a�������������������!��;a&P;A p:� ��{ 1�% /� A� 8|P�� @� ,/� %A� ��# 8� &�a&�8c &�a&��% /� @���8 � �a&�8!&P|xP�& ���p|c����x�&��|��!���A���a�����������������&���!���A���a����������������N� ` K�x|�+x8 %� ;� &|�P|
49: �� /� dA��/� iA��/� uA��/� xA��/� XA��/� pA��/� cA��/� sA��/� %A� /� OA��/� o9k &@���9 o9j &}AR}k�}aZ�* p�+ p� /� %@� 9# &� �!&�8� &�a&�K���` �& q�� :& /� 0A�/� .:` ;� qA� �< /� A� P| �:� �& �;� 8 ��T >+� )@� D8 ��T >+� A� }z�;� &{� �+ �< &/� @���~&�xK��p` ` ` �b��x �| �}`Z}i�N� X�������������������������������� ���������������������������������������� &� ������������� � ��������� X�������� X &h�������� ����� ��������� ��8� 8�
50: ~��x�? H �` x ��xH -` �@@� D|c�Pxc !A� 8/� �!&�|i�A��A��` ` ` �� �!&�9) &�!&�B ��;� H (` �!&�| ��;� &{� � �!&�8 &�&&���xH �` ��@A���K��l` ` }:�~��x��x8� 8� 9 �) c�xK����!&�c�x��x8� �� �!&�8 &�&&��� &�!&�8 &�&&�K��]�< &K��}:�c�x~��x8� &8�
51: 8� �) 9 K����!&��� �a&��< &8c &�a&�K���}:��b��z� $8� ~g�x}k9 �) ~��xc�x�K Ґ8~E�xK��-c�x~D�x8� K��͍< &K��x}:��b��z� $8� ~g�x}k9 �) ~��xc�x�K Ґ8~E�xK���c�x~D�x8� K��}�< &K��(�< &:� /� h@���< &:� &K�� ` V�88 ��}:�~ 6��x�) � 9A� 4�a&��"��z� $})8 -� �I �!&��a �8 &}r�8�&&�~E�x8�
52: ~g�x9 ~��xc�xK��9c�x~D�x8�
53: K��ٍ< &K���` ` ` �< &:� /� l@��hK��`` ` ` :` 0;� rK���` 9 dK���` ` 9 iK��|` ` 9 uK��l9 xK��d9 XK��\9 pK��T9 cK��L9 sK��D9 OK��<8 &| �K�� &� |ix9` 8` � /� M� ` ` � &9k &}k�/� @���yc N� ,$ |ixA�&@+� $�$ @� H &` 9) &�$ �i /� / ,�
54: A���/�
A���A���A���/� @� �/� 0A� �8�
55: /� A� �8` ` 8 ��9K��T>UJ>+� +
56: 9) &9K��| 4@� $8 ��T >+� }@4@� M� 9k��}`4�( L� �$ |c)҉i /� |`@���N� ` /� @��|/� 08� @��p� &9I &/� x@��h9* &�$ �j &K��P` ` ` 8` N� � &9I &/� x@��(9* &�$ �j &K���8���K��� & � P & & �P P Press "s" to enter Open Firmware.
57:
58: bootinfo !!! roomfs lookup(bootinfo) = %d
59: xvect Cannot find romfs file %s
60: ofw_main %s%s [0m [?25h
61: exception %llx
62: SRR0 = %08llx%08llx SRR1 = %08llx%08llx
63: SPRG2 = %08llx%08llx SPRG3 = %08llx%08llx
64: 0123456789ABCDEF � �� ��� ���� ����� ������ ��������������� AT &C� I� &C� J &C� J0 &C� J@ &C� J` &C� L@ &C� L� &C� Ml &C� M� &C� N� &C� OP &C� R� &C� U� &C� V &C� V` &C� W &C� Wp &C� W� &C� Y@ &C� Z@ &C� `� &C� a &C� &C� �� �� �� b� c c c@ cH ch cx c� c� c� Ð c� c� c� c� ě��S�� b� d �� \��������� ?0 ? (xvect �`/�|i�8 & N� |C�| �|C�|�|C�� /�| �8 N� |C�| �|C�|�|C�� /�| �8 �N� |C�| �|C�|�|C�� /�| �8 N� |C�| �|C�|�|C�� /�| �8 �N� |C�| �|C�|�|C�� /�| �8 N� |C�| �|C�|�|C�� /�| �8 �N� |C�| �|C�|�|C�� /�| �8 N� |C�| �|C�|�|C�� /�| �8 N� |C�| �|C�|�|C�� /�| �8 N� |C�| �|C�|�|C�� /�| �8 N� |C�| �|C�|�|C�� /�| �8 N� |C�| �|C�|�|C�� /�| �8
65: N� |C�| �|C�|�|C�� /�| �8 N� |C�| �|C�|�|C�� /�| �8 N� |C�| �|C�|�|C�� /�| �8
N� |C�| �|C�|�|C�� /�| �8 N� |C�| �|C�|�|C�� /�| �8 N� |C�| �|C�|�|C�� /�| �8 N� |C�| �|C�|�|C�� /�| �8 N� |C�| �|C�|�|C�� /�| �8 N� |C�| �|C�|�|C�� /�| �8 N� |C�| �|C�|�|C�� /�| �8 N� |C�| �|C�|�|C�� /�| �8 N� |C�| �|C�|�|C�� /�| �8 N� |C�| �|C�|�|C�� /�| �8 N� |C�| �|C�|�|C�� /�| �8 N� |C�| �|C�|�|C�� /�| �8 N� |C�| �|C�|�|C�� /�| �8 N� |C�| �|C�|�|C�� /�| �8 N� |C�| �|C�|�|C�� /�| �8 N� |C�| �|C�|�|C�� /�| �8 N� |C�| �|C�|�|C�� /�| �8 N� |C�| �|C�|�|C�� /�| �8 N� |C�| �|C�|�|C�� /�| �8 N� |C�| �|C�|�|C�� /�| �8 ! N� |C�| �|C�|�|C�� /�| �8 " N� |C�| �|C�|�|C�� /�| �8 # N� |C�| �|C�|�|C�� /�| �8 $ N� |C�| �|C�|�|C�� /�| �8 % N� |C�| �|C�|�|C�� /�| �8 & N� |C�| �|C�|�|C�� /�| �8 ' N� |C�| �|C�|�|C�� /�| �8 ( N� |C�| �|C�|�|C�� /�| �8 ) N� |C�| �|C�|�|C�� /�| �8 * N� |C�| �|C�|�|C�� /�| �8 + N� |C�| �|C�|�|C�� /�| �8 , N� |C�| �|C�|�|C�� /�| �8 - N� |C�| �|C�|�|C�� /�| �8 . N� |C�| �|C�|�|C�� /�| �8 / N� 6�������� d� dh 0ofw_main ELF& & & @ a� @ 8 & @
66: & a� �49 & ?��c� � ?��c� �� ?�c�� �� | �|�<``c �c �`/�H & � |1C�B� |(��!���A �a �� �� (�� 0�� 8�& @�! H�A P�a X�� `�� h�� p�� x�& ��! ��A ��a ��� ��� ��� ��� ��& ��! ��A ��a ��� ��� ��� ��� �8` |x|B��& |B��& , @� |��< �|�| &�&& |&��&&|B��&&|B��&&|��&& |��&&(|��&&0|��&&8B�
�.�|H��" |!8 �&���!�&<@�b|��Bb L $|�B� ��}�|�� } B� �( |&x� �H |x� �h |x� �� |x� (�� (|x� 0�� 0|x� 8�� 8|x� h�� h|
x� p�� p|x� x�� x|x� �� �|x� ��( �|x� ��H �|x� ��h �|x� ��� �|x� ��� �|x� ��� �|x� ��� �|x� �� �|x� ��( �|x� ��H �|x� ��h �|x� ��� �| x� ��� �| x� ��� �| x� ��� �| x�& } &|� �(& �&(} �| &d| �L &,�(&(N� |��K��u|��8` N� |��|i�K��]N�!K��U|��8`��N� ` ` |������& |�3x��| �N�!�������& |�N� & & ` |��"� ����|wx�& ���p���x�&���!���A���a���������������&���!���A���a�������������������!��� /� @� <�B���(}+Kx9
67: 8�
68: 0� ���B� ��� �* 8 &� �iz���A� �B��j 8 �
69: �� z��A� �B��j 8 �
70: �� z���@� \z���@�"�ꂀ;�&�� :�&�:� p:& t:� u;& v;` : &;����� ;A�;�&w:@ ;! x>` &` }��N� z���8` A� �"��i 8 ���k � 8!P�& ���p���x�&��|��!���A���a�����������������&���!���A���a����������������N� �b��� ��0�+ �� 9I �K � }��N� �b��� ��8�+ �� 9I �K � }��N� �b��� ��@�+ �� 9I �K � }��N� �b��� ��H�+ �� 9I �K � }��N� �b��� ��P�+ �� 9I �K � }��N� �b��� ��X�+ �� 9I �K � }��N� �b��B�`�� �+ �
71: �� 9I �K � }��N� �b��B�`�� �+ �
72: �� 9I �K � }��N� �b��B�h�� �+ �
73: �� 9I �K � }��N� �b��B�p�� �+ �
74: �� 9I �K � }��N� �b��B�x�� �+ �
75: �� 9I �K � }��N� �b� �+ 8 � �� ;� �� �� }��N� �B� �b�8 �* 9 �
76: �� �+ �� 9I �K � �� �� }��N� �� �� }��N� �� �� }��N� �b�� �+ 9I �K � �� �� }��N� �b�� �+ 9I �K � �� �� }��N� �"�� �) �i | � �� �� }��N� �b�;� �+ 8 � �� �� �� }��N� �b�;� �+ 8 � �� �� �� }��N� � 9> });� �� �� }��N� ��� 9> �o �K /� @� })9k��;� �o �� �� }��N� �b� �+ 8 � �� ~��x�� �� }��N� �B�� 9> ;� �j 9 �
77: � �� �� }��N� �B�� 9> ;� �j 9 �
78: � �� �� }��N� �b��� �+ �� 9I � �K � }��N� �b��� �+ �� 9I � ���K � }��N� �"��� �) �� � | �x $| *� }��N� �"��� � �� 0 ��� }��N� �"��� �) �� �i��� � ���i }��N� �"��B� �� � �j �� 8��8� � �� � � }��N� �"� �B��� � �j �� 8��8� � �� � � }��N� �"� �b��� � �+ �� 9I � �K � }��N� �b��� �B���+ �� 8 }J P� }J t�I }��N� �"��� �b���I �� �
79: 0 ��x $| � }��N� �"� �b������ �I �+ �� | PP9I | t0 &�K � }��N� �"��� �B� ����i �� 8���� �� 0 ��x $|�
80: }��N� �"��b� �� �) �k �� � x $| �| *� }��N� �"��� �i �� �K��� |
81: � ��� 0 ��� }��N� �"��� �i �� �K��� | PP� ��� 0 ��� }��N� �"��� �i �� �K��� |
82: &�� ��� 0 ��� }��N� �"��� �i �� �K��� }@ 6� ��� 0 ��� }��N� �"��� �i �� �K��� }@6� ��� 0 ��� }��N� �"��� �i �� �K��� }@4� ��� 0 ��� }��N� �"��� �i �� �K��� }@ 8� ��� 0 ��� }��N� �"��� �i �� �K��� }@x� ��� 0 ��� }��N� �"��� �i �� �K��� }@x� ��� 0 ��� }��N� �"��� �) �� �i � � }��N� �b��� �+ �� 9 ���I � ��� �
83: }��N� �"��� �) �� �i � � }��N� �b��� �+ �� 9 ���I � ��� �
84: }��N� �"��� �) �� �i � � }��N� �b��� �+ �� 9 ���I � ��� �
85: }��N� �"��� �) �� �i � � }��N� �b��� �+ �� 9 ���I � ��� �
86: }��N� �"��� �) �� �i � � }��N� �b��� �+ �� 9 ���I � ��� �
87: }��N� �"��� �) �� �i � � � &� &�& p� }��N� �B��� �j �� }i[x�k � ���& p9)��x ��* � � &� &}��N� �"��� �i �� �+ 9I &� � � &� �
88: &� �
89: � &�& t� }��N� �B��� �* �� }+Kx�) � ���& t9k��T F>�j � 9i &� � &� � &� &� }��N� �"��� �i �� �K��� � | &T ��| �| �� ��� 0 ��� }��N� �"��� �i �� �K��� | P| &� ��� 0 ��� }��N� �"��� �) �� � | �v� }��N� �"��� �i �� �K��� }@x0 ��| &� ��� 0 ��� }��N� �"��� �) �� � 0 ��| &� }��N� ���B� �� �h �� �� 9' � ��� 8� 8 ���� �k �i � }��N� �b�9> �K 8���8����
90: ���
91: �� �@ �~ A���B� �j 8� � �� � �� ;� �� }��N� �"� � ;� �i �K 9J &�K �i � �K���P A� ���� ;� �� }��N� ���"� �� ;� �H �i 8���� �J �� /� � }HR�K A� P�I }KSx�J � ��}@PP9��| @P�P@@��9k���i �� ;� �� }��N� �b� � 9> });� � 0 ��� �� �� }��N� �"�� ;� �i 9K���k �I /� A� �"� �� 0 ��� �� ;� �� }��N� �b� �+ 8 ���) � ;� �� �� }��N� ���� �h �� 9K��8����+ �H 8���k���� �J��� }@[x| Kxx `/� A� �/� A� d/� @���P@A� 0|�J|�J�8@9 A� H |@*9)��|A*/� 9��@���K���B��* 9i��8���� �j 8���y E�| Cxx��|�x�)���� �k���� }*[xyJ`/� A��/� A��/� A�l/� }+J}+HP})�@� � 9k &B ���� �� }��N� ���O 9j��9 ���
92: �o 9(��/� �J��� �k���/ @� T�� � �@@A�A��4���} �@� ,H �` ` ` �� &|�B|�P��8@A��A��4 ��@���8 � �i �� �� }��N� ���h 9K��8����+ �H 8����k���� }`Kx�J���� | Sxx `/� A��/� A��/� @���P@A�H|�J|�J�8@9 A� H 0|@*9)��|A*/� 9��@����� �� }��N� �b� �+ 8 ���) � ;� �� �� }��N� �"��i 8 ���� � �� }��N� ���� �O � 9j��9+���
93: �o 8����J���/ �A������� �@ �I��A� �i��|x}��N� ���� �o �� 9+��� �/ /� A� � ��� ��9)���/ }��N� ���� �/ �� �i H =Q` �/ 8 � �i }��N� �� �b��8� 8� `�� �� H > ` }�{x}��N� �b��� ����+ �� 9I �K � }��N� ���� �/ � 8 ���� � /� �)��A�����8 ` ` ` �i x ��&��!��a�H >
` ���&��!�4����a�| x9) &���| rx@����B���/ x h|
94: � }n[x}��N� �"��� �i �� 8 ���k � H �` }��N� �"��� �� �� 8 � H y` �o }��N� �"��� �� �� 8 � H }` �o }��N� �"��� 8` ��i �� 9���8���� �� ���� ����H �` �o��}��N� �"��� 8`& �i �� 8 ���� � H �` }��N� �"��� �� �� 8��� � �o��H )` �o��}��N� �"��� �i �� 8 ���k � |c4H %` }��N� �"��� �I �� 9j��}�{x9 ��� �i 8������� �k��� H �` }��N� �"��� �i �� 9K��8
95: ��� �I �k��� H E` }��N� �"��� �I �� 9j��}�{x9 ��� �i 8������� �k��� H ` }��N� �"��� �i �� 9K��8
96: ���� �I �k��� H %` }��N� �"��� �� �� 8���� � �o��H �` 1��|| ����}��N� �� �� H �` }��N� �"��� �� �� �o H �` �o }��N� �"��� �� �� �o H �` �o }��N� �"��� �� �� �o H ` �o }��N� �"��� �� �� �o H =` �o }��N� ���� �/ �� �����i H Q` � 0 ��� }��N� ���� �/ �� �����i H m` � 0 ��� }��N� ���� �/ �� �����i H �` � 0 ��� }��N� ���� �/ �� ����i H �` � 0 ��� }��N� ���� C�x8� �/ �� �� H $m` �z � 9+ &+� &@��/ � �/ 8 � �i �/ 8 � �i }��N� ���� ��x�/ � 9I��9j���� �O y� ����o �&�H 8�` � �8� x� |}rH 8U` 8���C�xx� ��xH #�` �z �Z �&�9+ &+� &@�D�/ |x8 � �I �/ 8 � �i �/ 8 � �i }��N� ���� 8� ��x|��8� � �� 9H��9j���� �O 8���8������o �J���� ���� H }}HP| P�� 8� &9) &|��B@�8 A����I K������� �o �� 9+��9I���k �/ 8
97: ������O ���� H $�` �/ /� 8 � @���� }��N� �� �� H *�` }��N� �� �� H E` }��N� �� �� H �` }��N� �� ����x�� �/ ���9i��8 ���� �o y� ���� H 6�` � �8� x� |}rH 6q` �/ ��x9i��8 ��� �o �i��� H ,�` |`yA�D�/ 9i �o � �/ �!�8 � H 5)` �!�����i �/ 8 � �� }��N� ���� #�x�/ �� 9I��9j��� �O x ����o �&�H 5�` �&�8� � �|yx� H 5�` �/ ��x9I��9j��� �O x ����o �&�H 5�` �&�8� � �|}x� H 5Q` �/ ��x&�x9i��8 ��� �o �i��� H -5` ,# A�
�/ 8 � �� }��N� ���� #�x�/ � 9I��9j���� �O y� ����o �&�H 5 ` � �8� x� |yrH 4�` �/ %�x9I��9j��� �O �i���o H 1�` �&�,# A� 4�/ |x8 � �� }��N� ���� �/ �� 9i��8 ��� �o �i��� H �` ,# A� ��/ 8 � �� }��N� ���� ��x�/ �� 9I��9j��� �O x ����o �&�H 4` �&�8� � �|}x� H 3�` �/ #�x9I��9j��� �O x ����o �&�H 3�` �&�8� � �|yx� H 3m` �/ %�x��x9i��8 ��� �o �i��� H -�` ,# A�
98: ��/ 8 � �� }��N� ���� �/ �� 9i��8 ��� �o �i��� H #A` ,# A�
99: \�/ 8 � �� }��N� �b��� �+ �� 8 � �i }��N� �b��� �+ �� 8 � |�� }��N� �b��� �+ �� 8 � | B�� }��N� �b��� �+ �� 8 � | ��� }��N� �b��� �+ �� 8 � | B�� }��N� �b��� �+ �� 8 � |
B�� }��N� �"��� �) �� � |���b�9)���+ }��N� �b��� �+ �� 8 � |��� }��N� �"��� �) �� � |K��b�9)���+ }��N� �b��� �+ �� 8 � |J�� }��N� �"��� �i �� � |C�9k���i }��N� �b��� �+ �� 8 � |B�� }��N� �"��� �i �� � |C�9k���i }��N� �b��� �+ �� 8 � |B�� }��N� �"��� �i �� � |C�9k���i }��N� �b��� �+ �� 8 � |B�� }��N� �"��� �i �� � |C�9k���i }��N� �b��� �+ �� 8 � |B�� }��N� �"��� �i �� � |K�9k���i }��N� �b��� �+ �� 8 � |J�� }��N� �"��� �i �� � |K�9k���i }��N� �b��� �+ �� 8 � |J�� }��N� �"��� �) �� � | �|æL &,�b�9)���+ }��N� �b��� �+ �� 8 � | �|¦� }��N� �"��� �) �� � | l| �| �| �L &,�b�9)���+ }��N� �"��� �� �� �o K�� ` �o }��N� H �"��� 8� �i �� 9���8������� �o��� K��&�o��}��N� �"��� �I �� 9j��9���8������� ����o��� K����o��}��N� �B��� �* �� 9 ��8���i �
100: �)���
101: }kJ9k U) 0Uk 0}iXPUk��}i�| Hl| �| O�| �L &,9) �B ��}��N� �"��� �i �� � |�9k���i }��N� �b��� �+ �� 8 � |�� }��N� �B� ꂀ9);� ��j 8 �
102: �+ K���b��� �+ �� 9 ���I � ��� �
103: }��N� �"��� �) �� �i � � }��N� �b��� �+ �� 9 ���I � ��� �
104: }��N� �"��� �) �� �i � � }��N� �b��� �+ �� 9 ���I � ��� �
105: }��N� �"��� �i �� � | �|��|��|��|��|��|��|��9k���i }��N� �b��� �+ �� 8 � |��� }��N� �"��� �) �� � |��|��L &,�b�9)���+ }��N� �b��� �+ �� 8 � |��� }��N� �"��� �) �� � | �|��L &,�b�9)���+ }��N� �b��� �+ �� 8 � |��� }��N� �"��� �) �� � |���b�9)���+ }��N� �b��� �+ �� 8 � |��� }��N� �"��� �) �� � | &d�b�9)���+ }��N� �b��� �+ �� 8 � | �� }��N� �"��� �) �� � |��b�9)���+ }��N� �b��� �+ �� 8 � �i }��N� �"��� �) �� �i � � }��N� �b��� �+ �� 9 ���I � ��� �
106: }��N� �"��� �) �� �i � � }��N� �b��� �+ �� 8 � �i }��N� �b��� �+ �� 8 � �i }��N� �b��� �+ �� 8 � �i }��N� |��|��C�x��xH m` � �z /� @�&��/ 8 � �� }��N� 9I��x�/���y*��| Cx9J &}h[x@� 9@ &H � 9 5J��9)��@���9I��}h[x/���y*��9J &@� 9@ &H � 9 5J��9)��@���9I��y)�B/���9) &@� H &�� 9k 5)��@���K�� })ZK���/ 8 � �i }��N� �i }��N� �:K��$�/ 8 � �i }��N� �/ |x8 � �i }��N� �/ 8 � �i }��N� �/ 8 � �i }��N� �P@A� 8}
107: J�@@@� ,}kJ9) &})�9 H |H�| I�9)��B ��K��9) &|
108: �})�B@�t}*�
109: 9J &} Y�K����P@A� x}
110: J�@@@� l}kJ9) &})�9 H |H�| I�9)��B ��K��p�/ 9I �O �i �/ 9i �o � �/ 8 � �i }��N� 9 &K���9) &})�9 B@� | �9)��}
111: �} &�K����/ ���9i �o � }��N� �/ |x8 � �� }��N� �/ �� }��N� | x���K��l����9 H `}i �9)��|jX��&��!��A��a�H '=` �a���|hx|dX��&�H '!` �&��&��!��A��@ @� @9���/� @���|x}��N� 9 H |P*9)��|Y*9 /� @���K����/ |x�i }��N� �P@A� |�J|�J�8@9 A� 49 H |P.9)��|Y.9 /� @���K��x|@.9)��|A./� 9��@���K��\�P@A� |�J|�J�8@9 A� 49 H |R.9)��|[.9 /� @���K�� |B.9)��|C./� 9��@���K�� 8 &K��L8 � �� �� �� }��N� 8 � �) �� �� }��N� 9 H |
112: @*9)��| A*9 /� @���K����P@A� |�J|�J�8@9 A� 49 H |
113: @.9)��| A.9 /� @���K�Ԩ|@.9)��|A./� 9��@���K�Ԍ�P@A� |�J|�J�8@9 A� 49 H |
114: B.9)��| C.9 /� @���K��L|B.9)��|C./� 9��@���K��0�i |
115: x� K��9k���i K��L &� ` |�/� �& �!��A� xc H !` 8! p�& |�N� &� ` |�8c����������|�+x+� &�& �����!�q@� ,8! �8` �& �����������|�N� ` ` /� @���|�#x;� H ,` ` ` ;� &H �` ;� &���� @� H� /�
116: @���8`
;� &H Y` � ��;� &H E` �� A���` ` ` 8! ���x�& �����������|�N� &� ` |��& �!��H &�` 8! p�& |�N� &� }��|�#x8� |#8 A� H �}B�, A� 4H x�� }B�8� |'0 A� 8� � |' 8` &A� P|�#x|qB�� � 8� |' A� |��� � �� � �� � |��� (8� �� 8` ~�x}��N� }��|�+x|�+xH 9, &@� }��N� |��:��8����E &�P &B ��~%�x}��N� }(�|�#x|jx|�#x8� |�+xH E, &@� � , |�*@���8` &}(�N� 8` � �� �� |�B}(�N� 9J��9k��� �� |-p 9� &A� N� q� �@���9� N� �!��|��& 0�� 8�� @�� H|�+xK��Y�& 0|��� �� �� �� � H�� @�� 88! PN� N� xf��8` X8� 8� &D "N� |jx8` T8� D "|�#yA� x�F �j N� }�|ix�i , A� K���9) &K���}�N� }�|ixy#' pc ,
117: A� 8c 8c 0K��}y#F pc ,
118: A� 8c 8c 0K��ay#e pc ,
119: A� 8c 8c 0K��Ey#� pc ,
120: A� 8c 8c 0K��)y#� pc ,
121: A� 8c 8c 0K��
y#� pc ,
122: A� 8c 8c 0K���y#� pc ,
123: A� 8c 8c 0K���y# "pc ,
124: A� 8c 8c 0K���y#'pc ,
125: A� 8c 8c 0K���y#Fpc ,
126: A� 8c 8c 0K���y#epc ,
127: A� 8c 8c 0K��ey#�pc ,
128: A� 8c 8c 0K��Iy#�pc ,
129: A� 8c 8c 0K��-y#�pc ,
130: A� 8c 8c 0K��y#�pc ,
131: A� 8c 8c 0K���y# pc ,
132: A� 8c 8c 0K���}�N� }�|ixK��}�|ixK��t}�|ixK��� |��H |��|��8��xxg�j|�8�|8 N� }h�|ix8` CK���}#KxK��18` K���8` K���8` K���8` K���8` K���}h�N� }h�|ix|�#x|�+x8`
133: K���8`
K���}�cxK���}#KxK���8` K���}CSxK���8`
134: K��y8`
K��q}h�N� 8� EK���}h�K��1}h�8� W@���N� }h�8� K��}h�8� D@��tN� }h�|�#[email protected]���8` A� 8` &}h�N� |��H |��8��Tpc |�2�� |��N� N� ` D "N� xf��8` X8� 8� &D "N� }H�H -}H�, M� = �a)2 �� |dH�8� &�� N� 8`��= �a)2 �� �� |0@L� 8` T8� D "= �a)2 �� 8` �i ( M� 8`���� �� N� � �� |dx8`&D "N� 9` }*Kx} Cx|�;x|�3x|�+x|�#x|dx8`& D "N� ` ` +���8 A� �"��| �|xN� ` ` +���M� �"��|��N� +���8 A� �"��| .|xN� ` ` +���M� �"��|�.N� +���8 A� �"��| .|xN� ` ` +���M� �"��|�.N� +���8 A� �"��| *|xN� ` ` +���M� �"��|�*N� < &� @� 8` N� ` ` ` �b��<c &� /� @���8 ��� 8c N� �"��8 =) &� N� 8� ���8` `���<� &` ` ` 8 &8� x �( A� |� �x` 8� x� |�;x}h �8 | �` ` ` +���9I &8 A� |H�}`ZyI yk B ��U`�>}`ZUk>�X L� +���M� |:./� M� T 6|`|c�� @��dN� || �� L� 9# &9` � }# Py) })�A� <= � �H A� 0` ` x` 8c &+���A� �"��}i&�|c�B ��N� 8 &| �K��� ` < &�B��9 | �9` ` ` ` y 9) &})�}j&�B ��N� ` ` ` 8c��8� /� |��|i�A� 8� |�J|��� @� Xxc 9@ 8 &|c Pxc � |i�A� @< � � A� 4` ` y 9) &+���A� �b��}K&�})�B ��8` N� 8 &| �K��� |`y8` M� | �|�J|��� @� Tx 9@ 8 &}k Pyk � }i�A� << � � A� 0` y 9) &+���A� �b��}K&�})�B ��8` &N� 8 &| �K��� N� |��!���A��|zx�& �a��8 |�+x��������T 6|�#x�����&��| ������!�Q|�3xK���|yxK���< &| P�� A�&�{8 +���@�&4;� {� +���@�&;� ;� {� H $9= &8 &}{�A� �B��}j�y= x c�xH m` + ����@A���9 &+���y 9 @� �8 | �` ` ` +���9~ &8 A� �B��|
135: �} Jy~ y) B ��+���@� �8! �;9 �� 9��: C�x�& �&���!���A��|��a����������������N� ` ` ` �"��})��K��d` �"���&p�&���.K���` ` ` �"�����;� {� +���A���K���` �b��U �>} J}+A�K��P` ` ` 8! �8 � � C�x�A���& �&���!��|��a����������������N� &� ` |��& �!��K���8� 袀�8� `���|�0P8a p|��K����a p8! �0��|`�& |�N� &� ` ` }� &|���������.$ |�+x�&���!��; |xx�A���a��|�#xc9����������?` &-% ��������;� -����& �� �!�A�‘?� :� ;� 8 &8� x �� A� |� �{� 9 8 y | �}8�} Cx` ` +���9I &8 A� | H�}`ZyI yk B ��U`�>}`ZUk>�X @� �+���;� A� �B.A� �/� A� t@� |A� �| �P9> | �y) ��x+���9I &8 A� | H�� yI 9k &B ����x~�x8� H �` /� A� 4W� 6������ @��8 9 ��H (| 8��� @���K��|9=��8 U) 6| �})�8! �� �8 �x�&���& �� ����|������!��}�& �A���a��}�& ������}�� ��������N� �
136: ` ` ` |�� ��������|}x�����& |�#x|�+x�!�a@� (8! �8` �& �����������|�N� ` 8� 8a p8� K����& x� p/���A���}>�P� A���{� {� 9d��}>�}k�})��H A� �|� P9 x� |��` y` 9k &+���A� �B��}
137: &�}k�B ��{� �8P| J| �� @� L9i &9@ � }i Pyk }i�A�&�=`� �X A�&�y 9) &+���A� �b��}K&�})�B ��;���{� +���A� �"����.K��I8! �8` &�& �����������|�N� ` |iXP< &|c�� A���袀�=� &� /� @���8 &9L �X | XPx }HSx| �}'KxA� �< � � A� �` ` x� 8� &+���|��8 A� |0�� 9 &B ��|� P9 x� |��` ` y` 9k &+���A� }&�}k�B ��{� }g�yk |cZ}k�|c�� @� <|kPxc |i�` ` y` 9k &�
138: +���}k�A� }&�9J &B ��8 � K��H8 &| �K��88 &| �K��l &� ` ` ` |��& �!��8 &+� &8 @�&px� ` ��}$y) }+�� A� h}jX�}$HP=J &9)��8
139: &y) x | �` ` y` 9k &+ ��9I &+���}k�9 A� ���} �A� �‘}I�yI B ��8 9 ` ��a)��|� P|���H @� H8 9d &` ���H | P9` x | �A� �x� 8� &+���A� �"��}i&�|��B ��8a p8� 8� K��%�a p�! |9k��8 }i�| J| �� @� Pyk 9K &}k P� yk }i�9@ A� X=`� �X A� Ly 9) &+���A� �b��}K&�})�B ��K��Q8 &8! �|x�& |�N� 8 &| �K��<8 &| �K��� &� |��a������|�#x|�+x�& ����8� 8� ��������|x|�3x�!�Q;� p��xK��1�! x�a p8 &+� &@� <9+��9@ })�}iXPyk }i�y 9) &+���A� �b��}K&�})�B ����xd�x��x��xK��A�& x� p� A� ;� ;� K��U8! ��� �� ��x�����& �a�����|��������N� &� ` |��������������& �!�q��&���&�|dx��&���&��&&��!&��A&�;� p8�&���xH
�` /� |}x@� 0��x` �~ 8� ;� &8� &K��` | �P�� A���8!&���x�& �����������|�N� &� |��A���a��9 9` �& ����< &��������| ������!�A�‘��x` y 9) &})�}&�B ��;� p;� ����<� &?�ib�& tc�m,`�����x8� Q�� p��xK����a ������x��x8� Q8�O� p�& t{{ K���! �+���A� 8 @|�.8 x +���A� 9` }.8 x +���A� 9` &}&.y) +���A� 8 @| K.8 x +���A� 9` }.8 x +���A� 9 &}?&.�b��K��袀���x8� p8��K���K��
8! ��& �A���a�����|������������N� &� ` |��a������|�#x��������x~ |x�& ������x{��!�a{���K���` �� ||x@� d;� H ` ` }>�||x@� H;� &{� {� K��` /� | �9> & � @���/� A� }>�||xA���` ` ;���8! ���x�& �a��������|���������N� &� ` ` |�,# ��������|�+x�& �A���a�����������!�aA� �낀�|~�;� ;@ ��x` ` ` {� ;� &K���` ��/� �|`y��xA� @A� <| ��9? &{� }?�;� &��K��` /� �|`y��x@���` ` \��H ` d�x|ex��xH Y` /? /� A� HA� ;� K��l` ` 8! �8` �& �A���a�����|������������N� ` � /� =A� �A� �{� /� ;{ &9 | �@� t< � � @� H d` ` ;{ &B@ � 9) &})�/� =@���8i &||8! ��& �A���a�����|������������N� 8` &||K���9` &}i�K��� &� |��A���a��|�#x�& ����|�3x��������|~x�����!�a|�+x��K�� |}x��xH �` ��P|zx��xH �` C�8`��;Z �� ;� @� $H �` |��| �;� &K���` {� ��xH e` {� 8 &��@}#KxA���8� =| �;� K��` H |���;� &��{� K��` ��xH ` {� ;� &��@|xA���8` 8! ��& �A���a�����|������������N� &� |��a������8� ��������|�+x|~������& 8�& ;� �!�a�b��;�&��xH q` ` ` {� ;� &K��` ��/� �|`y��xA� @};�A� 8� &{� ;� &��;� &��K��}` /� �|`y��x@���` H ` ��x|ex��xH M` /? /� A� A� ;� K��p` ` ` ;���8! ���x�& �a��������|���������N� &� ` ` }� &|���������|y|�3x��������|�+x|�#x�& �!���A���a�ؑ� �!�Q@� @8! �8`���& �� �!���A��|��a�����}�� �����������N� ` K��A|{yA�&���xH &` ��x8� &c�xx� H 9` /� @� <8` 8! ��& �� �!���A��|��a�����}�� �����������N� ��x��xK�����x��x|{x��xK�����P|x����xK��&` |zyA��. @� @Y�x;� |}�;� &xc ��K��` �� �y ;9 &A���H ` | �{� K��i` 8 ��/� =@���;� &����xH ` �� | �;� &K��e` ��xH �` | �P{� � 8 &}#KxA���8� | �K��1` @� H_�x��x` ` ` �� {� ;� &;� &K��&` |�P���� A�������C�xK��=` �� @��x��x` ` {� ;� &8� ��K��` �� A���8` K��H` ` 8! ���x��x��x��x�& �� �!���A��|��a�����}�� �����������K��� � |���������|y�& ����8 ��|�#x�!���A���a�������!�A@� <8! �|x�& �!���A���a��|���������������N� ` ` �� pK���� p��x|~x��xK��y;���|yx��H ` | �{� K��i` 8 ��/� @���y�P{�c�xK��` /� |zx@� �||x;� ` ` ` |�;� &xc ��K��` �� �| ;� &A���;� &_�x{� ` ` ` �� ��x;� &;� &K��&` |�P{� �� A���;{ &C�x��K��=` ��x��K�� ` 8! �8 |x�& �!���A���a��|���������������N� &� ` |ix9` 8` � /� M� ` ` � &9k &}k�/� @���yc N� ` ` ,% |ix8` M� �I /� A� p� }KSx/� A� T8���x� !A� H� @@� @|��H $` ` � /� @A� B@ @� �i &8� &/� @��܈ }`XP}c�N� � 9` K��� ,% M� 8���x� x� |ix8� &|���� 9) &B ��N� ` ,% M� 8���|ixx� 8� &|��` � 8� &� 9) &B ��N� ` ` ` 8��+� M� 8c |c�N� ` ` ` 8��+� M� 8c��|c�N� ` ` ` |�|�+x�& �!��|�#x8���|xx� `H �` 8! p�& |�N� &� ` ` ` |��"������|�#x�& ����8��|�+x��������T >|x�!�a+�
�I �) 8 �! p�A xA� X� @@� |�"�؈ /� A� ��c 8 -� 8 �c 9k &�c � ��8 &�= p�+ �? 9) &�? 8! �|x�& ����������|�����N� ` ` �+������x��PK��!���? 8! �8 &|x�} p�i �& �? ������|�9) &�����? ����N� ` ` �c K��T &� ` ` ` |��a������}Cx|�;x�& ����|�3x��������|~x|�+x�!�a|�#x8�
140: 8� H Q` /� 9 8 &|c�A� ` ��9) &/� })�@���y | �| �� @� @| P| �/� @� 0x �> | �` ` ` �� �> 9) &�> B ��8! �8` �& �a��������|���������N� &� ` ` |����p���x9� x9� 0�& �&��: &��������:� �����&��|�#x|xx�!���A��; �a�������!���A���a�������������������!��;a&P;A p:� ��{ 1�% /� A� 8|P�� @� ,/� %A� ��# 8� &�a&�8c &�a&��% /� @���8 � �a&�8!&P|xP�& ���p|c����x�&��|��!���A���a�����������������&���!���A���a����������������N� ` K�x|�+x8 %� ;� &|�P|
141: �� /� dA��/� iA��/� uA��/� xA��/� XA��/� pA��/� cA��/� sA��/� %A� /� OA��/� o9k &@���9 o9j &}AR}k�}aZ�* p�+ p� /� %@� 9# &� �!&�8� &�a&�K���` �& q�� :& /� 0A�/� .:` ;� qA� �< /� A� P| �:� �& �;� 8 ��T >+� )@� D8 ��T >+� A� }z�;� &{� �+ �< &/� @���~&�xK��p` ` ` �b��x �| �}`Z}i�N� X�������������������������������� ���������������������������������������� &� ������������� � ��������� X�������� X &h�������� ����� ��������� ��8� 8�
142: ~��x�? H =` x ��xK�� ` �@@� D|c�Pxc !A� 8/� �!&�|i�A��A��` ` ` �� �!&�9) &�!&�B ��;� H (` �!&�| ��;� &{� � �!&�8 &�&&���xK���` ��@A���K��l` ` }:�~��x��x8� 8� 9 �) c�xK����!&�c�x��x8� �� �!&�8 &�&&��� &�!&�8 &�&&�K��]�< &K��}:�c�x~��x8� &8�
143: 8� �) 9 K����!&��� �a&��< &8c &�a&�K���}:��b��z� $8� ~g�x}k9 �) ~��xc�x�K Ґ8~E�xK��-c�x~D�x8� K��͍< &K��x}:��b��z� $8� ~g�x}k9 �) ~��xc�x�K Ґ8~E�xK���c�x~D�x8� K��}�< &K��(�< &:� /� h@���< &:� &K�� ` V�88 ��}:�~ 6��x�) � 9A� 4�a&��"��z� $})8 -� �I �!&��a �8 &}r�8�&&�~E�x8�
144: ~g�x9 ~��xc�xK��9c�x~D�x8�
145: K��ٍ< &K���` ` ` �< &:� /� l@��hK��`` ` ` :` 0;� rK���` 9 dK���` ` 9 iK��|` ` 9 uK��l9 xK��d9 XK��\9 pK��T9 cK��L9 sK��D9 OK��<8 &| �K�� &� ,$ |ixA�&@+� $�$ @� H &` 9) &�$ �i /� / ,�
146: A���/�
A���A���A���/� @� �/� 0A� �8�
147: /� A� �8` ` 8 ��9K��T>UJ>+� +
148: 9) &9K��| 4@� $8 ��T >+� }@4@� M� 9k��}`4�( L� �$ |c)҉i /� |`@���N� ` /� @��|/� 08� @��p� &9I &/� x@��h9* &�$ �j &K��P` ` ` 8` N� � &9I &/� x@��(9* &�$ �j &K���8���K��� � @ � 2p � 2� � 3� � � � � � :� � :� � ; � ;@ � ;` � ;� � ;� � ;� � < � <P � <p � =@ � =� � > � >� � ?@ � ?P � A� � A� � C� � F� � Hp � Ip � J � K� � L� � Np � O� � P� � S� � Up � U� � V` � V� � V� � W � WP � W� � X� � Y� � `� � p h � � � x �& � � � � � � � � � � � � �2 ghCPU0log CPU1log gx g� �20 g� �48 \�free space Creating common NVRAM partition
149: common 0123456789ABCDEF � �� ��� ���� ����� ������ ��������������� q� FORTH-WORDLIST � q� � LASTWORD � i� m8 EVALUATE � n n� n� o jH o@ o` ox o` n� o� o� mP o� pp q i� j j0 jH j` & jx j� ( j� j� �� j� 8 jH j` 8 jx j� k k0 lp j� BP $ s� SEMICOLON 4 n� &0 D s� RDEPTH! � o� DUP
150: � s� LIT
151: � s� &= t j� 0BRANCH
152: , j� SWAP � s� DROP l t BRANCH
153: t CLIENTINTERFACE $ t@ PRINT-STATUS � u0 jH u` j� ( u� o� u� j� 8 jH n� jx j� 0 o� v v vX j� P jH j`�������� jx j� 8 v� v� v vX j� j� t` v� i� w QUIT � j j0 wp w� x x0 j` > r u0 xh j� P u0 o� mP o� jH k0 j��������x j��������H i� y INTERPRET � j y� o` z jH j� P zX v� j� z� j� y8 j��������� s i� {h SAVE-SOURCE � {� o� | o@ v� | o | ox v� | y� v� | | i� � -1 D�������� | DOTO � {� |@ jH | v� |@ o` i� o0 SOURCE-ID l o� #IB � v� &! X |X SPAN � |x IB l jP DOTICK
154: � v� CATCH � x | |� v� | s� |� o` |� {� |� o` {� j� j i� m� RESTORE-SOURCE � {� {� y� o` {� ox o` {� n� o {� o@ o` {� n� o� | i� o� THROW � |� j� ` |� v� j0 {� |� o` {� j� | }0 j� {� i� }8 NOOP � i� }� BOOT-EXCEPTION-HANDLER $ }� EMIT $ r� ((FIND)) � jH j� x | ~ ~P ~p ~� ~� j� s {� s� {� v� j��������p ~� ( i� ~� (FIND) $ 8 2DROP � j� j� i� x (REVEAL) $ j8 OVER � &-
� � EXIT � } RDEPTH � i�
155: BREAKPOINT
156: h � 0< P sP PICK @ � EPAPR-MAGIC � �� JUMP-CLIENT '� uh PRINT-EXCEPTION � jH j`�������� jx j� 8 o� � v vX v� j� s� jH j` & jx j� j� s� �P i� �` SPACE � �� r i� jh 0= � �� PRINT-STACK � � j� ( | | �8 {� {� i� pX OK-STRok u� ABORTED-STR Aborted �� COUNT � jH �8 j� �` i� v� TYPE � �x �� ( �� �` r ��������� i� |�
157: ABORT"-STR � � &@ 4 q� CR $ �( &' � z �` u` o� �@ �� j� i� zH&&[ � zX �@ i� y� TERMINAL � �x n� o� |� v� o@ o` j n� o i� �� DEPTH T �� &. � �� vX u0 i� �8 REFILL � o u` j� 8 �� �H j y� o` �� s� o n� jx j� ( s� j` e q i� zh INTERPRET-WORD � ~ �` j� ( j� �� �� |� s� ~ � j� vX j`�������� q | s {� i� �p >IN � ��
158: PARSE-WORD � �� �� �� i� �� STATE � k COMPILE-WORD � ~ �` j� P � j� �� �� |� s� �H s s� ~ � j� vX j`�������� q o� j` �H �H s i� �`&?LEAVE � �� o� � �H �@ v� � �@ o` �H i� {� R> � j� >R � �p CELLS+ � �� i� �( CELL+ � �� i� �� ACCEPT $ � #TIB � & �H CATCHER � i� EXECUTE \ �� ?DUP � jH j� jH i� x DEPTH! � �� STRING, � � s` �� �� � � i� �@ DUMBER � �P v� �p j` & �P �� i� �� LINEFEED D
159: �� 2DUP � s` s` i� {� R@ $ � LINK>NAME � |@ i� �8 NAME>STRING � �8 v i� �h STRING=CI | r� 3DROP � j� j� j� i� �� FALSE D �� 2OVER � �0 s� �0 s� i� ~� LATEST � j &+
` �@ DO?LEAVE h �` U< �x
160: ROMFS-BASE d �� UNKNOWN-STR Undefined word � HW-EXCEPTION-HANDLER $ vH LL-CR � �� r ~ r i� w� BL D �� NOSHOWSTACK � j n� � i� �0 SHOW-STACK? l � .S � x jH s� j� j� s� j �� @ x �� sx �� s� x0 ��������� i� u SPACES � j �� u0 ��������� i� �� CHAR+ � �� i� oP C@ � �� BOUNDS � s` � j� i� � DO?DO � &I � {� ~P j� | i� �� DOLOOP t �x XOR ��
UNDEFINED-STR undefined word �� $FIND � �� jH j� 0 ~p jH �� j� �` �� i� �( DOABORT" � j� j� ( v� o` j`�������� q j� i� �P OFF � ( j� o` i� TIB � ~@ RPICK
, �h (U.) � �� � �x i� �@ (.) � �� jH | �� j �� {� �@ �P i� oh EXPECT � |h ox o` i� o SOURCE � o� o@ v� i� �� TRUE D�������� ~� NIP � j� j� i� �� $NUMBER � jH u` j� j� j� �� s� | jH | �` j` - jx jH j� x {� �8 {� �� jH u` j� ( j� j� j� �� s� | | j j {� {� �� �� u` j� 8 j� j� j� � ( s� j� j� j� �� i� �� SKIPWS � o� ox v� jH y� v� �8 j� p s` y� v� � �` �� �h j� ( �� y� �� j��������` j� j� i� �� PARSE � | o� y� v� � ox v� y� v� sx ~ {� �� j� 0 �� jH �� � j� jH y� �� i� ��&&\ � y� v� �� y� o` ~ �� s i� �
161: IMMEDIATE? � � �@ �X i� �� COMPILE, � �� i� ��&LEAVE � �� o� �X �H �@ v� � �@ o` �H i� � ?COMP � zX v� j� s� j`�������z q i� �H LEAVES � ��
162: HASH-TABLE l �� CHARS+ � �� i� �� NA+ � �8 � i� �X NA1+ � �� � i� �� KEY? $ q ABORT � n� q i� �� ERASE � j` � i� n� SLITERAL � {� |@ jH jH �` � j`�������� �@ | i� � PLACE � ~ �p �8 j� �� �x �� H jH �` �� �p �8 �� �� ���������� j� i� �� 1+ � �� � i� �� CHARS � � i� �� ALLOT � � � n� � i� �0 DAAR � � �P C! � �H +! � �� v� � j� o` i� �� CARRET D
|� TUCK � j� s` i� �� CONTEXT l �� �� LINK> � ~p �� i� �P REVEAL � � v� ~p ~� s@ � v� �� o` i� ~ 3DUP � � s� � s� � s� i� �� &3 D �� DOLEAVE 8 � &< � �8 FDT-START 8 �X ICBI 'l u�
EXCEPTION-STR Exception # � SHOWSTACK � n� n� � i� �p .H � �� v� j� �� x0 �� o` i� �� 1- � �� sx i� �� CA1+ � �0 � i� �@ EVEN � �� n� �@ i� uP DODO � �p ALIGNED � �� �� � �� � �@ i� �0 OR � ��&ABORT" � �� o� �� �H i� r (FIND-ORDER) � �( jH | �� �x j� � ~ ~P v� |@ v� r� |� j� ( �� �� {� j� s� {� �� j��������@ {� ~� j i� ~X NAME> � �8 jH �` �� �� �8 i� h` EVAL � hx i� �x COMP � �� U#> � j� �� jH v� �� sx i� �� <# � �� jH o` i� �8 U#S � �H jH j� j��������� i� �� #> � s �� jH v� �� sx i� �� ABS � jH s� j� � i� �� #S � �� ~ �� j� j��������� i� �� SIGN � s� j� j` - �� i� �8 NOT � �H i� �h >NUMBER � jH u` j� s� s` �` �� v� �x j� � j� | j� | | �� v� �� j� �� v� �� �� � {� j �0 {� �8 {� �� j��������� j� i� �` NEGATE � j j� sx i� &> � j� �p i� �� <= � �8 u` i� i� &1 D & �� FINDCHAR � j� j �� � s` �� � �` s` jH �� jx j� �h j� jx j� 0 �� �X �� �� �� s� ��������@ j� j� ( i� �h&&( � j` ) �� s i� �P
163: 'IMMEDIATE D & �� AND � �� 0<> � j �� i� � &, � � o` �� � i� �&+LOOP � �� o� �� �H �� �@ i� w` &] � j` & zX o` i� ��&REPEAT � �� � �h i� ��
164: CLEAN-HASH @ �� CELLS � �8 i� �( CA+ � � � i� �� XA+ � �� � i� �� /N* � �� � i� � XA1+ � �` � i� �P /N D �p KEY $ � BLANK � j` � i� �� FILL p �h ALIGN � � �� �� �@ j� j �� j��������� i� �� DO+LOOP � �� U* � � i� �8 CELL- � �� sx i� �h /C* � �0 � i� �� CRASH '� �� UNLOOP � {� {� {� s | i� � BS D �� SEARCH-ORDER � h( s( HEADER � �( � �� v� �� � o` j �� }P �( i� �8 LAST � �P |@ i� �� &2 D �` UNALIGNED-L! � �� HEAP-END �� PMC1@ '@ �� .D � �� v� j� �` x0 �� o` i� xX BASE � �H HEX � �� �� o` i� �� /C D & �� 2- � � sx i� �� XBFLIP � �X �� j� �� �� i� �&C" � �� j` " �� o� �� �H jH �� �x �� ( �� �` �� ��������� �( i� �h U>= � � u` i� �� PAD � � j` & � i� �� MU/MOD � jH | �h {� j� | �� {� i� �� U# � �� v� �h j� �� �� i� �0 &# � �� v� �� �� �� �� i� �� HOLD � �� jH v� �� �� j� o` �p i� �� INVERT � n� � i� � DIGIT � s` �` jH j` A j` Z �� j� j` sx j` 0 sx jH �� j j� � j� �� �� j� j� ( i� �� UM* � j �( j` @ j � �� ��������� j� i� �X ROT � | j� {� j� i� �� D+ � | �� {� � i� � D2/ � | �x ~P j` ? �� �� {� �� i� �( U> � j� � i� �� IMMEDIATE � �� v� |@ jH �` � �� j� �p i� �� CHAR � z j� �` i� �� ASHIFT d �� 0<= � j �h i� �X <> � jx u` i� ��&LOOP � �� o� � �H �� �@ i� �0 RESOLVE-LOOP � �@ v� |� j� P jH v� j� � s` sx j� o` j��������� � sx �H �@ o` i� �h -COMP � n� zX �� zX v� j� s� � s� �p v� n� � �� |� i� ��&WHILE � �� � j� i� �H&AGAIN � �� o� j� �H �� �@ i� ��&THEN � �� �� �@ i� � HASH � �@ LA+ � �� � i� �p /X* � �` � i� sh &*
� �� LA1+ � �� � i� �� /X D �P LCC � jH j` A j` Z �� j� j` � i� �� XLFLIPS � �x �� @ �� �� �� �� �� �` ���������� i� �� X, � � �� �` � i� �x C, � � �p �0 � i� � MIN � ~ �8 j� j� j� i� |0 CHAR- � �0 sx i� �� CELL D �h
165: FLUSHCACHE (P �� &J � {� {� {� ~P j� | j� | j� | i� �� BELL D h CURRENT l h( �� UNALIGNED-L@ 8 ��
166: HEAP-START � �� MMCR0! ' �� U.R � j� �� �� ~ �p j� ( s` sx �� j� j� vX i� �� DECIMAL � �� �� o` i� �P H#10 D �p D#10 D
167: �p 2+ � � � i� �� BXJOIN � �� | �� {� �� i� �( XLSPLIT � jH �� �@ j� �� �� i� �� LBFLIP � �� j� � j� �� i� �0 LXJOIN � �� �� �� i� �h&&; � �� o� i� �H �x wp i� �� U<= � �� u` i� �� OCTAL � �` �� o` i� �� TODIGIT � jH j` �8 j� j` ' � j` 0 � i� �� U/MOD � j j� �� i� �� UM/MOD � j` @ j � �� ��������� j� j� i� �p >>A � �� i� �( &? � v� x0 i� UPC � jH j` a j` z �� j� j` sx i� � BETWEEN � �� � � i� �h WITHIN � �� jH �� �� j� s ( s� �8 j� ( s� �� i� �� *' � | jH s� | � {� j� ~P �� {� i� �� -ROT � j� | j� {� i� �� CLEAR � j }0 i� �h M+ � j� | jH | � jH {� � {� j� sx i� � UD2/ � | �x ~P j` ? �� �� {� �x i� ð U2/ � �� �� i� � LSHIFT
� �h 2/ � �� �� i� �� WORD � �� | �� jH ~P �p �x {� jH � �� 8 �8 �� �` s` �p ��������� j� i� �� RSHIFT 0 �� >= � �p u` i� Ĩ&?DO � �x �@ v� o� �� �H � � �@ o` j �H i� �` +COMP � zX v� �� zX �� j� s� � �p o` �� n� � � � i� � COMPILE � {� |@ jH v� �H | i� � THERE � �X COMP-BUFFER � �&UNTIL � �� o� j� �H �� �@ i� �x&IF � �x o� j� �H � j �H i� �x&BEGIN � �x � i� �� RESOLVE-DEST � � |@ sx �H i� �0 RESOLVE-ORIG � � s` |@ sx j� o` i� � HASH-SIZE D �� WA+ � �8 � i� �( /L* � �� � i� �� WA1+ � �h � i� �X /L D �x XWFLIPS � �x �� @ �� �� �� �� �� �` ���������� i� �� X@ t �� XLFLIP � �X j� �� i� �p X! � � L, � � � �� � i� �� MAX � ~ �p j� j� j� i� �P
168: START-RTAS '� �h UNALIGNED-W! � Lj DEC! (� Ǡ .R � j� �� �� ~ �p j� ( s` sx �� j� j� vX i� �� &8 D ��
169: H#FFFFFFFF D ���� � XWFLIP � �x j� � j� �( i� Ȱ BLJOIN � �� | �� {� �� i� � LWSPLIT � jH � �@ j� �� �� i� �� H#20 D �@ LBSPLIT � �@ | �8 {� �8 i� � 2SWAP � | �( {� �( i� �x LWFLIP � �@ j� �� i� ɰ :NONAME � �( � o� � �H � i� � 0>= � j �� i� �0 FM/MOD � jH | ~ � s� | �@ s` �X {� �@ j� 0 �� j� {� � j� s� {� j� i� �� /' � | jH s� | � {� s` ~P �x �� j� 0 | �� �� {� ~P sx {� i� �x >> � �� i� v PACK � jH | j� ˰ {� i� � D- � �� �0 i� �� D2* � �� s` s� sx | �� {� i� ˸ DABS � jH s� j� �� i� � 2* � �� �� i� �8 POCKET � �x �P v� j` & � � �P v� �� � jH j` jx j� j� j �P o` i� �h&DO � �x �@ v� � o� � �H j �@ o` i� ̀&.( � j` ) �� vX i� � CISTACK � ��&AHEAD � �x o� j� �H � j �H i� � &ENDOF � �� | �� {� i� � ZCOUNT � /W* � �h � i� � /W D �0 XBFLIPS � �x �� @ �� �� �� �� �� �` ���������� i� ΰ L! H �� W, � � �� �h � i� �� CALL-C ( �� UNALIGNED-W@ � � DEC@ (� �@ U. � �� vX u0 i� � &4 D �h H#FFFF D �� �� WXJOIN � �� | �� {� �� i� �� XWSPLIT � �X | �@ {� �@ i� �� WLJOIN � �� �� �� i� ψ BWJOIN � �` �� �� i� �� WBSPLIT � jH �x �@ j� �` �� i� �� WBFLIP � �8 j� �� i� �0 &: � z �` o� � �H � i� �H 0> � j �8 i� �� SM/REM � s` | | �x ~P �� �� {� s� j� � {� s� j� � j� � j� i� �p M* � ~ � | | �� {� �� �� {� s� j� �� i� �� << � �� i� |� MOVE � � DNEGATE � �H | � jH u` {� j� sx i� �8 ?PICK � z WHICHPOCKET � �h POCKETS И&." � zX v� j� ( � o� vX �H s� j` " �� vX i� Ѹ CIREGS h ��&OF � �� �� | o� s` �H o� jx �H � o� j� �H {� i� �X&ELSE � �� o� j� �H � j �H j� �� i� ˠ RMOVE � �` LBFLIPS � �x �� @ �� �� �� �� � �� ���������� i� �� L@ $ �� W! � �� WRITE-LOG-BYTE-ENTRY � �� v� i� �� HSPRG1! &� x S. � x0 i� �� H#FF D � �` XBSPLIT � �X | �� {� �� i� � */ � �( �� i� �h S>D � jH s� i� �X 2R@ � {� {� ~P s` | �� | j� i� ��&Z" � � ~ � j j� �p j� i� ��&S" � zX v� j� ( �� o� v �H s� j` " �� jH | �� jH | j� ˰ {� {� i� �` EREGS @ Ө&ENDCASE � �� o� j� �H |� j� ( �� j� �h j��������� �@ i� �� LWFLIPS � �x �� @ �� �� �@ �� � �� ���������� i� �` W@ � �X HSPRG1@ &� �x */MOD � | � {� � i� Ԩ 2R> � {� {� {� �� | j� i� Ͱ&CASE � �x j i� �� WBFLIPS � �x �� @ �� �� Ɉ �� �� �h ���������� i� �H HSPRG0! &l �h MOD � ը j� i� �� 2>R � {� �� | j� | | i� ֨ 2! � jH | o` {� |@ o` i� �� HSPRG0@ &� &/ � ը �� i� �X /MOD � | � {� � i� � -ROLL � jH |� j� H | �� {� j� | �� sx j��������� |� j� 0 {� j� �� sx j��������� i� �� 2@ � jH |@ v� j� v� i� �0 SPRG3! & �H ROLL � jH |� j� 0 �� | �� sx j��������� |� j� 0 {� �( �� sx j��������� i� ؘ <W@ � �� jH j` � �� j� j` & sx i� �� SPRG3@ &D �� 2ROT � | | � {� {� � i� �0 ON � �� j� o` i� �� SPRG2! %� � SPRG2@ %� � SPRG1! %| �0 SPRG1@ %� �H SPRG0! %, �` SPRG0@ %T �x HIOR! $� ِ HIOR@ % ٨ DABR! $� �� DABR@ $� �� TBU@ $\ �� TBL@ $4 � PIR@ $ � PVR@ #� �8 SDR1! +� �P SDR1@ #� �h MSR! +p ڀ MSR@ +� ژ HID5@ +H ڰ HID5! + �� HID4@ *� �� HID4! *� �� HID1@ *� � HID1! *d �( HID0@ *< �@ HID0! )� �X RX! )� �p RX@ )� ۈ RL! )| ۠ RL@ )X ۸ RW! ), �� RW@ ,d �� RB! ,8 � RB@ , � get-mbx-base +� �@ get-flash-size ,� �` get-flash-base ,� ܀ get-nvram-size ,� ܠ get-nvram-base #� �� internal-set-env "X �� internal-del-env !d � internal-add-env t �@ internal-get-env � �h delete-nvram-partition #H ݐ erase-nvram-partition " �� increase-nvram-partition �� new-nvram-partition � � get-named-nvram-partition � �@ get-nvram-partition X �`
170: wipe-nvram t ހ nvram-debug � ި internal-reset-nvram \ �� nvram-x! $ �� nvram-x@ ` � nvram-l! � �( nvram-l@ 8 �H nvram-w! � �h nvram-w@ ߈ nvram-c! � ߨ nvram-c@ � �� bootmsg-checklevel � �� bootmsg-nvupdate � � bootmsg-setlevel X �H bootmsg-debugcp �h
bootmsg-error � �� bootmsg-warning � �
171: bootmsg-cp ` �� hv-send-crq , �� hv-free-crq � �
172: hv-reg-crq � �0
173: hv-haschar � �P
174: hv-getchar ` �p
175: hv-putchar 4 ��&o# � z �� v� | �� hx {� �� o` i� �@&h# � z �� v� | �� hx {� �� o` i� �&d# � z �� v� | �` hx {� �� o` i� ��&RECURSE � � v� �H �H i� � & RECURSIVE � �x i� �X BODY> � � �� sx i� � >BODY � � �� � i� �� BEHAVIOR � |@ v� i� �H&TO � w zX v� j� ( o� n� �H �H s� |@ o` i� �� FIND � jH v �` j� H �� j� �� j� � j� � s� ( s� i� �0&['] � w o� o� �H �H i� �`&[CHAR] � �x �( i� �X&POSTPONE � z �` u` o� �@ �� � u` j� 0 o� o� �H �H o� �H �H i� �&LITERAL � o� j` �H �H i� �& [COMPILE] � w �H i� �� FIELD � z �` o� � �H s` �� � �x i� �(
176: END-STRUCT � j� i� �P STRUCT � j i� � ALIAS � z �` o� 4 �H w �H �x i� � DEFER � z �` o� $ �H o� �( �H �x i� �x BUFFER: � z �` o� � �H � �x i� �� VARIABLE � z �` o� � �H j �H �x i� �8 VALUE � z �` o� l �H �H �x i� � CONSTANT � z �` o� D �H �H �x i� ��&DOES> � o� �� �H i� �0 DODOES> � {� |@ � v� �H |@ o` i� �` CREATE � z �x i� �� $CREATE � �` o� � �H o� q� |@ �H �x i� � INCLUDE � z � i� �( INCLUDED � �h ~ | | �x �� � {� ~P j� | ~P sx ~P j� ~ ~ �� j� �� jH | hx {� �� ���������X {� {� � i� �x
177: WRITE-FILE $ l` MAP-FILE $ �P
178: UNMAP-FILE $ � q� NICEINIT � o� j� n� r o� r( n� r� o� s n� s@ j` �8 j` a\ s` sx o� hx o� q� i� �P HERE l �@ �� CLIENT-ENTRY-POINT D bx � .WRITE-LOG-BYTE-ENTRY D b` j� ROMFS-LOOKUP-ENTRY D 5Xhex
179: ' ll-cr to cr
180: get-flash-base VALUE flash-addr
181: get-nvram-base CONSTANT nvram-base
182: get-nvram-size CONSTANT nvram-size
183: ff8f9000 CONSTANT sec-nvram-base \ save area from phype.... not really known
184: 2000 CONSTANT sec-nvram-size
185: nvram-base 20000 + CONSTANT nvram-log-be1-base
186: : hvterm-emit hv-putchar ;
187: : hvterm-key? hv-haschar ;
188: : hvterm-key BEGIN hvterm-key? UNTIL hv-getchar ;
189: ' hvterm-emit to emit
190: ' hvterm-key to key
191: ' hvterm-key? to key?
192: : serial-emit hvterm-emit ;
193: : serial-key? hvterm-key? ;
194: : serial-key hvterm-key ;
195: clean-hash
196: : hash-find ( str len head -- 0 | link )
197: >r 2dup 2dup hash ( str len str len hash R: head )
198: dup >r @ dup ( str len str len *hash *hash R: head hash )
199: IF ( str len str len *hash R: head hash )
200: link>name name>string string=ci ( str len true|false R: head hash )
201: dup 0=
202: IF
203: THEN
204: ELSE
205: nip nip ( str len 0 R: head hash )
206: THEN
207: IF \ hash found
208: 2drop r> @ r> drop ( *hash R: )
209: exit
210: THEN \ hash not found
211: r> r> swap >r ((find)) ( str len head R: hash=0 )
212: dup
213: IF
214: dup r> ! ( link R: )
215: ELSE
216: r> drop ( 0 R: )
217: THEN
218: ;
219: : hash-reveal hash off ;
220: ' hash-reveal to (reveal)
221: ' hash-find to (find)
222: : >name ( xt -- nfa ) \ note: still has the "immediate" field!
223: BEGIN char- dup c@ UNTIL ( @lastchar )
224: dup dup aligned - cell+ char- ( @lastchar lenmodcell )
225: dup >r -
226: BEGIN dup c@ r@ <> WHILE
227: cell- r> cell+ >r
228: REPEAT
229: r> drop char-
230: ;
231: VARIABLE mask -1 mask !
232: VARIABLE huge-tftp-load 1 huge-tftp-load !
233: : sms-get-tftp-blocksize 598 ;
234: : default-hw-exception s" Exception #" type . ;
235: ' default-hw-exception to hw-exception-handler
236: : diagnostic-mode? false ; \ 2B DOTICK'D later in envvar.fs
237: : memory-test-suite ( addr len -- fail? )
238: diagnostic-mode? IF
239: ." Memory test mask value: " mask @ . cr
240: ." No memory test suite currently implemented! " cr
241: THEN
242: false
243: ;
244: : 0.r 0 swap <# 0 ?DO # LOOP #> type ;
245: : cnt-bits ( 64-bit-value -- #bits=1 )
246: dup IF
247: 41 1 DO dup 1- and dup 0= IF drop i LEAVE THEN LOOP
248: THEN
249: ;
250: : bcd-to-bin ( bcd -- bin )
251: dup f and swap 4 rshift a * +
252: ;
253: : 2log ( n -- lb{n} )
254: 8 cells 0 DO 1 rshift dup 0= IF drop i LEAVE THEN LOOP
255: ;
256: : log2 ( n -- log2-n )
257: 1- 2log 1+
258: ;
259: : $find ( str len -- xt true | str len false )
260: 2dup $find
261: IF
262: drop nip nip TRUE
263: ELSE
264: FALSE
265: THEN
266: ;
267: CREATE $catpad 100 allot
268: : $cat ( str1 len1 str2 len2 -- str3 len3 )
269: >r >r dup >r $catpad swap move
270: r> dup $catpad + r> swap r@ move
271: r> + $catpad swap ;
272: : $cat-comma ( str2 len2 str1 len1 -- "str1, str2" len1+len2+2 )
273: 2dup + s" , " rot swap move 2+ 2swap $cat
274: ;
275: : $cat-space ( str2 len2 str1 len1 -- "str1 str2" len1+len2+1 )
276: 2dup + bl swap c! 1+ 2swap $cat
277: ;
278: : $cathex ( str len val -- str len' )
279: (u.) $cat
280: ;
281: : 2CONSTANT CREATE , , DOES> 2@ ;
282: : $2CONSTANT $CREATE , , DOES> 2@ ;
283: : 2VARIABLE CREATE 0 , 0 , DOES> ;
284: : (is-user-word) ( name-str name-len xt -- ) -rot $CREATE , DOES> @ execute ;
285: : zplace ( str len buf -- ) 2dup + 0 swap c! swap move ;
286: : rzplace ( str len buf -- ) 2dup + 0 swap rb! swap rmove ;
287: : strdup ( str len -- dupstr len ) here over allot swap 2dup 2>r move 2r> ;
288: : str= ( str1 len1 str2 len2 -- equal? )
289: rot over <> IF 3drop false ELSE comp 0= THEN ;
290: : #aligned ( adr alignment -- adr' ) negate swap negate and negate ;
291: : #join ( lo hi #bits -- x ) lshift or ;
292: : #split ( x #bits -- lo hi ) 2dup rshift dup >r swap lshift xor r> ;
293: : /string ( str len u -- str' len' )
294: >r swap r@ chars + swap r> - ;
295: : skip ( str len c -- str' len' )
296: >r BEGIN dup WHILE over c@ r@ = WHILE 1 /string REPEAT THEN r> drop ;
297: : scan ( str len c -- str' len' )
298: >r BEGIN dup WHILE over c@ r@ <> WHILE 1 /string REPEAT THEN r> drop ;
299: : split ( str len char -- left len right len )
300: >r 2dup r> findchar IF >r over r@ 2swap r> 1+ /string ELSE 0 0 THEN ;
301: : rfindchar ( str len char -- offs true | false )
302: swap 1 - 0 swap do
303: over i + c@
304: over dup bl = if <= else = then if
305: 2drop i dup dup leave
306: then
307: -1 +loop =
308: ;
309: : rsplit ( str len char -- left len right len )
310: >r 2dup r> rfindchar IF >r over r@ 2swap r> 1+ /string ELSE 0 0 THEN ;
311: : left-parse-string ( str len char -- R-str R-len L-str L-len )
312: split 2swap ;
313: : replace-char ( str len chout chin -- )
314: >r -rot BEGIN 2dup 4 pick findchar WHILE tuck - -rot + r@ over c! swap REPEAT
315: r> 2drop 2drop
316: ;
317: : \-to-/ ( str len -- str' len ) strdup 2dup [char] \ [char] / replace-char ;
318: : // dup >r 1- + r> / ; \ division, round up
319: : c@+ ( adr -- c adr' ) dup c@ swap char+ ;
320: : 2c@ ( adr -- c1 c2 ) c@+ c@ ;
321: : 4c@ ( adr -- c1 c2 c3 c4 ) c@+ c@+ c@+ c@ ;
322: : 8c@ ( adr -- c1 c2 c3 c4 c5 c6 c7 c8 ) c@+ c@+ c@+ c@+ c@+ c@+ c@+ c@ ;
323: : 4dup ( n1 n2 n3 n4 -- n1 n2 n3 n4 n1 n2 n3 n4 ) 2over 2over ;
324: : 4drop ( n1 n2 n3 n4 -- ) 2drop 2drop ;
325: : 6dup ( 1 2 3 4 5 6 -- 1 2 3 4 5 6 1 2 3 4 5 6 )
326: 5 pick 5 pick 5 pick 5 pick 5 pick 5 pick
327: ;
328: : signed ( n1 -- n2 ) dup 80000000 and IF FFFFFFFF00000000 or THEN ;
329: : <l@ ( addr -- x ) l@ signed ;
330: : -leading BEGIN dup WHILE over c@ bl <= WHILE 1 /string REPEAT THEN ;
331: : (parse-line) skipws 0 parse ;
332: : hex-byte ( char0 char1 -- value true|false )
333: 10 digit IF
334: swap 10 digit IF
335: 4 lshift or true EXIT
336: ELSE
337: 2drop 0
338: THEN
339: ELSE
340: drop
341: THEN
342: false EXIT
343: ;
344: : parse-hexstring ( dst-adr -- dst-adr' )
345: [char] ) parse cr ( dst-adr str len )
346: bounds ?DO ( dst-adr )
347: i c@ i 1+ c@ hex-byte IF ( dst-adr hex-byte )
348: >r dup r> swap c! 1+ 2 ( dst-adr+1 2 )
349: ELSE
350: drop 1 ( dst-adr 1 )
351: THEN
352: +LOOP
353: ;
354: : add-specialchar ( dst-adr special -- dst-adr' )
355: over c! 1+ ( dst-adr' )
356: 1 >in +! \ advance input-index
357: ;
358: : parse-" ( dst-adr -- dst-adr' )
359: [char] " parse dup 3 pick + >r ( dst-adr str len R: dst-adr' )
360: >r swap r> move r> ( dst-adr' )
361: ;
362: : (") ( dst-adr -- dst-adr' )
363: begin ( dst-adr )
364: parse-" ( dst-adr' )
365: >in @ dup span @ >= IF ( dst-adr' >in-@ )
366: drop
367: EXIT
368: THEN
369: ib + c@
370: CASE
371: [char] ( OF parse-hexstring ENDOF
372: [char] " OF [char] " add-specialchar ENDOF
373: dup OF EXIT ENDOF
374: ENDCASE
375: again
376: ;
377: CREATE "pad 100 allot
378: : " ( [text<">< >] -- text-str text-len )
379: state @ IF \ compile sliteral, pstr into dict
380: "pad dup (") over - ( str len )
381: ['] sliteral compile, dup c, ( str len )
382: bounds ?DO i c@ c, LOOP
383: align ['] count compile,
384: ELSE
385: pocket dup (") over - \ Interpretation, put string
386: THEN \ in temp buffer
387: ; immediate
388: : $forget ( str len -- )
389: 2dup last @ ( str len str len last-bc )
390: BEGIN
391: dup >r ( str len str len last-bc R: last-bc )
392: cell+ char+ count ( str len str len found-str found-len R: last-bc )
393: string=ci IF ( str len R: last-bc )
394: r> @ last ! 2drop clean-hash EXIT ( -- )
395: THEN
396: 2dup r> @ dup 0= ( str len str len next-bc next-bc )
397: UNTIL
398: drop 2drop 2drop \ clean hash table
399: ;
400: : forget ( "old-name<>" -- )
401: parse-word $forget
402: ;
403: : linked ( var -- ) here over @ , swap ! ;
404: HEX
405: VARIABLE wordlists forth-wordlist wordlists !
406: : wordlist ( -- wid ) here wordlists linked 0 , ;
407: 10 CONSTANT max-in-search-order \ should define elsewhere
408: : also ( -- ) clean-hash context dup cell+ dup to context >r @ r> ! ;
409: : previous ( -- ) clean-hash context cell- to context ;
410: : only ( -- ) clean-hash search-order to context ( minimal-wordlist search-order ! ) ;
411: : seal ( -- ) clean-hash context @ search-order dup to context ! ;
412: : get-order ( -- wid_n .. wid_1 n )
413: context >r search-order BEGIN dup r@ u<= WHILE
414: dup @ swap cell+ REPEAT r> drop
415: search-order - cell / ;
416: : set-order ( wid_n .. wid_1 n -- ) \ XXX: special cases for 0, -1
417: clean-hash 1- cells search-order + dup to context
418: BEGIN dup search-order u>= WHILE
419: dup >r ! r> cell- REPEAT drop ;
420: : get-current ( -- wid ) current ;
421: : set-current ( wid -- ) to current ;
422: : definitions ( -- ) context @ set-current ;
423: : VOCABULARY ( C: "name" -- ) ( -- ) CREATE wordlist drop DOES> clean-hash context ! ;
424: : FORTH ( -- ) clean-hash forth-wordlist context ! ;
425: : .voc ( wid -- ) \ display name for wid \ needs work ( body> or something like that )
426: dup cell- @ ['] vocabulary ['] forth within IF
427: 2 cells - >name name>string type ELSE u. THEN space ;
428: : vocs ( -- ) \ display all wordlist names
429: cr wordlists BEGIN @ dup WHILE dup .voc REPEAT drop ;
430: : order ( -- )
431: cr ." context: " get-order 0 ?DO .voc LOOP
432: cr ." current: " get-current .voc ;
433: : voc-find ( wid -- 0 | link )
434: clean-hash cell+ @ (find) clean-hash ;
435: : (function) ;
436: defer (defer)
437: 0 value (value)
438: 0 constant (constant)
439: variable (variable)
440: create (create)
441: alias (alias) (function)
442: cell buffer: (buffer:)
443: ' (function) @ \ ( <colon> )
444: ' (function) cell + @ \ ( ... <semicolon> )
445: ' (defer) @ \ ( ... <defer> )
446: ' (value) @ \ ( ... <value> )
447: ' (constant) @ \ ( ... <constant> )
448: ' (variable) @ \ ( ... <variable> )
449: ' (create) @ \ ( ... <create> )
450: ' (alias) @ \ ( ... <alias> )
451: ' (buffer:) @ \ ( ... <buffer:> )
452: forget (function)
453: constant <buffer:>
454: constant <alias>
455: constant <create>
456: constant <variable>
457: constant <constant>
458: constant <value>
459: constant <defer>
460: constant <semicolon>
461: constant <colon>
462: ' lit constant <lit>
463: ' sliteral constant <sliteral>
464: ' 0branch constant <0branch>
465: ' branch constant <branch>
466: ' doloop constant <doloop>
467: ' dotick constant <dotick>
468: ' doto constant <doto>
469: ' do?do constant <do?do>
470: ' do+loop constant <do+loop>
471: ' do constant <do>
472: ' exit constant <exit>
473: ' doleave constant <doleave>
474: ' do?leave constant <do?leave>
475: 500 CONSTANT AVAILABLE-SIZE
476: 10000000 CONSTANT MIN-RAM-SIZE \ assumed minimal memory size
477: 4000 CONSTANT MIN-RAM-RESERVE \ prevent from using first pages
478: STRUCT
479: cell field available>address
480: cell field available>size
481: CONSTANT /available
482: CREATE available AVAILABLE-SIZE /available * allot available AVAILABLE-SIZE /available * erase
483: VARIABLE mem-pre-released 0 mem-pre-released !
484: : available>size@ available>size @ ;
485: : available>address@ available>address @ ;
486: : available>size! available>size ! ;
487: : available>address! available>address ! ;
488: : available! ( addr size available-ptr -- )
489: dup -rot available>size! available>address!
490: ;
491: : available@ ( available-ptr -- addr size )
492: dup available>address@ swap available>size@
493: ;
494: : (?available-segment<) ( start1 end1 start2 end2 -- true/false ) drop < nip ;
495: : (?available-segment>) ( start1 end1 start2 end2 -- true/false ) -rot 2drop > ;
496: : (?available-segment-#) ( start1 end1 start2 end2 -- true/false )
497: 2dup 5 roll -rot ( e1 s2 e2 s1 s2 e2 )
498: between >r between r> and not
499: ;
500: : (find-available) ( addr addr+size-1 a-ptr a-size -- a-ptr' found )
501: ?dup 0= IF -rot 2drop false EXIT THEN \ Not Found
502: 2dup 2/ dup >r /available * +
503: dup available>size@ 0= IF 2drop r> RECURSE EXIT THEN
504: dup >r available@
505: over + 1- 2>r 2swap
506: 2dup 2r@ (?available-segment>) IF
507: 2swap 2r> 2drop r>
508: /available + -rot r> - 1- nip RECURSE EXIT \ Look Right
509: THEN
510: 2dup 2r@ (?available-segment<) IF
511: 2swap 2r> 2drop r>
512: 2drop r> RECURSE EXIT \ Look Left
513: THEN
514: 2dup 2r@ (?available-segment-#) IF \ Conflict - segments overlap
515: 2r> 2r> 3drop 3drop 2drop
516: 1212 throw
517: THEN
518: 2r> 3drop 3drop r> r> drop ( a-ptr' -- )
519: dup available>size@ 0<> ( a-ptr' found -- )
520: ;
521: : (find-available) ( addr size -- seg-ptr found )
522: over + 1- available AVAILABLE-SIZE ['] (find-available) catch IF
523: 2drop 2drop 0 false
524: THEN
525: ;
526: : dump-available ( available-ptr -- )
527: cr
528: dup available - /available / AVAILABLE-SIZE swap - 0 ?DO
529: dup available@ ?dup 0= IF
530: 2drop UNLOOP EXIT
531: THEN
532: swap . . cr
533: /available +
534: LOOP
535: dup
536: ;
537: : .available available dump-available ;
538: : (drop-available) ( available-ptr -- )
539: dup available - /available / \ current element index
540: AVAILABLE-SIZE swap - \ # of remaining elements
541: ( first nelements ) 1- 0 ?DO
542: dup /available + dup available@
543: ( current next next>address next>size ) ?dup 0= IF
544: 2drop LEAVE \ NULL element - goto last copy
545: THEN
546: 3 roll available! ( next )
547: LOOP
548: 0 0 rot available!
549: ;
550: : (stick-to-previous-available) ( addr size available-ptr -- naddr nsize nptr success )
551: dup available = IF
552: false EXIT \ This was the first available segment
553: THEN
554: dup /available - dup available@
555: + 4 pick = IF
556: nip \ Drop available-ptr since we are going to previous one
557: rot drop \ Drop start addr, we take the previous one
558: dup available@ 3 roll + rot true
559: ELSE
560: drop false
561: THEN
562: ;
563: : (insert-available) ( available-ptr -- available-ptr )
564: dup \ current element
565: dup available - /available / \ current element index
566: AVAILABLE-SIZE swap - \ # of remaining elements
567: dup 0<= 3 pick available>size@ 0= or IF
568: drop drop EXIT
569: THEN
570: over available@ rot
571: ( first first/=current/ first>address first>size nelements ) 1- 0 ?DO
572: 2>r
573: /available + dup available@
574: 2r> 4 pick available! dup 0= IF
575: rot /available + available!
576: UNLOOP EXIT
577: THEN
578: LOOP
579: ( first next/=last/ last[0]>address last[0]>size ) ?dup 0<> IF
580: cr ." release error: available map overflow"
581: cr ." Dumping available property"
582: .available
583: cr ." No space for one before last entry:" cr swap . .
584: cr ." Dying ..." cr 123 throw
585: THEN
586: 2drop
587: ;
588: : insert-available ( addr size available-ptr -- addr size available-ptr )
589: dup available>address@ 0<> IF
590: dup available>address@ rot dup -rot -
591: 3 pick = IF \ if (available>address@ - size == addr)
592: over available>size@ + swap
593: (stick-to-previous-available) IF
594: dup /available + (drop-available)
595: THEN
596: ELSE
597: swap (stick-to-previous-available)
598: not IF (insert-available) THEN
599: THEN
600: ELSE
601: (stick-to-previous-available) drop
602: THEN
603: ;
604: defer release
605: : drop-available ( addr size available-ptr -- addr )
606: dup >r available@
607: over 4 pick swap - ?dup 0<> IF
608: dup 3 roll swap r> available! -
609: over - ?dup 0= IF
610: drop
611: ELSE
612: swap 2 pick + swap release
613: THEN
614: ELSE
615: nip ( req_addr req_size segment_size )
616: over - ?dup 0= IF
617: drop r> (drop-available)
618: ELSE
619: -rot over + rot r> available!
620: THEN
621: THEN
622: ;
623: : pwr2roundup ( value -- pwr2value )
624: dup CASE
625: 0 OF EXIT ENDOF
626: 1 OF EXIT ENDOF
627: ENDCASE
628: dup 1 DO drop i dup +LOOP
629: dup +
630: ;
631: : (claim-best-fit) ( len align -- len base )
632: pwr2roundup 1- -1 -1
633: available AVAILABLE-SIZE /available * + available DO
634: i \ Must be saved now, before we use Return stack
635: -rot >r >r swap >r
636: available@ ?dup 0= IF drop r> r> r> LEAVE THEN \ EOL
637: 2 pick - dup 0< IF
638: 2drop \ Can't Fit: Too Small
639: ELSE
640: dup 2 pick r@ and - 0< IF
641: 2drop \ Can't Fit When Aligned
642: ELSE
643: r> -rot dup r@ U< IF
644: 2r> 2drop
645: swap 2 pick + 2 pick invert and >r >r >r
646: ELSE
647: 2drop >r
648: THEN
649: THEN
650: THEN
651: r> r> r>
652: /available +LOOP
653: -rot 2drop ( len best-fit-base/or -1 if none found/ )
654: ;
655: : (adjust-release0) ( 0 size -- addr' size' )
656: 2dup MIN-RAM-SIZE dup 3 roll + -rot -
657: dup 0< IF 2drop ELSE
658: 2swap 2drop 0 mem-pre-released !
659: THEN
660: ;
661: : claim ( [ addr ] len align -- base )
662: ?dup 0<> IF
663: (claim-best-fit) dup -1 = IF
664: 2drop cr ." claim error : aligned allocation failed" cr
665: ." available:" cr .available
666: 321 throw EXIT
667: THEN
668: swap
669: THEN
670: 2dup (find-available) not IF
671: drop
672: 2drop
673: 321 throw EXIT
674: THEN
675: ( req_addr req_size available-ptr ) drop-available
676: ;
677: : .release ( addr len -- )
678: over 0= mem-pre-released @ and IF (adjust-release0) THEN
679: 2dup (find-available) IF
680: drop swap
681: cr ." release error: region " . ." , " . ." already released" cr
682: ELSE
683: ?dup 0= IF
684: swap
685: cr ." release error: Bad/conflicting region " . ." , " .
686: ." or available list full " cr
687: ELSE
688: ( addr size available-ptr ) insert-available
689: ( addr size available-ptr ) available!
690: THEN
691: THEN
692: ;
693: ' .release to release
694: 0 MIN-RAM-SIZE release 1 mem-pre-released !
695: 0 MIN-RAM-RESERVE 0 ' claim CATCH IF ." claim failed!" cr 2drop THEN drop
696: E000000 2000000 0 ' claim CATCH IF ." claim failed!" cr 2drop THEN drop
697: heap-end heap-start - log2 1+ CONSTANT (max-heads#)
698: CREATE heads (max-heads#) cells allot
699: heads (max-heads#) cells erase
700: : size>head ( size -- headptr ) log2 3 max cells heads + ;
701: : alloc-mem ( len -- a-addr )
702: dup 0= IF EXIT THEN
703: 1 over log2 3 max ( len 1 log_len )
704: dup (max-heads#) >= IF cr ." Out of internal memory." cr 3drop 0 EXIT THEN
705: lshift >r ( len R: 1<<log_len )
706: size>head dup @ IF
707: dup @ dup >r @ swap ! r> r> drop EXIT
708: THEN ( headptr R: 1<<log_len)
709: r@ 2* recurse dup ( headptr a-addr2 a-addr2 R: 1<<log_len)
710: dup 0= IF r> 2drop 2drop 0 EXIT THEN
711: r> + >r 0 over ! swap ! r>
712: ;
713: : free-mem ( a-addr len -- )
714: dup 0= IF 2drop EXIT THEN size>head 2dup @ swap ! !
715: ;
716: : #links ( a -- n )
717: @ 0 BEGIN over WHILE 1+ swap @ swap REPEAT nip
718: ;
719: : .free ( -- )
720: 0 (max-heads#) 0 DO
721: heads i cells + #links dup IF
722: cr dup . ." * " 1 i lshift dup . ." = " * dup .
723: THEN
724: +
725: LOOP
726: cr ." Total " .
727: ;
728: heap-start heap-end heap-start - free-mem
729: VARIABLE device-tree
730: VARIABLE current-node
731: : get-node current-node @ dup 0= ABORT" No active device tree node" ;
732: STRUCT
733: cell FIELD node>peer
734: cell FIELD node>parent
735: cell FIELD node>child
736: cell FIELD node>properties
737: cell FIELD node>words
738: cell FIELD node>instance
739: cell FIELD node>instance-size
740: cell FIELD node>space?
741: cell FIELD node>space
742: cell FIELD node>addr1
743: cell FIELD node>addr2
744: cell FIELD node>addr3
745: END-STRUCT
746: : find-method ( str len phandle -- false | xt true )
747: node>words @ voc-find dup IF link> true THEN ;
748: 0 VALUE my-self
749: : >instance
750: my-self 0= ABORT" No instance!"
751: my-self +
752: ;
753: : (create-instance-var) ( initial-value -- )
754: get-node ?dup 0= ABORT" Instance word outside device context!"
755: dup node>instance @ ( iv phandle tmp-ihandle )
756: swap node>instance-size dup @ ( iv tmp-ih *instance-size instance-size )
757: dup , \ compile current instance ptr
758: swap 1 cells swap +! ( iv tmp-ih instance-size )
759: + !
760: ;
761: : create-instance-var ( "name" initial-value -- )
762: CREATE (create-instance-var) PREVIOUS ;
763: VOCABULARY instance-words ALSO instance-words DEFINITIONS
764: : VARIABLE 0 create-instance-var DOES> @ >instance ;
765: : VALUE create-instance-var DOES> @ >instance @ ;
766: : DEFER 0 create-instance-var DOES> @ >instance @ execute ;
767: PREVIOUS DEFINITIONS
768: : (instance?) ( xt -- xt true|false )
769: dup @ <create> = IF
770: dup cell+ @ cell+ @ ['] >instance =
771: ELSE
772: false
773: THEN
774: ;
775: : (doito) ( value R:*CFA -- )
776: r> cell+ dup >r
777: @ cell+ cell+ @ >instance !
778: ;
779: : to ( value wordname<> -- )
780: ' (instance?)
781: state @ IF
782: IF ['] (doito) ELSE ['] DOTO THEN
783: , , EXIT
784: THEN
785: IF
786: cell+ cell+ @ >instance ! \ interp mode instance value
787: ELSE
788: cell+ ! \ interp mode normal value
789: THEN
790: ; IMMEDIATE
791: : INSTANCE ALSO instance-words ;
792: STRUCT
793: /n FIELD instance>node
794: /n FIELD instance>parent
795: /n FIELD instance>args
796: /n FIELD instance>args-len
797: CONSTANT /instance-header
798: : my-parent my-self instance>parent @ ;
799: : my-args my-self instance>args 2@ ;
800: : set-my-args ( old-addr len -- )
801: dup IF \ IF len > 0 ( old-addr len )
802: dup alloc-mem \ | allocate space for new args ( old-addr len new-addr )
803: swap 2dup \ | write the new address ( old-addr new-addr len new-addr len )
804: my-self instance>args 2! \ | into the instance table ( old-addr new-addr len )
805: move \ | and copy the args ( -- )
806: ELSE \ ELSE ( old-addr len )
807: my-self instance>args 2! \ | set new args to zero, too ( )
808: THEN \ FI
809: ;
810: : create-instance-data ( -- instance )
811: get-node dup node>instance @ swap node>instance-size @ ( instance instance-size )
812: dup alloc-mem dup >r swap move r>
813: ;
814: : create-instance ( -- )
815: my-self create-instance-data
816: dup to my-self instance>parent !
817: get-node my-self instance>node !
818: ;
819: : destroy-instance ( instance -- )
820: dup @ node>instance-size @ free-mem
821: ;
822: : ihandle>phandle ( ihandle -- phandle )
823: dup 0= ABORT" no current instance" instance>node @
824: ;
825: : push-my-self ( ihandle -- ) r> my-self >r >r to my-self ;
826: : pop-my-self ( -- ) r> r> to my-self >r ;
827: : call-package push-my-self execute pop-my-self ;
828: : $call-static ( ... str len node -- ??? )
829: find-method IF execute ELSE -1 throw THEN
830: ;
831: : $call-my-method ( str len -- ) my-self ihandle>phandle $call-static ;
832: : $call-method push-my-self $call-my-method pop-my-self ;
833: : $call-parent my-parent $call-method ;
834: 1000 CONSTANT max-instance-size
835: 3000000 CONSTANT space-code-mask
836: : create-node ( parent -- new )
837: max-instance-size alloc-mem dup max-instance-size erase >r
838: align wordlist >r wordlist >r
839: here 0 , swap , 0 , r> , r> , r> , /instance-header , 0 , 0 , 0 , 0 , ;
840: : peer node>peer @ ;
841: : parent node>parent @ ;
842: : child node>child @ ;
843: : peer dup IF peer ELSE drop device-tree @ THEN ;
844: : link ( new head -- ) \ link a new node at the end of a linked list
845: BEGIN dup @ WHILE @ REPEAT ! ;
846: : link-node ( parent child -- )
847: swap dup IF node>child link ELSE drop device-tree ! THEN ;
848: : set-node ( phandle -- )
849: current-node @ IF previous THEN
850: dup current-node !
851: ?dup IF node>words @ also context ! THEN
852: definitions ;
853: : get-parent get-node parent ;
854: : new-node ( -- phandle ) \ active node becomes new node's parent;
855: current-node @ dup create-node
856: tuck link-node dup set-node ;
857: : finish-node ( -- )
858: get-node parent set-node ;
859: : device-end ( -- ) 0 set-node ;
860: CREATE $indent 100 allot VARIABLE indent 0 indent !
861: true value encode-first?
862: : decode-int over >r 4 /string r> 4c@ swap 2swap swap bljoin ;
863: : decode-64 decode-int -rot decode-int -rot 2swap swap lxjoin ;
864: : decode-string ( prop-addr1 prop-len1 -- prop-addr2 prop-len2 str len )
865: dup 0= IF 2dup EXIT THEN \ string properties with zero lenght
866: over BEGIN dup c@ 0= IF 1+ -rot swap 2 pick over - rot over - -rot 1-
867: EXIT THEN 1+ AGAIN ;
868: : (prune) ( name len head -- )
869: dup >r (find) ?dup IF r> BEGIN dup @ WHILE 2dup @ = IF
870: >r @ r> ! EXIT THEN @ REPEAT 2drop ELSE r> drop THEN ;
871: : prune ( name len -- ) last (prune) ;
872: : set-property ( data dlen name nlen phandle -- )
873: true to encode-first?
874: get-current >r node>properties @ set-current
875: 2dup prune $2CONSTANT r> set-current ;
876: : delete-property ( name nlen -- )
877: get-node get-current >r node>properties @ set-current
878: prune r> set-current ;
879: : property ( data dlen name nlen -- ) get-node set-property ;
880: : get-property ( str len phandle -- true | data dlen false )
881: ?dup 0= IF cr cr cr ." get-property for " type ." on zero phandle"
882: cr cr true EXIT THEN
883: node>properties @ voc-find dup IF link> execute false ELSE drop true THEN ;
884: : get-package-property ( str len phandle -- true | data dlen false )
885: get-property ;
886: : get-my-property ( str len -- true | data dlen false )
887: my-self ihandle>phandle get-property ;
888: : get-parent-property ( str len -- true | data dlen false )
889: my-parent ihandle>phandle get-property ;
890: : get-inherited-property ( str len -- true | data dlen false )
891: my-self ihandle>phandle
892: BEGIN 3dup get-property 0=
893: IF \ Property found
894: rot drop rot drop rot drop false EXIT
895: THEN
896: parent 0=
897: IF
898: nip nip true EXIT
899: THEN
900: AGAIN ;
901: 20 CONSTANT indent-prop
902: : .prop-int ( str len -- )
903: space
904: 400 min 0
905: ?DO
906: i over + dup ( str act-addr act-addr )
907: c@ 2 0.r 1+ dup c@ 2 0.r 1+ dup c@ 2 0.r 1+ c@ 2 0.r ( str )
908: i c and c = IF \ check for multipleof 16 bytes
909: cr indent @ indent-prop + 1+ 0 \ linefeed + indent
910: DO
911: space \ print spaces
912: LOOP
913: ELSE
914: space space \ print two spaces
915: THEN
916: 4 +LOOP
917: drop
918: ;
919: : .prop-bytes ( str len -- )
920: 2dup -4 and .prop-int ( str len )
921: dup 3 and dup IF ( str len len%4 )
922: >r -4 and + r> ( str' len%4 )
923: bounds ( str' str'+len%4 )
924: DO
925: i c@ 2 0.r \ Print last 3 bytes
926: LOOP
927: ELSE
928: 3drop
929: THEN
930: ;
931: : .prop-string ( str len )
932: 2dup space type
933: cr indent @ indent-prop + 0 DO space LOOP \ Linefeed
934: .prop-bytes
935: ;
936: : .propbytes ( xt -- )
937: execute dup
938: IF
939: over cell- @ execute
940: ELSE
941: 2drop
942: THEN
943: ;
944: : .property ( lfa -- )
945: cr indent @ 0
946: ?DO
947: space
948: LOOP
949: link> dup >name name>string 2dup type nip ( len )
950: indent-prop swap - ( xt 20-len )
951: dup 0< IF drop 0 THEN 0 ( xt number-of-space 0 )
952: ?DO
953: space
954: LOOP
955: .propbytes
956: ;
957: : (.properties) ( phandle -- )
958: node>properties @ cell+ @ BEGIN dup WHILE dup .property @ REPEAT drop ;
959: : .properties ( -- )
960: get-node (.properties) ;
961: : next-property ( str len phandle -- false | str' len' true )
962: ?dup 0= IF device-tree @ THEN \ XXX: is this line required?
963: node>properties @
964: >r 2dup 0= swap 0= or IF 2drop r> cell+ ELSE r> voc-find THEN
965: @ dup IF link>name name>string true THEN ;
966: : encode-start ( -- prop 0 )
967: ['] .prop-int compile,
968: false to encode-first?
969: here 0
970: ;
971: : encode-int ( val -- prop prop-len )
972: encode-first? IF
973: ['] .prop-int compile, \ Execution token for print
974: false to encode-first?
975: THEN
976: here swap lbsplit c, c, c, c, /l
977: ;
978: : encode-bytes ( str len -- prop-addr prop-len )
979: encode-first? IF
980: ['] .prop-bytes compile, \ Execution token for print
981: false to encode-first?
982: THEN
983: here over 2dup 2>r allot swap move 2r>
984: ;
985: : encode-string ( str len -- prop-addr prop-len )
986: encode-first? IF
987: ['] .prop-string compile, \ Execution token for print
988: false to encode-first?
989: THEN
990: encode-bytes 0 c, char+
991: ;
992: : encode+ ( prop1-addr prop1-len prop2-addr prop2-len -- prop-addr prop-len )
993: nip + ;
994: : encode-int+ encode-int encode+ ;
995: : encode-64 xlsplit encode-int rot encode-int+ ;
996: : encode-64+ encode-64 encode+ ;
997: : device-name encode-string s" name" property ;
998: : device-type encode-string s" device_type" property ;
999: : model encode-string s" model" property ;
1000: : compatible encode-string s" compatible" property ;
1001: : #address-cells s" #address-cells" rot parent get-property
1002: ABORT" parent doesn't have a #address-cells property!"
1003: decode-int nip nip
1004: ;
1005: : my-#address-cells ( -- #address-cells )
1006: get-node #address-cells
1007: ;
1008: : child-#address-cells ( -- #address-cells )
1009: s" #address-cells" get-node get-property
1010: ABORT" node doesn't have a #address-cells property!"
1011: decode-int nip nip
1012: ;
1013: : child-#size-cells ( -- #address-cells )
1014: s" #size-cells" get-node get-property
1015: ABORT" node doesn't have a #size-cells property!"
1016: decode-int nip nip
1017: ;
1018: : encode-phys ( phys.hi ... phys.low -- prop len )
1019: encode-first? IF encode-start ELSE here 0 THEN
1020: my-#address-cells 0 ?DO rot encode-int+ LOOP
1021: ;
1022: : encode-child-phys ( phys.hi ... phys.low -- prop len )
1023: encode-first? IF encode-start ELSE here 0 THEN
1024: child-#address-cells 0 ?DO rot encode-int+ LOOP
1025: ;
1026: : encode-child-size ( size.hi ... size.low -- prop len )
1027: encode-first? IF encode-start ELSE here 0 THEN
1028: child-#size-cells 0 ?DO rot encode-int+ LOOP
1029: ;
1030: : decode-phys
1031: my-#address-cells BEGIN dup WHILE 1- >r decode-int r> swap >r REPEAT drop
1032: my-#address-cells BEGIN dup WHILE 1- r> swap REPEAT drop ;
1033: : decode-phys-and-drop
1034: my-#address-cells BEGIN dup WHILE 1- >r decode-int r> swap >r REPEAT 3drop
1035: my-#address-cells BEGIN dup WHILE 1- r> swap REPEAT drop ;
1036: : reg >r encode-phys r> encode-int+ s" reg" property ;
1037: : >space node>space @ ;
1038: : >space? node>space? @ ;
1039: : >address dup >r #address-cells dup 3 > IF r@ node>addr3 @ swap THEN
1040: dup 2 > IF r@ node>addr2 @ swap THEN
1041: 1 > IF r@ node>addr1 @ THEN r> drop ;
1042: : >unit dup >r >address r> >space ;
1043: : my-space ( -- phys.hi )
1044: my-self ihandle>phandle >space ;
1045: : my-address my-self ihandle>phandle >address ;
1046: : my-unit my-self ihandle>phandle >unit ;
1047: : my-unit-64 ( -- phys.lo+1|phys.lo )
1048: my-unit ( phys.lo ... phys.hi )
1049: my-self ihandle>phandle #address-cells ( phys.lo ... phys.hi #ad-cells )
1050: CASE
1051: 1 OF EXIT ENDOF
1052: 2 OF lxjoin EXIT ENDOF
1053: 3 OF drop lxjoin EXIT ENDOF
1054: dup OF 2drop lxjoin EXIT ENDOF
1055: ENDCASE
1056: ;
1057: : set-space get-node dup >r node>space ! true r> node>space? ! ;
1058: : set-address my-#address-cells 1 ?DO
1059: get-node node>space i cells + ! LOOP ;
1060: : set-unit set-space set-address ;
1061: : set-unit-64 ( phys.lo|phys.hi -- )
1062: my-#address-cells 2 <> IF
1063: ." set-unit-64: #address-cells <> 2 " abort
1064: THEN
1065: xlsplit set-unit
1066: ;
1067: : set-args ( arg-str len unit-str len -- )
1068: s" decode-unit" get-parent $call-static set-unit set-my-args ;
1069: : $cat-unit dup parent 0= IF drop EXIT THEN
1070: dup >space? not IF drop EXIT THEN
1071: dup >r >unit s" encode-unit" r> parent $call-static dup IF
1072: dup >r here swap move s" @" $cat here r> $cat
1073: ELSE 2drop THEN ;
1074: : node>name dup >r s" name" rot get-property IF r> (u.) ELSE 1- r> drop THEN ;
1075: : node>qname dup node>name rot ['] $cat-unit CATCH IF drop THEN ;
1076: : node>path here 0 rot BEGIN dup WHILE dup parent REPEAT 2drop
1077: dup 0= IF [char] / c, THEN
1078: BEGIN dup WHILE [char] / c, node>qname here over allot swap move
1079: REPEAT drop here 2dup - allot over - ;
1080: : interposed? ( ihandle -- flag )
1081: dup instance>parent @ dup 0= IF 2drop false EXIT THEN
1082: ihandle>phandle swap ihandle>phandle parent <> ;
1083: : instance>qname dup >r interposed? IF s" %" ELSE 0 0 THEN
1084: r@ ihandle>phandle node>qname $cat r> instance>args 2@
1085: dup IF 2>r s" :" $cat 2r> $cat ELSE 2drop THEN ;
1086: : instance>qpath \ With interposed nodes.
1087: here 0 rot BEGIN dup WHILE dup instance>parent @ REPEAT 2drop
1088: dup 0= IF [char] / c, THEN
1089: BEGIN dup WHILE [char] / c, instance>qname here over allot swap move
1090: REPEAT drop here 2dup - allot over - ;
1091: : instance>path \ Without interposed nodes.
1092: here 0 rot BEGIN dup WHILE
1093: dup interposed? 0= IF dup THEN instance>parent @ REPEAT 2drop
1094: dup 0= IF [char] / c, THEN
1095: BEGIN dup WHILE [char] / c, instance>qname here over allot swap move
1096: REPEAT drop here 2dup - allot over - ;
1097: : .node node>path type ;
1098: : pwd get-node .node ;
1099: : .instance instance>qpath type ;
1100: : .chain dup instance>parent @ ?dup IF recurse THEN
1101: cr dup . instance>qname type ;
1102: defer find-node
1103: : set-alias ( alias-name len device-name len -- )
1104: encode-string
1105: 2swap s" /aliases" find-node ?dup IF
1106: set-property
1107: ELSE
1108: 4drop
1109: THEN
1110: ;
1111: : find-alias ( alias-name len -- false | dev-path len )
1112: s" /aliases" find-node dup IF
1113: get-property 0= IF 1- dup 0= IF nip THEN ELSE false THEN
1114: THEN ;
1115: : .alias ( alias-name len -- )
1116: find-alias dup IF type ELSE ." no alias available" THEN ;
1117: : (.print-alias) ( lfa -- )
1118: link> dup >name name>string
1119: 2dup s" name" string=ci IF 2drop drop
1120: ELSE cr type space ." : " execute type
1121: THEN ;
1122: : (.list-alias) ( phandle -- )
1123: node>properties @ cell+ @ BEGIN dup WHILE dup (.print-alias) @ REPEAT drop ;
1124: : list-alias ( -- )
1125: s" /aliases" find-node dup IF (.list-alias) THEN ;
1126: : devalias ( "{alias-name}<>{device-specifier}<cr>" -- )
1127: parse-word parse-word dup IF set-alias
1128: ELSE 2drop dup IF .alias
1129: ELSE 2drop list-alias THEN THEN ;
1130: : sub-alias ( arg-str arg-len -- arg' len' | false )
1131: 2dup
1132: 2dup [char] / findchar ?dup IF ELSE 2dup [char] : findchar THEN
1133: ( a l a l [p] -1|0 ) IF nip dup ELSE 2drop 0 THEN >r
1134: find-alias ?dup IF ( a l a' p' -- R:p | a' l' -- R:0 )
1135: r@ IF 2swap r@ - swap r> + swap $cat strdup ( a" l-p+p' -- )
1136: ELSE ( a' l' -- R:0 ) r> drop ( a' l' -- ) THEN
1137: ELSE ( a l -- R:p | -- R:0 ) r> IF 2drop THEN false ( 0 -- ) THEN
1138: ;
1139: : de-alias ( arg-str arg-len -- arg' len' )
1140: BEGIN over c@ [char] / <> dup IF drop 2dup sub-alias ?dup THEN
1141: WHILE 2swap 2drop REPEAT
1142: ;
1143: : +indent ( not-last? -- )
1144: IF s" | " ELSE s" " THEN $indent indent @ + swap move 4 indent +! ;
1145: : -indent ( -- ) -4 indent +! ;
1146: : ls-node ( node -- )
1147: cr $indent indent @ type
1148: dup peer IF ." |-- " ELSE ." +-- " THEN node>qname type ;
1149: : (ls) ( node -- )
1150: child BEGIN dup WHILE dup ls-node dup child IF
1151: dup peer +indent dup recurse -indent THEN peer REPEAT drop ;
1152: : ls ( -- ) get-node dup cr node>path type (ls) 0 indent ! ;
1153: : show-devs ( {device-specifier}<eol> -- )
1154: skipws 0 parse dup IF de-alias ELSE 2drop s" /" THEN ( str len )
1155: find-node dup 0= ABORT" No such device path" (ls)
1156: ;
1157: VARIABLE interpose-node
1158: 2VARIABLE interpose-args
1159: : interpose ( arg len phandle -- ) interpose-node ! interpose-args 2! ;
1160: : open-node ( arg len phandle -- ihandle | 0 )
1161: current-node @ >r set-node create-instance set-my-args
1162: s" open" ['] $call-my-method CATCH IF 2drop true THEN
1163: 0= IF my-self destroy-instance 0 to my-self THEN
1164: my-self my-parent to my-self r> set-node
1165: interpose-node @ IF my-self >r to my-self
1166: interpose-args 2@ interpose-node @
1167: interpose-node off recurse r> to my-self THEN ;
1168: : close-node ( ihandle -- )
1169: my-self >r to my-self
1170: s" close" ['] $call-my-method CATCH IF 2drop THEN
1171: my-self destroy-instance r> to my-self ;
1172: : close-dev ( ihandle -- )
1173: my-self >r to my-self
1174: BEGIN my-self WHILE my-parent my-self close-node to my-self REPEAT
1175: r> to my-self ;
1176: : new-device ( -- )
1177: my-self new-node node>instance @ dup to my-self instance>parent !
1178: get-node my-self instance>node ! ;
1179: : finish-device ( -- )
1180: finish-node my-parent my-self max-instance-size free-mem to my-self ;
1181: : split ( str len char -- left len right len )
1182: >r 2dup r> findchar IF >r over r@ 2swap r> 1+ /string ELSE 0 0 THEN ;
1183: : generic-decode-unit ( str len ncells -- addr.lo ... addr.hi )
1184: dup >r -rot BEGIN r@ WHILE r> 1- >r [char] , split 2swap
1185: $number IF 0 THEN r> swap >r >r REPEAT r> 3drop
1186: BEGIN dup WHILE 1- r> swap REPEAT drop ;
1187: : generic-encode-unit ( addr.lo ... addr.hi ncells -- str len )
1188: 0 0 rot ?dup IF 0 ?DO rot (u.) $cat s" ," $cat LOOP 1- THEN ;
1189: : hex-decode-unit ( str len ncells -- addr.lo ... addr.hi )
1190: base @ >r hex generic-decode-unit r> base ! ;
1191: : hex-encode-unit ( addr.lo ... addr.hi ncells -- str len )
1192: base @ >r hex generic-encode-unit r> base ! ;
1193: : handle-leading-/ ( path len -- path' len' )
1194: dup IF over c@ [char] / = IF 1 /string device-tree @ set-node THEN THEN ;
1195: : match-name ( name len node -- match? )
1196: over 0= IF 3drop true EXIT THEN
1197: s" name" rot get-property IF 2drop false EXIT THEN
1198: 1- string=ci ; \ XXX should use decode-string
1199: 0 VALUE #search-unit CREATE search-unit 4 cells allot
1200: : match-unit ( node -- match? )
1201: node>space search-unit #search-unit 0 ?DO 2dup @ swap @ <> IF
1202: 2drop false UNLOOP EXIT THEN cell+ swap cell+ swap LOOP 2drop true ;
1203: : match-node ( name len node -- match? )
1204: dup >r match-name r> match-unit and ; \ XXX e3d
1205: : find-kid ( name len -- node|0 )
1206: dup -1 = IF \ are we supposed to stay in the same node? -> resolve-relatives
1207: 2drop get-node
1208: ELSE
1209: get-node child >r BEGIN r@ WHILE 2dup r@ match-node
1210: IF 2drop r> EXIT THEN r> peer >r REPEAT
1211: r> 3drop false
1212: THEN ;
1213: : set-search-unit ( unit len -- )
1214: dup 0= IF to #search-unit drop EXIT THEN
1215: s" #address-cells" get-node get-property THROW
1216: decode-int to #search-unit 2drop
1217: s" decode-unit" get-node $call-static
1218: #search-unit 0 ?DO search-unit i cells + ! LOOP ;
1219: : resolve-relatives ( path len -- path' len' )
1220: 2dup 2 = swap s" .." comp 0= and IF
1221: get-node parent ?dup IF
1222: set-node drop -1
1223: ELSE
1224: s" Already in root node." type
1225: THEN
1226: THEN
1227: 2dup 1 = swap c@ [CHAR] . = and IF
1228: drop -1
1229: THEN
1230: ;
1231: : find-component ( path len -- path' len' args len node|0 )
1232: [char] / split 2swap ( path'. component. )
1233: [char] : split 2swap ( path'. args. node-addr. )
1234: [char] @ split ['] set-search-unit CATCH IF 2drop 2drop 0 EXIT THEN
1235: resolve-relatives find-kid ;
1236: : .find-node ( path len -- phandle|0 )
1237: current-node @ >r
1238: handle-leading-/ current-node @ 0= IF 2drop r> set-node 0 EXIT THEN
1239: BEGIN dup WHILE \ handle one component:
1240: find-component ( path len args len node ) dup 0= IF
1241: 3drop 2drop r> set-node 0 EXIT THEN
1242: set-node 2drop REPEAT 2drop
1243: get-node r> set-node ;
1244: ' .find-node to find-node
1245: : find-node ( path len -- phandle|0 ) de-alias find-node ;
1246: : delete-node ( phandle -- )
1247: dup node>parent @ node>child @ ( phandle 1st peer )
1248: 2dup = IF
1249: node>peer @ swap node>parent @ node>child !
1250: EXIT
1251: THEN
1252: dup node>peer @
1253: BEGIN 2 pick 2dup <> WHILE
1254: drop
1255: nip dup node>peer @
1256: dup 0= IF 2drop drop unloop EXIT THEN
1257: REPEAT
1258: drop
1259: node>peer @ swap node>peer !
1260: drop
1261: ;
1262: : open-dev ( path len -- ihandle|0 )
1263: de-alias current-node @ >r
1264: handle-leading-/ current-node @ 0= IF 2drop r> set-node 0 EXIT THEN
1265: my-self >r 0 to my-self
1266: 0 0 >r >r BEGIN dup WHILE \ handle one component:
1267: ( arg len ) r> r> get-node open-node to my-self
1268: find-component ( path len args len node ) dup 0= IF
1269: 3drop 2drop my-self close-dev r> to my-self r> set-node 0 EXIT THEN
1270: set-node >r >r REPEAT 2drop
1271: r> r> get-node open-node to my-self
1272: my-self r> to my-self r> set-node ;
1273: : select-dev open-dev dup to my-self ihandle>phandle set-node ;
1274: : find-device ( str len -- ) \ set as active node
1275: find-node dup 0= ABORT" No such device path" set-node ;
1276: : dev skipws 0 parse find-device ;
1277: : (lsprop) ( node --)
1278: dup cr $indent indent @ type ." node: " node>qname type
1279: false +indent (.properties) cr -indent ;
1280: : (show-children) ( node -- )
1281: child BEGIN dup WHILE
1282: dup (lsprop) dup child IF false +indent dup recurse -indent THEN peer
1283: REPEAT drop
1284: ;
1285: : lsprop ( {device-specifier}<eol> -- )
1286: skipws 0 parse dup IF de-alias ELSE 2drop s" /" THEN
1287: find-device get-node dup dup
1288: cr ." node: " node>path type (.properties) cr (show-children) 0 indent ! ;
1289: : (node>path) node>path ;
1290: : node>path ( phandle -- str len )
1291: node>path dup allot
1292: ;
1293: 0 VALUE packages
1294: : find-package ( name len -- false | phandle true )
1295: 0 >r packages child BEGIN dup WHILE dup >r node>name 2over string=ci r> swap
1296: IF r> drop dup >r THEN peer REPEAT 3drop r> dup IF true THEN ;
1297: : open-package ( arg len phandle -- ihandle | 0 ) open-node ;
1298: : close-package ( ihandle -- ) close-node ;
1299: : $open-package ( arg len name len -- ihandle | 0 )
1300: find-package IF open-package ELSE 2drop false THEN ;
1301: : pci-address-type ( node address prop_type -- type )
1302: -rot 2 pick ( prop_type node address prop_type )
1303: 0= IF
1304: swap s" reg" rot get-property ( prop_type address data dlen false )
1305: ELSE
1306: swap s" assigned-addresses" rot get-property ( prop_type address data dlen false )
1307: THEN
1308: IF 2drop -1 EXIT THEN 4 / 5 /
1309: 0 DO
1310: dup l@ FF AND 0<> ( prop_type address data cfgspace_offset? )
1311: 3 pick 0= ( prop_type address data cfgspace_offset? reg_prop? )
1312: AND NOT IF
1313: 2dup 8 + ( prop_type address data address data' )
1314: 2dup l@ 2 pick 8 + l@ + <= -rot l@ >= and IF
1315: l@ 03000000 and 18 rshift nip
1316: dup 3 = IF 1- THEN
1317: swap drop ( type )
1318: UNLOOP EXIT
1319: THEN
1320: THEN
1321: 4 5 * +
1322: LOOP
1323: 3drop -1
1324: ;
1325: : (range-read-cells) ( range-addr #cells -- range-value )
1326: 1 = IF l@ ELSE @ THEN
1327: ;
1328: : (map-one-range) ( type range pnac nsc nac address -- address true | address false )
1329: over 3 = 5 pick l@ 3000000 and 18 rshift 7 pick <> and IF
1330: >r 2drop 3drop r> false EXIT
1331: THEN
1332: 4 pick 4 pick 3 pick + 4 * +
1333: 3 pick
1334: (range-read-cells)
1335: 5 pick 3 pick 3 = IF
1336: 4 +
1337: THEN
1338: 3 pick
1339: (range-read-cells)
1340: dup >r dup 3 pick > >r + over <= r> or IF
1341: >r 2drop 3drop r> r> drop false EXIT
1342: THEN
1343: dup r> -
1344: 5 pick 5 pick 3 = IF
1345: 4 +
1346: THEN
1347: 3 pick 4 * +
1348: 5 pick
1349: (range-read-cells)
1350: + >r 3drop 3drop r> true
1351: ;
1352: : translate-address ( node address -- address )
1353: 2dup 1 pci-address-type ( node address type )
1354: dup -1 = IF
1355: drop 2dup 0 pci-address-type ( node address type )
1356: THEN
1357: rot parent BEGIN
1358: dup parent 0= IF 2drop EXIT THEN
1359: s" #address-cells" 2 pick get-property 2drop l@ >r \ nac
1360: s" #size-cells" 2 pick get-property 2drop l@ >r \ nsc
1361: s" #address-cells" 2 pick parent get-property 2drop l@ >r \ pnac
1362: -rot ( node address type )
1363: s" ranges" 4 pick get-property IF
1364: 3drop
1365: ABORT" no ranges property; not translatable"
1366: THEN
1367: r> r> r> 3 roll
1368: 4 / >r 3dup + + >r 5 roll r> r> swap / 0 ?DO
1369: 6dup (map-one-range) IF
1370: nip leave
1371: THEN
1372: nip
1373: 4 roll
1374: 4 pick 4 pick 4 pick + + 4 * + 4 -roll
1375: LOOP
1376: >r 2drop 2drop r> ( node type address )
1377: swap rot parent ( address type node )
1378: dup 0=
1379: UNTIL
1380: ;
1381: : translate-my-address ( address -- address' )
1382: get-node swap translate-address
1383: ;
1384: : find-substr ( basestr-ptr basestr-len substr-ptr substr-len -- pos )
1385: dup 0 = IF
1386: 2drop 2drop 0 exit THEN
1387: dup 3 pick <= IF
1388: 2 pick over - 1+ 0 DO dup 0 DO
1389: over i + c@ 4 pick j + i + c@ = IF
1390: dup i 1+ = IF
1391: 2drop 2drop j unloop unloop exit THEN
1392: ELSE leave THEN
1393: LOOP LOOP
1394: THEN
1395: 2drop nip
1396: ;
1397: : find-isubstr ( basestr-ptr basestr-len substr-ptr substr-len -- pos )
1398: dup 0 = IF
1399: 2drop 2drop 0 exit THEN
1400: dup 3 pick <= IF
1401: 2 pick over - 1+ 0 DO dup 0 DO
1402: over i + c@ lcc 4 pick j + i + c@ lcc = IF
1403: dup i 1+ = IF
1404: 2drop 2drop j unloop unloop exit THEN
1405: ELSE leave THEN
1406: LOOP LOOP
1407: THEN
1408: 2drop nip
1409: ;
1410: : find-nextline ( str-ptr str-len -- pos )
1411: dup 0 ?DO over i + c@ CASE
1412: 0a OF
1413: dup 1- i = IF
1414: 2drop i 1+ unloop exit THEN
1415: over i 1+ + c@ 0d = IF
1416: 2drop i 2+ ELSE
1417: 2drop i 1+ THEN
1418: unloop exit
1419: ENDOF
1420: 0d OF
1421: dup 1- i = IF
1422: 2drop i 1+ unloop exit THEN
1423: over i 1+ + c@ 0a = IF
1424: 2drop i 2+ ELSE
1425: 2drop i 1+ THEN
1426: unloop exit
1427: ENDOF
1428: ENDCASE LOOP nip
1429: ;
1430: : string-at ( str1-ptr str1-len pos -- str2-ptr str2-len )
1431: -rot 2 pick - -rot swap chars + swap
1432: ;
1433: : string-cat ( addr1 len1 addr2 len2 -- addr1 len1+len2 )
1434: rot dup >r over + -rot
1435: 3 pick r> chars + -rot
1436: 0 ?DO
1437: 2dup c@ swap c!
1438: char+ swap char+ swap
1439: LOOP 2drop
1440: ;
1441: : char-cat ( addr len character -- addr len+1 )
1442: -rot 2dup >r >r 1+ rot r> r> chars + c!
1443: ;
1444: : overlap ( src dest size -- true|false )
1445: 3dup over + within IF 3drop true ELSE rot tuck + within THEN
1446: ;
1447: : parse-2int ( str len -- val.lo val.hi )
1448: [char] , split ?dup IF eval ELSE drop 0 THEN
1449: -rot ?dup IF eval ELSE drop 0 THEN
1450: ;
1451: : cpeek ( addr -- false | byte true ) c@ true ;
1452: : cpoke ( byte addr -- success? ) c! true ;
1453: : wpeek ( addr -- false | word true ) w@ true ;
1454: : wpoke ( word addr -- success? ) w! true ;
1455: : lpeek ( addr -- false | lword true ) l@ true ;
1456: : lpoke ( lword addr -- success? ) l! true ;
1457: defer reboot ( -- )
1458: defer halt ( -- )
1459: defer disable-watchdog ( -- )
1460: defer reset-watchdog ( -- )
1461: defer set-watchdog ( +n -- )
1462: defer set-led ( type instance state -- status )
1463: defer get-flashside ( -- side )
1464: defer set-flashside ( side -- status )
1465: defer read-bootlist ( -- )
1466: defer furnish-boot-file ( -- adr len )
1467: defer set-boot-file ( adr len -- )
1468: defer mfg-mode? ( -- flag )
1469: defer of-prompt? ( -- flag )
1470: defer debug-boot? ( -- flag )
1471: defer bmc-version ( -- adr len )
1472: defer cursor-on ( -- )
1473: defer cursor-off ( -- )
1474: : nop-reboot ( -- ) ." reboot not available" abort ;
1475: : nop-halt ( -- ) ." halt not available" abort ;
1476: : nop-disable-watchdog ( -- ) ;
1477: : nop-reset-watchdog ( -- ) ;
1478: : nop-set-watchdog ( +n -- ) drop ;
1479: : nop-set-led ( type instance state -- status ) drop drop drop ;
1480: : nop-get-flashside ( -- side ) ." Cannot get flashside" cr ABORT ;
1481: : nop-set-flashside ( side -- status ) ." Cannot set flashside" cr ABORT ;
1482: : nop-read-bootlist ( -- ) ;
1483: : nop-furnish-bootfile ( -- adr len ) s" net:" ;
1484: : nop-set-boot-file ( adr len -- ) 2drop ;
1485: : nop-mfg-mode? ( -- flag ) false ;
1486: : nop-of-prompt? ( -- flag ) false ;
1487: : nop-debug-boot? ( -- flag ) false ;
1488: : nop-bmc-version ( -- adr len ) s" XXXXX" ;
1489: : nop-cursor-on ( -- ) ;
1490: : nop-cursor-off ( -- ) ;
1491: ' nop-reboot to reboot
1492: ' nop-halt to halt
1493: ' nop-disable-watchdog to disable-watchdog
1494: ' nop-reset-watchdog to reset-watchdog
1495: ' nop-set-watchdog to set-watchdog
1496: ' nop-set-led to set-led
1497: ' nop-get-flashside to get-flashside
1498: ' nop-set-flashside to set-flashside
1499: ' nop-read-bootlist to read-bootlist
1500: ' nop-furnish-bootfile to furnish-boot-file
1501: ' nop-set-boot-file to set-boot-file
1502: ' nop-mfg-mode? to mfg-mode?
1503: ' nop-of-prompt? to of-prompt?
1504: ' nop-debug-boot? to debug-boot?
1505: ' nop-bmc-version to bmc-version
1506: ' nop-cursor-on to cursor-on
1507: ' nop-cursor-off to cursor-off
1508: : reset-all reboot ;
1509: 10000000 value load-base
1510: 2000000 value flash-load-base
1511: false constant <debug-dummy>
1512: 12 34 2constant (2constant) ' (2constant) cell+ @
1513: here 0
1514: dup , dup , dup , dup , dup ,
1515: over 7 cells + ,
1516: dup , dup , dup , dup , dup ,
1517: dup , drop
1518: current-node ! \ FAKE!
1519: 12 instance value (instancevalue) ' (instancevalue) cell+ @
1520: instance variable (instancevariable) ' (instancevariable) cell+ @
1521: instance defer (instancedefer) ' (instancedefer) cell+ @
1522: 0 current-node !
1523: forget <debug-dummy>
1524: constant <instancedefer>
1525: constant <instancevariable>
1526: constant <instancevalue>
1527: constant <2constant>
1528: : xt>name ( xt -- str len )
1529: BEGIN
1530: cell - dup c@ 0 2 within IF
1531: dup 2+ swap 1+ c@ exit
1532: THEN
1533: AGAIN
1534: ;
1535: cell -1 * CONSTANT -cell
1536: : cell- ( n -- n-cell-size )
1537: [ cell -1 * ] LITERAL +
1538: ;
1539: : find-xt-addr ( addr -- xt )
1540: BEGIN
1541: dup @ <colon> = IF
1542: EXIT
1543: THEN
1544: cell-
1545: AGAIN
1546: ;
1547: : (.immediate) ( xt -- )
1548: xt>name drop 2 - c@ \ skip len and flags
1549: immediate? IF
1550: ." IMMEDIATE"
1551: THEN
1552: ;
1553: : (.xt) ( xt -- )
1554: xt>name type
1555: ;
1556: : trace-back ( )
1557: 1
1558: BEGIN
1559: cr dup dup . ." : " rpick dup . ." : "
1560: ['] tib here within IF
1561: dup rpick find-xt-addr (.xt)
1562: THEN
1563: 1+ dup rdepth 5 - >= IF cr drop EXIT THEN
1564: AGAIN
1565: ;
1566: VARIABLE see-my-type-column
1567: : (see-my-type) ( indent limit xt str len -- indent limit xt )
1568: dup see-my-type-column @ + dup 50 >= IF
1569: -rot over " " comp 0= IF
1570: 2drop see-my-type-column !
1571: ELSE
1572: rot drop ( indent limit xt str len )
1573: 2 pick (u.) dup -rot cr type ( indent limit xt str len xt-len )
1574: " :" type 1+ ( indent limit xt str len prefix-len )
1575: 5 pick dup spaces + ( indent limit xt str len prefix-len )
1576: over + see-my-type-column ! ( indent limit xt str len )
1577: type
1578: THEN ( indent limit xt )
1579: ELSE
1580: see-my-type-column ! type ( indent limit xt )
1581: THEN
1582: ;
1583: : (see-my-type-init) ( -- )
1584: ffff see-my-type-column ! \ just enforce a new line
1585: ;
1586: : (see-colon-body) ( indent limit xt -- indent limit xt )
1587: (see-my-type-init) \ enforce new line
1588: BEGIN ( indent limit xt )
1589: cell+ 2dup <>
1590: over @
1591: dup <semicolon> <>
1592: rot and ( indent limit xt @xt flag )
1593: WHILE ( indent limit xt @xt )
1594: xt>name (see-my-type) " " (see-my-type)
1595: dup @ ( indent limit xt @xt)
1596: CASE
1597: <0branch> OF cell+ dup @
1598: over + cell+ dup >r
1599: (u.) (see-my-type) r> ( indent limit xt target)
1600: 2dup < IF
1601: over 4 pick 3 + -rot recurse
1602: nip nip nip cell- ( indent limit xt )
1603: ELSE
1604: drop ( indent limit xt )
1605: THEN
1606: (see-my-type-init) ENDOF \ enforce new line
1607: <branch> OF cell+ dup @ over + cell+ (u.)
1608: (see-my-type) " " (see-my-type) ENDOF
1609: <do?do> OF cell+ dup @ (u.) (see-my-type)
1610: " " (see-my-type) ENDOF
1611: <lit> OF cell+ dup @ (u.) (see-my-type)
1612: " " (see-my-type) ENDOF
1613: <dotick> OF cell+ dup @ xt>name (see-my-type)
1614: " " (see-my-type) ENDOF
1615: <doloop> OF cell+ dup @ (u.) (see-my-type)
1616: " " (see-my-type) ENDOF
1617: <doleave> OF cell+ dup @ over + cell+ (u.)
1618: (see-my-type) " " (see-my-type) ENDOF
1619: <do?leave> OF cell+ dup @ over + cell+ (u.)
1620: (see-my-type) " " (see-my-type) ENDOF
1621: <sliteral> OF cell+ " """ (see-my-type) dup count dup >r
1622: (see-my-type) " """ (see-my-type)
1623: " " (see-my-type)
1624: r> -cell and + ENDOF
1625: ENDCASE
1626: REPEAT
1627: drop
1628: ;
1629: : (see-colon) ( xt -- )
1630: (see-my-type-init)
1631: 1 swap 0 swap ( indent limit xt )
1632: " : " (see-my-type) dup xt>name (see-my-type)
1633: rot drop 4 -rot (see-colon-body) ( indent limit xt )
1634: rot drop 1 -rot (see-my-type-init) " ;" (see-my-type)
1635: 3drop
1636: ;
1637: : (see-create) ( xt -- )
1638: dup cell+ @
1639: CASE
1640: <2constant> OF
1641: dup cell+ cell+ dup @ swap cell+ @ . . ." 2CONSTANT "
1642: ENDOF
1643: <instancevalue> OF
1644: dup cell+ cell+ @ . ." INSTANCE VALUE "
1645: ENDOF
1646: <instancevariable> OF
1647: ." INSTANCE VARIABLE "
1648: ENDOF
1649: dup OF
1650: ." CREATE "
1651: ENDOF
1652: ENDCASE
1653: (.xt)
1654: ;
1655: : (see) ( xt -- )
1656: cr dup dup @
1657: CASE
1658: <variable> OF ." VARIABLE " (.xt) ENDOF
1659: <value> OF dup execute . ." VALUE " (.xt) ENDOF
1660: <constant> OF dup execute . ." CONSTANT " (.xt) ENDOF
1661: <defer> OF dup cell+ @ swap ." DEFER " (.xt) ." is " (.xt) ENDOF
1662: <alias> OF dup cell+ @ swap ." ALIAS " (.xt) ." " (.xt) ENDOF
1663: <buffer:> OF ." BUFFER: " (.xt) ENDOF
1664: <create> OF (see-create) ENDOF
1665: <colon> OF (see-colon) ENDOF
1666: dup OF ." ??? PRIM " (.xt) ENDOF
1667: ENDCASE
1668: (.immediate) cr
1669: ;
1670: : see ( "old-name<>" -- )
1671: ' (see)
1672: ;
1673: 0 value forth-ip
1674: true value trace>stepping?
1675: true value trace>print?
1676: true value trace>up?
1677: 0 value trace>depth
1678: 0 value trace>rdepth
1679: 0 value trace>recurse
1680: : trace-depth+ ( -- ) trace>depth 1+ to trace>depth ;
1681: : trace-depth- ( -- ) trace>depth 1- to trace>depth ;
1682: : stepping ( -- )
1683: true to trace>stepping?
1684: ;
1685: : tracing ( -- )
1686: false to trace>stepping?
1687: ;
1688: : trace-print-on ( -- )
1689: true to trace>print?
1690: ;
1691: : trace-print-off ( -- )
1692: false to trace>print?
1693: ;
1694: : fip-add ( n -- )
1695: forth-ip + to forth-ip
1696: ;
1697: 0 value debug-last-xt
1698: 0 value debug-last-xt-content
1699: : trace-print ( -- )
1700: forth-ip cr u. ." : "
1701: forth-ip @
1702: dup ['] breakpoint = IF drop debug-last-xt-content THEN
1703: xt>name type ." "
1704: ." ( " .s ." ) | "
1705: ;
1706: : trace-interpret ( -- )
1707: rdepth 1- to trace>rdepth
1708: BEGIN
1709: depth . [char] > dup emit emit space
1710: source expect ( str len )
1711: ['] interpret catch print-status
1712: AGAIN
1713: ;
1714: : trace-xt ( xt -- )
1715: trace>recurse IF
1716: r> drop \ Drop return of 'trace-xt call
1717: cell+ \ Step over ":"
1718: ELSE
1719: debug-last-xt-content <colon> = IF
1720: ['] breakpoint @ debug-last-xt ! \ Re-arm break point
1721: r> drop \ Drop return of 'trace-xt call
1722: cell+ \ Step over ":"
1723: ELSE
1724: ['] breakpoint debug-last-xt ! \ Re-arm break point
1725: 2r> 2drop
1726: THEN
1727: THEN
1728: to forth-ip
1729: true to trace>print?
1730: BEGIN
1731: trace>print? IF trace-print THEN
1732: forth-ip ( ip )
1733: trace>stepping? IF
1734: BEGIN
1735: key
1736: CASE
1737: [char] d OF dup @ @ <colon> = IF \ recurse only into colon definitions
1738: trace-depth+
1739: 1 to trace>recurse
1740: dup >r @ recurse
1741: THEN true ENDOF
1742: [char] u OF trace>depth IF tracing trace-print-off true ELSE false THEN ENDOF
1743: [char] f OF drop cr trace-interpret ENDOF \ quit trace and start interpreter FIXME rstack
1744: [char] c OF tracing true ENDOF
1745: [char] t OF trace-back false ENDOF
1746: [char] q OF drop cr quit ENDOF
1747: 20 OF true ENDOF
1748: dup OF cr ." Press d: Down into current word" cr
1749: ." Press u: Up to caller" cr
1750: ." Press f: Switch to forth interpreter, 'resume' will continue tracing" cr
1751: ." Press c: Switch to tracing" cr
1752: ." Press <space>: Execute current word" cr
1753: ." Press q: Abort execution, switch to interpreter" cr
1754: false ENDOF
1755: ENDCASE
1756: UNTIL
1757: THEN ( ip' )
1758: dup to forth-ip @ ( xt )
1759: dup ['] breakpoint = IF drop debug-last-xt-content THEN
1760: dup ( xt xt )
1761: CASE
1762: <sliteral> OF drop forth-ip cell+ dup dup c@ + -cell and to forth-ip ENDOF
1763: <dotick> OF drop forth-ip cell+ @ cell fip-add ENDOF
1764: <lit> OF drop forth-ip cell+ @ cell fip-add ENDOF
1765: <doto> OF drop forth-ip cell+ @ cell+ ! cell fip-add ENDOF
1766: <0branch> OF drop IF
1767: cell fip-add
1768: ELSE
1769: forth-ip cell+ @ cell+ fip-add THEN
1770: ENDOF
1771: <do?do> OF drop 2dup <> IF
1772: swap >r >r cell fip-add
1773: ELSE
1774: forth-ip cell+ @ cell+ fip-add 2drop THEN
1775: ENDOF
1776: <branch> OF drop forth-ip cell+ @ cell+ fip-add ENDOF
1777: <doleave> OF drop r> r> 2drop forth-ip cell+ @ cell+ fip-add ENDOF
1778: <do?leave> OF drop IF
1779: r> r> 2drop forth-ip cell+ @ cell+ fip-add
1780: ELSE
1781: cell fip-add
1782: THEN
1783: ENDOF
1784: <doloop> OF drop r> 1+ r> 2dup = IF
1785: 2drop cell fip-add
1786: ELSE >r >r
1787: forth-ip cell+ @ cell+ fip-add THEN
1788: ENDOF
1789: <do+loop> OF drop r> + r> 2dup >= IF
1790: 2drop cell fip-add
1791: ELSE >r >r
1792: forth-ip cell+ @ cell+ fip-add THEN
1793: ENDOF
1794: <semicolon> OF trace>depth 0> IF
1795: trace-depth- 1 to trace>recurse
1796: stepping drop r> recurse
1797: ELSE
1798: drop exit THEN
1799: ENDOF
1800: <exit> OF trace>depth 0> IF
1801: trace-depth- stepping drop r> recurse
1802: ELSE
1803: drop exit THEN
1804: ENDOF
1805: dup OF execute ENDOF
1806: ENDCASE
1807: forth-ip cell+ to forth-ip
1808: AGAIN
1809: ;
1810: : resume ( -- )
1811: trace>rdepth rdepth!
1812: forth-ip cell - trace-xt
1813: ;
1814: : debug-off ( -- )
1815: debug-last-xt IF
1816: debug-last-xt-content debug-last-xt ! \ Restore overwriten token
1817: 0 to debug-last-xt
1818: THEN
1819: ;
1820: : (break-entry) ( -- )
1821: debug-last-xt dup @ ['] breakpoint <> swap ( debug-addr? debug-last-xt )
1822: debug-last-xt-content swap ! \ Restore overwriten token
1823: r> drop \ Don't return to bp, but to caller
1824: debug-last-xt-content <colon> <> and IF \ Execute non colon definition
1825: debug-last-xt cr u. ." : "
1826: debug-last-xt xt>name type ." "
1827: ." ( " .s ." ) | "
1828: key drop
1829: debug-last-xt execute
1830: ELSE
1831: debug-last-xt 0 to trace>depth 0 to trace>recurse trace-xt \ Trace colon definition
1832: THEN
1833: ;
1834: ' (break-entry) to BP
1835: : debug-address ( addr -- )
1836: debug-off ( xt ) \ Remove active breakpoint
1837: dup to debug-last-xt ( xt ) \ Save token for later debug
1838: dup @ to debug-last-xt-content ( xt ) \ Save old value
1839: ['] breakpoint swap !
1840: ;
1841: : (debug ( xt -- )
1842: debug-off ( xt ) \ Remove active breakpoint
1843: dup to debug-last-xt ( xt ) \ Save token for later debug
1844: dup @ to debug-last-xt-content ( xt ) \ Save old value
1845: ['] breakpoint @ swap !
1846: ;
1847: : debug ( "old-name<>" -- )
1848: parse-word $find IF \ Get xt for old-name
1849: (debug
1850: ELSE
1851: ." undefined word " type cr
1852: THEN
1853: ;
1854: : words
1855: last @
1856: BEGIN ?dup WHILE
1857: dup cell+ char+ count type space @
1858: REPEAT
1859: ;
1860: : .calls ( xt -- )
1861: current-node @ >r 0 set-node \ only search commands, according too IEEE1275
1862: last BEGIN @ ?dup WHILE ( xt currxt )
1863: dup cell+ char+ ( xt currxt name* )
1864: dup dup c@ + 1+ aligned ( xt currxt name* CFA )
1865: dup @ <colon> = IF ( xt currxt name* CFA )
1866: BEGIN
1867: cell+ dup @ ['] semicolon <>
1868: WHILE ( xt currxt *name pos )
1869: dup @ 4 pick = IF ( xt currxt *name pos )
1870: over count type space
1871: BEGIN cell+ dup @ ['] semicolon = UNTIL cell - \ eat up other occurences
1872: THEN
1873: REPEAT
1874: THEN
1875: 2drop ( xt currxt )
1876: REPEAT
1877: drop
1878: r> set-node \ restore node
1879: ;
1880: 0 value #sift-count
1881: false value sift-compl-only
1882: : $inner-sift ( text-addr text-len LFA -- ... word-addr word-len true | false )
1883: dup cell+ char+ count \ get word name
1884: 2dup 6 pick 6 pick find-isubstr \ is there a partly match?
1885: sift-compl-only IF 0= ELSE over < THEN
1886: IF
1887: #sift-count 1+ to #sift-count \ count completions
1888: true
1889: ELSE
1890: 2drop false
1891: THEN
1892: ;
1893: : $sift ( text-addr text-len -- )
1894: current-node @ >r 0 set-node \ only search commands, according too IEEE1275
1895: sift-compl-only >r false to sift-compl-only \ all substrings, not only compl.
1896: last BEGIN @ ?dup WHILE \ walk the whole dictionary
1897: $inner-sift IF type space THEN
1898: REPEAT
1899: 2drop
1900: 0 to #sift-count \ we don't need completions here.
1901: r> to sift-compl-only \ restore previous sifting mode
1902: r> set-node \ restore node
1903: ;
1904: : sifting ( "text< >" -- )
1905: parse-word $sift
1906: ;
1907: defer '(r@)
1908: defer '(r!)
1909: 1 VALUE /(r)
1910: : (rfill) ( addr size pattern 'r! /r -- )
1911: to /(r) to '(r!) ff and
1912: dup 8 lshift or dup 10 lshift or dup 20 lshift or
1913: -rot bounds ?do dup i '(r!) /(r) +loop drop
1914: ;
1915: : (fwrmove) ( src dest size -- )
1916: >r 0 -rot r> bounds ?do + dup '(r@) i '(r!) /(r) dup +loop 2drop
1917: ;
1918: : mrmove ( src dest size -- )
1919: 3dup or or 7 AND CASE
1920: 0 OF ['] x@ ['] rx! /x ENDOF
1921: 4 OF ['] l@ ['] rl! /l ENDOF
1922: 2 OF ['] w@ ['] rw! /w ENDOF
1923: dup OF ['] c@ ['] rb! /c ENDOF
1924: ENDCASE
1925: to /(r) to '(r!) to '(r@) (fwrmove)
1926: ;
1927: : rfill ( addr size pattern -- )
1928: 3dup drop or 7 AND CASE
1929: 0 OF ['] rx! /x ENDOF
1930: 4 OF ['] rl! /l ENDOF
1931: 2 OF ['] rw! /w ENDOF
1932: dup OF ['] rb! /c ENDOF
1933: ENDCASE (rfill)
1934: ;
1935: : ([IF])
1936: BEGIN
1937: BEGIN parse-word dup 0= WHILE
1938: 2drop refill
1939: REPEAT
1940: 2dup s" [IF]" str= IF 1 throw THEN
1941: 2dup s" [ELSE]" str= IF 2 throw THEN
1942: 2dup s" [THEN]" str= IF 3 throw THEN
1943: s" \" str= IF linefeed parse 2drop THEN
1944: AGAIN
1945: ;
1946: : [IF] ( flag -- )
1947: IF exit THEN
1948: 1 BEGIN
1949: ['] ([IF]) catch
1950: CASE
1951: 1 OF 1+ ENDOF
1952: 2 OF dup 1 = if 1- then ENDOF
1953: 3 OF 1- ENDOF
1954: ENDCASE
1955: dup 0 <=
1956: UNTIL drop
1957: ; immediate
1958: : [ELSE] 0 [COMPILE] [IF] ; immediate
1959: : [THEN] ; immediate
1960: : $dnumber base @ >r decimal $number r> base ! ;
1961: : (.d) base @ >r decimal (.) r> base ! ;
1962: : (ipaddr) ( "a.b.c.d" -- FALSE | n1 n2 n3 n4 TRUE )
1963: base @ >r decimal
1964: over s" 000.000.000.000" comp 0= IF 2drop false r> base ! EXIT THEN
1965: [char] . left-parse-string $number IF 2drop false r> base ! EXIT THEN -rot
1966: [char] . left-parse-string $number IF 2drop false r> base ! EXIT THEN -rot
1967: [char] . left-parse-string $number IF 2drop false r> base ! EXIT THEN -rot
1968: $number IF false r> base ! EXIT THEN
1969: true r> base !
1970: ;
1971: : (ipformat) ( n1 n2 n3 n4 -- str len )
1972: base @ >r decimal
1973: 0 <# # # # [char] . hold drop # # # [char] . hold
1974: drop # # # [char] . hold drop # # #s #>
1975: r> base !
1976: ;
1977: : ipformat ( n1 n2 n3 n4 -- ) (ipformat) type ;
1978: deadbeef here l!
1979: here c@ de = CONSTANT ?bigendian
1980: here c@ ef = CONSTANT ?littleendian
1981: ?bigendian [IF]
1982: : l!-le >r lbflip r> l! ;
1983: : l@-le l@ lbflip ;
1984: : w!-le >r wbflip r> w! ;
1985: : w@-le w@ wbflip ;
1986: : rl!-le >r lbflip r> rl! ;
1987: : rl@-le rl@ lbflip ;
1988: : rw!-le >r wbflip r> rw! ;
1989: : rw@-le rw@ wbflip ;
1990: : l!-be l! ;
1991: : l@-be l@ ;
1992: : w!-be w! ;
1993: : w@-be w@ ;
1994: : rl!-be rl! ;
1995: : rl@-be rl@ ;
1996: : rw!-be rw! ;
1997: : rw@-be rw@ ;
1998: [ELSE]
1999: : l!-le l! ;
2000: : l@-le l@ ;
2001: : w!-le w! ;
2002: : w@-le w@ ;
2003: : rl!-le rl! ;
2004: : rl@-le rl@ ;
2005: : rw!-le rw! ;
2006: : rw@-le rw@ ;
2007: : l!-be >r lbflip r> l! ;
2008: : l@-be l@ lbflip ;
2009: : w!-be >r wbflip r> w! ;
2010: : w@-be w@ wbflip ;
2011: : rl!-be >r lbflip r> rl! ;
2012: : rl@-be rl@ lbflip ;
2013: : rw!-be >r wbflip r> rw! ;
2014: : rw@-be rw@ wbflip ;
2015: [THEN]
2016: : #join ( lo hi #bits -- x ) lshift or ;
2017: : #split ( x #bits -- lo hi ) 2dup rshift dup >r swap lshift xor r> ;
2018: : blink ;
2019: : reset-dual-emit ;
2020: : console-clean-fifo ;
2021: : bootmsg-nvupdate ;
2022: : asm-cout 2drop drop ;
2023: defer nvramlog-write-byte
2024: : .nvramlog-write-byte ( byte -- )
2025: drop
2026: ;
2027: ' .nvramlog-write-byte to nvramlog-write-byte
2028: : nvramlog-write-string ( str len -- )
2029: dup 0> IF
2030: 0 DO dup c@
2031: nvramlog-write-byte char+ LOOP
2032: ELSE
2033: drop
2034: THEN drop ;
2035: : nvramlog-write-number ( number format -- )
2036: 0 swap <# 0 ?DO # LOOP #>
2037: nvramlog-write-string ;
2038: : nvramlog-write-string-cr ( str len -- )
2039: nvramlog-write-string
2040: a nvramlog-write-byte d nvramlog-write-byte ;
2041: : log-string ( str len -- ) type ;
2042: : log-string 2drop ;
2043: create debugstr 255 allot
2044: 0 VALUE debuglen
2045: : cp ( checkpoint -- )
2046: bootmsg-cp ;
2047: : (warning) ( id level ptr len -- )
2048: dup TO debuglen
2049: debugstr swap move \ copy into buffer
2050: 0 debuglen debugstr + c! \ terminate '\0'
2051: debugstr bootmsg-warning
2052: ;
2053: : warning" ( id level [text<">] -- )
2054: postpone s" state @
2055: IF
2056: ['] (warning) compile,
2057: ELSE
2058: (warning)
2059: THEN
2060: ; immediate
2061: : (debug-cp) ( id level ptr len -- )
2062: dup TO debuglen
2063: debugstr swap move \ copy into buffer
2064: 0 debuglen debugstr + c! \ terminate '\0'
2065: debugstr bootmsg-debugcp
2066: ;
2067: : debug-cp" ( id level [text<">] -- )
2068: postpone s" state @
2069: IF
2070: ['] (debug-cp) compile,
2071: ELSE
2072: (debug-cp)
2073: THEN
2074: ; immediate
2075: : (error) ( id ptr len -- )
2076: dup TO debuglen
2077: debugstr swap move \ copy into buffer
2078: 0 debuglen debugstr + c! \ terminate '\0'
2079: debugstr bootmsg-error
2080: ;
2081: : error" ( id level [text<">] -- )
2082: postpone s" state @
2083: IF
2084: ['] (error) compile,
2085: ELSE
2086: (error)
2087: THEN
2088: ; immediate
2089: bootmsg-nvupdate
2090: 000 cp
2091: STRUCT
2092: cell FIELD >r0 cell FIELD >r1 cell FIELD >r2 cell FIELD >r3
2093: cell FIELD >r4 cell FIELD >r5 cell FIELD >r6 cell FIELD >r7
2094: cell FIELD >r8 cell FIELD >r9 cell FIELD >r10 cell FIELD >r11
2095: cell FIELD >r12 cell FIELD >r13 cell FIELD >r14 cell FIELD >r15
2096: cell FIELD >r16 cell FIELD >r17 cell FIELD >r18 cell FIELD >r19
2097: cell FIELD >r20 cell FIELD >r21 cell FIELD >r22 cell FIELD >r23
2098: cell FIELD >r24 cell FIELD >r25 cell FIELD >r26 cell FIELD >r27
2099: cell FIELD >r28 cell FIELD >r29 cell FIELD >r30 cell FIELD >r31
2100: cell FIELD >cr cell FIELD >xer cell FIELD >lr cell FIELD >ctr
2101: cell FIELD >srr0 cell FIELD >srr1 cell FIELD >dar cell FIELD >dsisr
2102: CONSTANT ciregs-size
2103: : .16 10 0.r 3 spaces ;
2104: : .8 8 spaces 8 0.r 3 spaces ;
2105: : .4regs cr 4 0 DO dup @ .16 8 cells+ LOOP drop ;
2106: : .fixed-regs
2107: cr ." R0 .. R7 R8 .. R15 R16 .. R23 R24 .. R31"
2108: dup 8 0 DO dup .4regs cell+ LOOP drop
2109: ;
2110: : .special-regs
2111: cr ." CR / XER LR / CTR SRR0 / SRR1 DAR / DSISR"
2112: cr dup >cr @ .8 dup >lr @ .16 dup >srr0 @ .16 dup >dar @ .16
2113: cr dup >xer @ .16 dup >ctr @ .16 dup >srr1 @ .16 >dsisr @ .8
2114: ;
2115: : .regs
2116: cr .fixed-regs
2117: cr .special-regs
2118: cr cr
2119: ;
2120: : .hw-exception ( reason-code exception-nr -- )
2121: ." ( " dup . ." ) "
2122: CASE
2123: 200 OF ." Machine Check" ENDOF
2124: 300 OF ." Data Storage" ENDOF
2125: 380 OF ." Data Segment" ENDOF
2126: 400 OF ." Intruction Storage" ENDOF
2127: 480 OF ." Instruction Segment" ENDOF
2128: 500 OF ." External" ENDOF
2129: 600 OF ." Alignment" ENDOF
2130: 700 OF ." Program" ENDOF
2131: 800 OF ." Floating-point unavailable" ENDOF
2132: 900 OF ." Decrementer" ENDOF
2133: 980 OF ." Hypervisor Decrementer" ENDOF
2134: C00 OF ." System Call" ENDOF
2135: D00 OF ." Trace" ENDOF
2136: F00 OF ." Performance Monitor" ENDOF
2137: F20 OF ." VMX Unavailable" ENDOF
2138: 1200 OF ." System Error" ENDOF
2139: 1600 OF ." Maintenance" ENDOF
2140: 1800 OF ." Thermal" ENDOF
2141: dup OF ." Unknown" ENDOF
2142: ENDCASE
2143: ." Exception [ " . ." ]"
2144: ;
2145: : .sw-exception ( exception-nr -- )
2146: ." Exception [ " . ." ] triggered by boot firmware."
2147: ;
2148: : be-hw-exception ( [reason-code] exception-nr -- )
2149: cr cr
2150: dup 0> IF .hw-exception ELSE .sw-exception THEN
2151: cr eregs .regs
2152: ;
2153: ' be-hw-exception to hw-exception-handler
2154: : (boot-exception-handler) ( x1...xn exception-nr -- x1...xn)
2155: dup IF
2156: dup 0 > IF
2157: negate cp 9 emit ." : " type
2158: ELSE
2159: CASE
2160: -6d OF cr ." W3411: Client application returned." cr ENDOF
2161: -6c OF cr ." E3400: It was not possible to boot from any device "
2162: ." specified in the VPD." cr
2163: ENDOF
2164: -6b OF cr ." E3410: Boot list successfully read from VPD "
2165: ." but no useful information received." cr
2166: ENDOF
2167: -6a OF cr ." E3420: Boot list could not be read from VPD." cr
2168: ENDOF
2169: -69 OF
2170: cr ." E3406: Client application returned an error"
2171: abort"-str @ count dup IF
2172: ." : " type cr
2173: ELSE
2174: ." ." cr
2175: 2drop
2176: THEN
2177: ENDOF
2178: -68 OF cr ." E3405: No such device" cr ENDOF
2179: -67 OF cr ." E3404: Not a bootable device!" cr ENDOF
2180: -66 OF cr ." E3408: Failed to claim memory for the executable" cr
2181: ENDOF
2182: -65 OF cr ." E3407: Load failed" cr ENDOF
2183: -64 OF cr ." E3403: Bad executable: " abort"-str @ count type cr
2184: ENDOF
2185: -63 OF cr ." E3409: Unknown FORTH Word" cr ENDOF
2186: -2 OF cr ." E3401: Aborting boot, " abort"-str @ count type cr
2187: ENDOF
2188: dup OF ." E3402: Aborting boot, internal error" cr ENDOF
2189: ENDCASE
2190: THEN
2191: ELSE
2192: drop
2193: THEN
2194: ;
2195: ' (boot-exception-handler) to boot-exception-handler
2196: : throw-error ( error-code "error-string" -- )
2197: skipws 0a parse rot throw
2198: ;
2199: : enable-ext-int ( -- )
2200: msr@ 8000 or msr!
2201: ;
2202: : disable-ext-int ( -- )
2203: msr@ 8000 not and msr!
2204: ;
2205: : gen-ext-int ( -- )
2206: 7fffffff dec! \ Reset decrementer
2207: enable-ext-int \ Enable interrupt
2208: FF 20000508418 rx! \ Interrupt priority mask
2209: 10 20000508410 rx! \ Interrupt priority
2210: ;
2211: : mm-log-warning 2drop ;
2212: : write-mm-log ( data length type -- status )
2213: 3drop 0
2214: ;
2215: 080 cp
2216: 100 cp
2217: : beep bell emit ;
2218: : TABLE-EXECUTE
2219: CREATE DOES> swap cells+ @ ?dup IF execute ELSE beep THEN ;
2220: 0 VALUE accept-adr
2221: 0 VALUE accept-max
2222: 0 VALUE accept-len
2223: 0 VALUE accept-cur
2224: : esc 1b emit ;
2225: : csi esc 5b emit ;
2226: : move-cursor ( -- )
2227: esc ." 8" accept-cur IF
2228: csi base @ decimal accept-cur 0 .r base ! ." C"
2229: THEN
2230: ;
2231: : redraw-line ( -- )
2232: accept-cur accept-len = IF EXIT THEN
2233: move-cursor
2234: accept-adr accept-len accept-cur /string type
2235: csi ." K" move-cursor
2236: ;
2237: : full-redraw-line ( -- )
2238: accept-cur 0 to accept-cur move-cursor
2239: accept-adr accept-len type
2240: csi ." K" to accept-cur move-cursor
2241: ;
2242: : redraw-prompt ( -- )
2243: cr depth . [char] > emit
2244: ;
2245: : insert-char ( char -- )
2246: accept-len accept-max = IF drop beep EXIT THEN
2247: accept-cur accept-len <> IF csi ." @" dup emit
2248: accept-adr accept-cur + dup 1+ accept-len accept-cur - move
2249: ELSE dup emit THEN
2250: accept-adr accept-cur + c!
2251: accept-cur 1+ to accept-cur
2252: accept-len 1+ to accept-len redraw-line
2253: ;
2254: : delete-char ( -- )
2255: accept-cur accept-len = IF beep EXIT THEN
2256: accept-len 1- to accept-len
2257: accept-adr accept-cur + dup 1+ swap accept-len accept-cur - move
2258: csi ." P" redraw-line
2259: ;
2260: STRUCT
2261: cell FIELD his>next
2262: cell FIELD his>prev
2263: cell FIELD his>len
2264: 0 FIELD his>buf
2265: CONSTANT /his
2266: 0 VALUE his-head
2267: 0 VALUE his-tail
2268: 0 VALUE his-cur
2269: : add-history ( -- )
2270: accept-len 0= IF EXIT THEN
2271: /his accept-len + alloc-mem
2272: his-tail IF dup his-tail his>next ! ELSE dup to his-head THEN
2273: his-tail over his>prev ! 0 over his>next ! dup to his-tail
2274: accept-len over his>len ! accept-adr swap his>buf accept-len move
2275: ;
2276: : history ( -- )
2277: his-head BEGIN dup WHILE
2278: cr dup his>buf over his>len @ type
2279: his>next @ REPEAT drop
2280: ;
2281: : select-history ( his -- )
2282: dup to his-cur dup IF
2283: dup his>len @ accept-max min dup to accept-len to accept-cur
2284: his>buf accept-adr accept-len move ELSE
2285: drop 0 to accept-len 0 to accept-cur THEN
2286: full-redraw-line
2287: ;
2288: 0 value ?tab-pressed
2289: 0 value tab-last-adr
2290: 0 value tab-last-len
2291: : $same-string ( addr-1 len-1 addr-2 len-2 -- addr-1 len-1' )
2292: dup 0= IF \ The second parameter is not a string.
2293: 2drop EXIT \ bail out
2294: THEN
2295: rot min 0 0 -rot ( addr1 addr2 0 len' 0 )
2296: DO ( addr1 addr2 len-1' )
2297: 2 pick i + c@ lcc
2298: 2 pick i + c@ lcc
2299: = IF 1 + ELSE leave THEN
2300: LOOP
2301: nip
2302: ;
2303: : $tab-sift-words ( text-addr text-len -- sift-count )
2304: sift-compl-only >r true to sift-compl-only \ save sifting mode
2305: last BEGIN @ ?dup WHILE \ loop over all words
2306: $inner-sift IF \ any completions possible?
2307: 2dup bounds DO I c@ lcc I c! LOOP
2308: ?tab-pressed IF 2dup type space THEN \ <tab><tab> prints possibilities
2309: tab-last-adr tab-last-len $same-string \ find matching substring ...
2310: to tab-last-len to tab-last-adr \ ... and save it
2311: THEN
2312: repeat
2313: 2drop
2314: #sift-count 0 to #sift-count \ how many words were found?
2315: r> to sift-compl-only \ restore sifting completion mode
2316: ;
2317: 0 value current-stack
2318: : new-stack ( cells <>name -- )
2319: create >r here ( here R: cells )
2320: dup r@ 2 + cells ( here here bytes R: cells )
2321: dup allot erase ( here R: cells)
2322: cell+ r> ( here+1cell cells )
2323: swap ! ( )
2324: DOES> to current-stack
2325: ;
2326: : reset-stack ( -- )
2327: 0 current-stack !
2328: ;
2329: : stack-depth ( -- depth )
2330: current-stack @
2331: ;
2332: : push ( value -- )
2333: current-stack @
2334: current-stack cell+ @ over <= ABORT" Stack overflow"
2335: cells
2336: 1 current-stack +!
2337: current-stack 2 cells + + !
2338: ;
2339: : pop ( -- value )
2340: current-stack @ 0= ABORT" Stack underflow"
2341: current-stack @ cells
2342: current-stack + cell+ @
2343: -1 current-stack +!
2344: ;
2345: 10 new-stack device-stack
2346: : (next-dev) ( node -- node' addr len )
2347: device-stack
2348: dup (node>path) rot
2349: dup child IF dup push child -rot EXIT THEN
2350: dup peer IF peer -rot EXIT THEN
2351: drop
2352: BEGIN
2353: stack-depth
2354: WHILE
2355: pop peer ?dup IF -rot EXIT THEN
2356: REPEAT
2357: 0 -rot
2358: ;
2359: : $inner-sift-nodes ( text-addr text-len node -- ... path-addr path-len true | false )
2360: (next-dev) ( text-addr text-len node' path-addr path-len )
2361: dup 0= IF drop false EXIT THEN
2362: 2dup 6 pick 6 pick find-isubstr ( text-addr text-len node' path-addr path-len pos )
2363: 0= IF
2364: #sift-count 1+ to #sift-count \ count completions
2365: true
2366: ELSE
2367: 2drop false
2368: THEN
2369: ;
2370: : .nodes ( -- )
2371: s" /" find-node BEGIN dup WHILE
2372: (next-dev)
2373: type cr
2374: REPEAT
2375: drop
2376: reset-stack
2377: ;
2378: create sift-node-buffer 1000 allot
2379: 0 value sift-node-num
2380: : sift-node-buffer
2381: sift-node-buffer sift-node-num 100 * +
2382: sift-node-num 1+ dup 10 = IF drop 0 THEN
2383: to sift-node-num
2384: ;
2385: : $tab-sift-nodes ( text-addr text-len -- sift-count )
2386: s" /" find-node BEGIN dup WHILE
2387: $inner-sift-nodes IF \ any completions possible?
2388: sift-node-buffer swap 2>r 2r@ move 2r> \ make an almost permanent copy without strdup
2389: ?tab-pressed IF 2dup type space THEN \ <tab><tab> prints possibilities
2390: tab-last-adr tab-last-len $same-string \ find matching substring ...
2391: to tab-last-len to tab-last-adr \ ... and save it
2392: THEN
2393: REPEAT
2394: 2drop drop
2395: #sift-count 0 to #sift-count \ how many words were found?
2396: reset-stack
2397: ;
2398: : $tab-sift ( text-addr text-len -- sift-count )
2399: ?tab-pressed IF beep space THEN \ cosmetical fix for <tab><tab>
2400: dup IF bl rsplit dup IF 2swap THEN ELSE 0 0 THEN >r >r
2401: 0 dup to tab-last-len to tab-last-adr \ reset last possible match
2402: current-node @ IF \ if we are in a node?
2403: 2dup 2>r \ save text
2404: $tab-sift-words to #sift-count \ search in current node first
2405: 2r> \ fetch text to complete, again
2406: THEN
2407: 2dup 2>r
2408: current-node @ >r 0 set-node \ now search in global words
2409: $tab-sift-words to #sift-count
2410: r> set-node
2411: 2r> $tab-sift-nodes
2412: r> r> dup IF s" " $cat THEN tab-last-adr tab-last-len $cat
2413: to tab-last-len to tab-last-adr \ ... and save the whole string
2414: ;
2415: : handle-^A
2416: 0 to accept-cur move-cursor ;
2417: : handle-^B
2418: accept-cur ?dup IF 1- to accept-cur ( csi ." D" ) move-cursor THEN ;
2419: : handle-^D
2420: delete-char ( redraw-line ) ;
2421: : handle-^E
2422: accept-len to accept-cur move-cursor ;
2423: : handle-^F
2424: accept-cur accept-len <> IF accept-cur 1+ to accept-cur csi ." C" THEN ;
2425: : handle-^H
2426: accept-cur 0= IF beep EXIT THEN
2427: handle-^B delete-char
2428: ;
2429: : handle-^I
2430: accept-adr accept-len
2431: $tab-sift 0 > IF
2432: ?tab-pressed IF
2433: redraw-prompt full-redraw-line
2434: false to ?tab-pressed
2435: ELSE
2436: tab-last-adr accept-adr tab-last-len move \ copy matching substring
2437: tab-last-len dup to accept-len to accept-cur \ len and cursor position
2438: full-redraw-line \ redraw new string
2439: true to ?tab-pressed \ second tab will print possible matches
2440: THEN
2441: THEN
2442: ;
2443: : handle-^K
2444: BEGIN accept-cur accept-len <> WHILE delete-char REPEAT ;
2445: : handle-^L
2446: history redraw-prompt full-redraw-line ;
2447: : handle-^N
2448: his-cur IF his-cur his>next @ ELSE his-head THEN
2449: dup to his-cur select-history
2450: ;
2451: : handle-^P
2452: his-cur IF his-cur his>prev @ ELSE his-tail THEN
2453: dup to his-cur select-history
2454: ;
2455: : handle-^Q \ Does not handle terminal formatting yet.
2456: key insert-char ;
2457: : handle-^R
2458: full-redraw-line ;
2459: : handle-^U
2460: 0 to accept-len 0 to accept-cur full-redraw-line ;
2461: : handle-fn
2462: key drop beep
2463: ;
2464: TABLE-EXECUTE handle-CSI
2465: 0 , ' handle-^P , ' handle-^N , ' handle-^F ,
2466: ' handle-^B , 0 , 0 , 0 ,
2467: ' handle-^A , 0 , 0 , ' handle-^E ,
2468: 0 , 0 , 0 , 0 ,
2469: 0 , 0 , 0 , 0 ,
2470: 0 , 0 , 0 , 0 ,
2471: 0 , 0 , 0 , 0 ,
2472: 0 , 0 , 0 , 0 ,
2473: TABLE-EXECUTE handle-meta
2474: 0 , 0 , 0 , 0 ,
2475: 0 , 0 , 0 , 0 ,
2476: 0 , 0 , 0 , 0 ,
2477: 0 , 0 , 0 , ' handle-fn ,
2478: 0 , 0 , 0 , 0 ,
2479: 0 , 0 , 0 , 0 ,
2480: 0 , 0 , 0 , ' handle-CSI ,
2481: 0 , 0 , 0 , 0 ,
2482: : handle-ESC-O
2483: key
2484: dup 48 = IF
2485: handle-^A
2486: ELSE
2487: dup 46 = IF
2488: handle-^E
2489: THEN
2490: THEN drop
2491: ;
2492: : handle-ESC-5b
2493: key
2494: dup 31 = IF \ HOME
2495: key drop ( drops closing 7e ) handle-^A
2496: ELSE
2497: dup 33 = IF \ DEL
2498: key drop handle-^D
2499: ELSE
2500: dup 34 = IF \ END
2501: key drop handle-^E
2502: ELSE
2503: dup 1f and handle-CSI
2504: THEN
2505: THEN
2506: THEN drop
2507: ;
2508: : handle-ESC
2509: key
2510: dup 5b = IF
2511: handle-ESC-5b
2512: ELSE
2513: dup 4f = IF
2514: handle-ESC-O
2515: ELSE
2516: dup 1f and handle-meta
2517: THEN
2518: THEN drop
2519: ;
2520: TABLE-EXECUTE handle-control
2521: 0 , \ ^@:
2522: ' handle-^A ,
2523: ' handle-^B ,
2524: 0 , \ ^C:
2525: ' handle-^D ,
2526: ' handle-^E ,
2527: ' handle-^F ,
2528: 0 , \ ^G:
2529: ' handle-^H ,
2530: ' handle-^I , \ tab
2531: 0 , \ ^J:
2532: ' handle-^K ,
2533: ' handle-^L ,
2534: 0 , \ ^M: enter: handled in main loop
2535: ' handle-^N ,
2536: 0 , \ ^O:
2537: ' handle-^P ,
2538: ' handle-^Q ,
2539: ' handle-^R ,
2540: 0 , \ ^S:
2541: 0 , \ ^T:
2542: ' handle-^U ,
2543: 0 , \ ^V:
2544: 0 , \ ^W:
2545: 0 , \ ^X:
2546: 0 , \ ^Y: insert save buffer
2547: 0 , \ ^Z:
2548: ' handle-ESC ,
2549: 0 , \ ^\:
2550: 0 , \ ^]:
2551: 0 , \ ^^:
2552: 0 , \ ^_:
2553: : (accept) ( adr len -- len' )
2554: cursor-on
2555: to accept-max to accept-adr
2556: 0 to accept-len 0 to accept-cur
2557: 0 to his-cur
2558: 1b emit 37 emit
2559: BEGIN
2560: key dup 0d <>
2561: WHILE
2562: dup 9 <> IF 0 to ?tab-pressed THEN \ reset state machine
2563: dup 7f = IF drop 8 THEN \ Handle DEL as if it was BS. ??? bogus
2564: dup bl < IF handle-control ELSE
2565: dup 80 and IF
2566: dup a0 < IF 7f and handle-meta ELSE drop beep THEN
2567: ELSE
2568: insert-char
2569: THEN
2570: THEN
2571: REPEAT
2572: drop add-history
2573: accept-len to accept-cur
2574: move-cursor space
2575: accept-len
2576: cursor-off
2577: ;
2578: ' (accept) to accept
2579: 120 cp
2580: 1 VALUE /dump
2581: ' c@ VALUE 'dump
2582: 0 VALUE dump-first
2583: 0 VALUE dump-last
2584: 0 VALUE dump-cur
2585: : .char ( c -- ) dup bl 7f within 0= IF drop [char] . THEN emit ;
2586: : dump-line ( -- )
2587: cr dump-cur dup 8 0.r [char] : emit 10 /dump / 0 DO
2588: space dump-cur dump-first dump-last within IF
2589: dump-cur 'dump execute /dump 2* 0.r ELSE
2590: /dump 2* spaces THEN dump-cur /dump + to dump-cur LOOP
2591: /dump 1 <> IF drop EXIT THEN
2592: to dump-cur 2 spaces
2593: 10 0 DO dump-cur dump-first dump-last within IF
2594: dump-cur 'dump execute .char ELSE space THEN dump-cur 1+ to dump-cur LOOP ;
2595: : (dump) ( addr len reader size -- )
2596: to /dump to 'dump bounds /dump negate and to dump-first to dump-last
2597: dump-first f invert and to dump-cur
2598: base @ hex BEGIN dump-line dump-cur dump-last >= UNTIL base ! ;
2599: : du ( -- ) dump-last 100 'dump /dump (dump) ;
2600: : dump ['] c@ 1 (dump) ;
2601: : wdump ['] w@ 2 (dump) ;
2602: : ldump ['] l@ 4 (dump) ;
2603: : xdump ['] x@ 8 (dump) ;
2604: : rdump ['] rb@ 1 (dump) ;
2605: cistack ciregs >r1 ! \ kernel wants a stack :-)
2606: STRUCT
2607: cell field romfs>file-header
2608: cell field romfs>data
2609: cell field romfs>data-size
2610: cell field romfs>flags
2611: CONSTANT /romfs-lookup-control-block
2612: CREATE romfs-lookup-cb /romfs-lookup-control-block allot
2613: romfs-lookup-cb /romfs-lookup-control-block erase
2614: : create-filename ( string -- string\0 )
2615: here >r dup 8 + allot
2616: r@ over 8 + erase
2617: r@ zplace r> ;
2618: : romfs-lookup ( fn-str fn-len -- data size | false )
2619: create-filename romfs-base
2620: romfs-lookup-cb romfs-lookup-entry call-c
2621: 0= IF romfs-lookup-cb dup romfs>data @ swap romfs>data-size @ ELSE
2622: false THEN ;
2623: : ibm,romfs-lookup ( fn-str fn-len -- data-high data-low size | 0 0 false )
2624: romfs-lookup dup
2625: 0= if drop 0 0 false else
2626: swap dup 20 rshift swap ffffffff and then ;
2627: : romfs-lookup-client ibm,romfs-lookup ;
2628: STRUCT
2629: cell field romfs>next-off
2630: cell field romfs>size
2631: cell field romfs>flags
2632: cell field romfs>data-off
2633: cell field romfs>name
2634: CONSTANT /romfs-cb
2635: : romfs-map-file ( fn-str fn-len -- file-addr file-size )
2636: romfs-base >r
2637: BEGIN 2dup r@ romfs>name zcount string=ci not WHILE
2638: ( fn-str fn-len ) ( R: rom-cb-file-addr )
2639: r> romfs>next-off dup @ dup 0= IF 1 THROW THEN + >r REPEAT
2640: ( fn-str fn-len ) ( R: rom-cb-file-addr )
2641: 2drop r@ romfs>data-off @ r@ + r> romfs>size @ ;
2642: : flash-header ( -- address | false )
2643: get-flash-base 28 + \ prepare flash header file address
2644: dup rx@ \ fetch "magic123"
2645: 6d61676963313233 <> IF \ IF flash is not valid
2646: drop \ | forget address
2647: false \ | return false
2648: THEN \ FI
2649: ;
2650: CREATE bdate-str 10 allot
2651: : bdate2human ( -- addr len )
2652: flash-header 40 + rx@ (.)
2653: drop dup 0 + bdate-str 6 + 4 move
2654: dup 4 + bdate-str 0 + 2 move
2655: dup 6 + bdate-str 3 + 2 move
2656: dup 8 + bdate-str b + 2 move
2657: a + bdate-str e + 2 move
2658: 2d bdate-str 2 + c!
2659: 2d bdate-str 5 + c!
2660: 20 bdate-str a + c!
2661: 3a bdate-str d + c!
2662: bdate-str 10
2663: ;
2664: : included ( fn fn-len -- )
2665: 2dup >r >r romfs-lookup dup IF
2666: r> drop r> drop evaluate
2667: ELSE
2668: drop ." Cannot open file : " r> r> type cr
2669: THEN
2670: ;
2671: : include ( " fn " -- )
2672: parse-word included
2673: ;
2674: : ?include ( flag " fn " -- )
2675: parse-word rot IF included ELSE 2drop THEN
2676: ;
2677: : include? ( nargs flag " fn " -- )
2678: parse-word rot IF
2679: rot drop included
2680: ELSE
2681: 2drop 0 ?DO drop LOOP
2682: THEN
2683: ;
2684: : (print-romfs-file-info) ( file-addr -- )
2685: 9 emit dup b 0.r 2 spaces dup 8 + @ 6 0.r 2 spaces 20 + zcount type cr
2686: ;
2687: : romfs-list ( -- )
2688: romfs-base 0 cr BEGIN + dup (print-romfs-file-info) dup @ dup 0= UNTIL 2drop
2689: ;
2690: 140 cp
2691: 200 cp
2692: 201 cp
2693: : .slof-logo
2694: cr ." ..`. .. ....... .. ...... ......."
2695: cr ." ..`...`''.`'. .''``````..''. .`''```''`. `''``````"
2696: cr ." .`` .:' ': `''..... .''. ''` .''..''......."
2697: cr ." ``.':.';. ``````''`.''. .''. ''``''`````'`"
2698: cr ." ``.':':` .....`''.`'`...... `'`.....`''.`'` "
2699: cr ." .`.`'`` .'`'`````. ``'''''' ``''`'''`. `'` "
2700: ;
2701: : banner
2702: cr ." Type 'boot' and press return to continue booting the system."
2703: s" /packages/sms" find-node IF
2704: cr ." Type 'sms-start' and press return to enter the configuration menu."
2705: THEN
2706: cr ." Type 'reset-all' and press return to reboot the system."
2707: cr cr
2708: ;
2709: : .banner banner console-clean-fifo ;
2710: : .banner .slof-logo .banner ;
2711: 220 cp
2712: DEFER find-boot-sector ( -- )
2713: 240 cp
2714: d# 512000000 VALUE tb-frequency \ default value - needed for "ms" to work
2715: -1 VALUE cpu-frequency
2716: : slof-build-id ( -- str len )
2717: flash-header 10 + a
2718: ;
2719: : slof-revision s" 001" ;
2720: : read-version-and-date
2721: flash-header 0= IF
2722: s" " encode-string
2723: ELSE
2724: flash-header 10 + 10
2725: here swap rmove
2726: here 10
2727: s" , " $cat
2728: bdate2human $cat encode-string THEN
2729: ;
2730: : from-cstring ( addr - len )
2731: dup dup BEGIN c@ 0 <> WHILE 1 + dup REPEAT
2732: swap -
2733: ;
2734: 260 cp
2735: : tb@ ( -- tb )
2736: BEGIN tbu@ tbl@ tbu@ rot over <> WHILE 2drop REPEAT
2737: 20 lshift swap ffffffff and or
2738: ;
2739: : milliseconds ( -- ms ) tb@ d# 1000 * tb-frequency / ;
2740: : microseconds ( -- us ) tb@ d# 1000000 * tb-frequency / ;
2741: : ms ( ms-to-wait -- ) milliseconds + BEGIN milliseconds over >= UNTIL drop ;
2742: : get-msecs ( -- n ) milliseconds ;
2743: : us ( us-to-wait -- ) microseconds + BEGIN microseconds over >= UNTIL drop ;
2744: 280 cp
2745: 2c0 cp
2746: 2e0 cp
2747: 10 CONSTANT quiesce-xt#
2748: CREATE quiesce-xts quiesce-xt# cells allot
2749: quiesce-xts quiesce-xt# cells erase
2750: : add-quiesce-xt ( xt -- )
2751: quiesce-xt# 0 DO
2752: quiesce-xts I cells + ( xt arrayptr )
2753: dup @ 0= ( xt arrayptr true|false )
2754: IF
2755: ! UNLOOP EXIT
2756: ELSE ( xt arrayptr )
2757: over swap ( xt xt arrayptr )
2758: @ = \ xt already stored ?
2759: IF
2760: drop UNLOOP EXIT
2761: THEN ( xt )
2762: THEN
2763: LOOP
2764: drop ( xt -- )
2765: ." Warning: quiesce xt list is full." cr
2766: ;
2767: : quiesce ( -- )
2768: quiesce-xt# 0 DO
2769: quiesce-xts I cells + ( arrayptr )
2770: @ dup IF ( xt )
2771: EXECUTE
2772: ELSE
2773: drop UNLOOP EXIT
2774: THEN
2775: LOOP
2776: ;
2777: 300 cp
2778: 0 VALUE usb-debug-flag
2779: false VALUE scan-time?
2780: VARIABLE ihandle-bulk-tran
2781: 0 VALUE uDOC-present \ device present and working?
2782: : usb-debug-print ( str len -- )
2783: usb-debug-flag IF type cr ELSE 2drop THEN
2784: ;
2785: : usb-debug-print-val ( str len val -- )
2786: usb-debug-flag IF -ROT type . cr ELSE drop 2drop THEN
2787: ;
2788: 0 VALUE proceed-char
2789: : show-proceed ( -- )
2790: scan-time? \ are we on usb-scan ?
2791: IF
2792: proceed-char
2793: CASE
2794: 0 OF 2d ENDOF \ show '-'
2795: 1 OF 5c ENDOF \ show '\'
2796: 2 OF 7c ENDOF \ show '|'
2797: dup OF 2f ENDOF \ show '/'
2798: ENDCASE
2799: emit 8 emit
2800: proceed-char 1 + 3 AND to proceed-char
2801: THEN
2802: ;
2803: : wait-proceed ( nl -- )
2804: show-proceed
2805: BEGIN
2806: dup d# 100 > ( nl true|false )
2807: WHILE
2808: 100 - show-proceed
2809: 100 ms \ do it in steps of 100ms
2810: REPEAT
2811: ms \ rest delay
2812: ;
2813: : do-alias-setting ( num name-str name-len )
2814: rot $cathex strdup \ create alias name
2815: get-node node>path \ get path string
2816: set-alias \ and set the alias
2817: ;
2818: 0 VALUE ohci-alias-num
2819: : set-ohci-alias ( -- )
2820: ohci-alias-num dup 1+ TO ohci-alias-num ( num )
2821: s" ohci"
2822: do-alias-setting
2823: ;
2824: 0 VALUE cdrom-alias-num
2825: 0 VALUE disk-alias-num \ shall start with: pci-disk-num
2826: FALSE VALUE ext-disk-alias \ first external disk: not yet assigned
2827: : set-drive-alias ( -- )
2828: space 5b emit
2829: s" cdrom" drop ( name-str )
2830: get-node node>name comp 0= ( true|false )
2831: IF \ is this a cdrom ?
2832: cdrom-alias-num dup 1+ TO cdrom-alias-num ( num )
2833: s" cdrom" \ yes, alias = cdrom
2834: ELSE
2835: s" sbc-dev" drop \ is this a scsi-block-device?
2836: get-node node>name comp 0= ( true|false )
2837: IF
2838: disk-alias-num dup 1 + to disk-alias-num
2839: s" disk" \ all block devices will be named "disk"
2840: s" usb" drop \ parent = usb controller ? (not hub)
2841: get-node node>parent @ node>name
2842: comp 0= \ parent node starts with 'usb' ?
2843: IF ( true|false )
2844: 1 s" hdd" \ add extra alias hdd1 for IntFlash
2845: 2dup type 2 pick .
2846: 8 emit 2f emit
2847: do-alias-setting
2848: uDOC-present 1 and
2849: IF
2850: uDOC-present 2 or to uDOC-present \ present and ready
2851: THEN
2852: ELSE
2853: ext-disk-alias not \ flag for first ext. disk already assigned
2854: IF
2855: TRUE to ext-disk-alias
2856: 2 s" hdd" \ add extra alias hdd2 for first USB disk
2857: 2dup type 2 pick .
2858: 8 emit 2f emit
2859: do-alias-setting
2860: THEN
2861: THEN
2862: ELSE
2863: 0 s" ??? " \ unknown device
2864: THEN
2865: THEN ( num name-str name-len )
2866: 2dup type 2 pick .
2867: 8 emit 5d emit cr
2868: do-alias-setting
2869: ;
2870: : usb-create-alias-name ( num -- str len )
2871: >r s" ohciX" 2dup + 1- ( str len last-char-ptr R: num )
2872: r> [char] 0 + swap c! ( str len R: )
2873: ;
2874: : uDOC-check ( -- )
2875: ;
2876: : uDOC-failure? ( -- )
2877: uDOC-present 80 and 0<> \ is ModFD actual beeing processed?
2878: IF
2879: uDOC-present 04 or to uDOC-present \ set Warning flag
2880: THEN
2881: ;
2882: : usb-scan
2883: space ." Scan USB... " cr
2884: true to scan-time? \ show proceeding signs
2885: 0 to uDOC-present \ mark as not present
2886: 0 to disk-alias-num \ start with disk0
2887: s" pci-disk-num" $find \ previously detected disks ?
2888: IF
2889: execute to disk-alias-num \ overwrite start number
2890: ELSE
2891: 2drop
2892: THEN
2893: 0 >r \ Counter for alias
2894: BEGIN
2895: r@ usb-create-alias-name
2896: find-alias ?dup ( false | str len len R: num )
2897: WHILE
2898: usb-debug-flag IF
2899: ." * Scanning hub " 2dup type ." ..." cr
2900: THEN
2901: open-dev ?dup IF ( ihandle R: num )
2902: dup to my-self
2903: dup ihandle>phandle dup set-node
2904: child ?dup IF
2905: delete-node s" Deleting node" usb-debug-print
2906: THEN
2907: >r s" enumerate" r@ $call-method \ Scan host controller
2908: r> close-dev 0 set-node 0 to my-self
2909: THEN ( R: num )
2910: r> 1+ >r ( R: num+1 )
2911: REPEAT r> drop
2912: 0 TO ohci-alias-num
2913: 0 TO cdrom-alias-num
2914: s" cdrom0" find-alias ( false | dev-path len )
2915: dup IF
2916: s" cdrom" 2swap ( alias-name len' dev-path len )
2917: set-alias ( -- )
2918: ELSE
2919: drop ( -- )
2920: THEN
2921: uDOC-check \ check if uDOC-device is present and working (ELBA only)
2922: false to scan-time? \ suppress proceeding signs
2923: ;
2924: : usb-probe
2925: usb-scan
2926: cdrom-alias-num 0= IF
2927: ." Not found CDROM! " cr
2928: THEN
2929: ." CDROM found " cdrom-alias-num . cr
2930: ;
2931: : usb-dev-test ( -- TRUE )
2932: s" USB Device Test " usb-debug-print
2933: 1 usb-create-alias-name
2934: find-alias ?dup IF
2935: ." * open " 2dup type . cr
2936: ELSE
2937: s" can't found alias " usb-debug-print
2938: THEN
2939: open-dev ?dup IF
2940: dup to my-self
2941: dup ihandle>phandle dup set-node
2942: s" bulk" $open-package ihandle-bulk-tran !
2943: s" close all " usb-debug-print
2944: close-dev 0 set-node 0 to my-self
2945: ihandle-bulk-tran close-package
2946: ELSE
2947: s" can't open usb hub" usb-debug-print
2948: THEN
2949: TRUE
2950: ;
2951: 320 cp
2952: : .ansi-attr-off 1b emit ." [0m" ; \ ESC Sequence: all terminal atributes off
2953: : .ansi-blue 1b emit ." [34m" ; \ ESC Sequence: foreground-color = blue
2954: : .ansi-green 1b emit ." [32m" ; \ ESC Sequence: foreground-color = green
2955: : .ansi-red 1b emit ." [31m" ; \ ESC Sequence: foreground-color = green
2956: : .ansi-bold 1b emit ." [1m" ; \ ESC Sequence: foreground-color bold
2957: false VALUE scsi-supp-present?
2958: : scsi-xt-err ." SCSI-ERROR (Intern) " ;
2959: ' scsi-xt-err VALUE scsi-open-xt \ preset with an invalid token
2960: : .wordlists ( -- )
2961: .ansi-red
2962: get-order ( -- wid1 .. widn n )
2963: dup space 28 emit .d ." word lists : "
2964: 0 DO
2965: . 08 emit 2c emit
2966: LOOP
2967: 08 emit \ 'bs'
2968: 29 emit \ ')'
2969: cr space 28 emit
2970: ." Context: " context dup .
2971: @ 5b emit . 8 emit 5d emit
2972: space
2973: ." / Current: " current .
2974: .ansi-attr-off
2975: cr
2976: ;
2977: : .context ( num -- )
2978: .ansi-red
2979: space
2980: 5b emit
2981: 23 emit . 3a emit
2982: context @
2983: . 8 emit 5d emit space
2984: .ansi-attr-off
2985: ;
2986: : scsi-open ( -- )
2987: scsi-supp-present? NOT
2988: IF
2989: s" scsi-support.fs" included ( xt-open )
2990: to scsi-open-xt ( )
2991: true to scsi-supp-present?
2992: THEN
2993: scsi-open-xt execute
2994: ;
2995: 340 cp
2996: 360 cp
2997: 0 VALUE fdt-debug
2998: fdt-start 0 = IF -1 throw THEN
2999: struct
3000: 4 field >fdth_magic
3001: 4 field >fdth_tsize
3002: 4 field >fdth_struct_off
3003: 4 field >fdth_string_off
3004: 4 field >fdth_rsvmap_off
3005: 4 field >fdth_version
3006: 4 field >fdth_compat_vers
3007: 4 field >fdth_boot_cpu
3008: 4 field >fdth_string_size
3009: 4 field >fdth_struct_size
3010: drop
3011: h# d00dfeed constant OF_DT_HEADER
3012: h# 1 constant OF_DT_BEGIN_NODE
3013: h# 2 constant OF_DT_END_NODE
3014: h# 3 constant OF_DT_PROP
3015: h# 4 constant OF_DT_NOP
3016: h# 9 constant OF_DT_END
3017: fdt-start
3018: dup dup >fdth_struct_off l@ + value fdt-struct
3019: dup dup >fdth_string_off l@ + value fdt-strings
3020: drop
3021: : fdt-check-header ( -- )
3022: fdt-start dup 0 = IF
3023: ." No flat device tree !" cr drop -1 throw EXIT THEN
3024: hex
3025: fdt-debug IF
3026: ." Flat device tree header at 0x" dup . s" :" type cr
3027: ." magic : 0x" dup >fdth_magic l@ . cr
3028: ." total size : 0x" dup >fdth_tsize l@ . cr
3029: ." offset to struct : 0x" dup >fdth_struct_off l@ . cr
3030: ." offset to strings: 0x" dup >fdth_string_off l@ . cr
3031: ." offset to rsvmap : 0x" dup >fdth_rsvmap_off l@ . cr
3032: ." version : " dup >fdth_version l@ decimal . hex cr
3033: ." last compat vers : " dup >fdth_compat_vers l@ decimal . hex cr
3034: dup >fdth_version l@ 2 >= IF
3035: ." boot CPU : 0x" dup >fdth_boot_cpu l@ . cr
3036: THEN
3037: dup >fdth_version l@ 3 >= IF
3038: ." strings size : 0x" dup >fdth_string_size l@ . cr
3039: THEN
3040: dup >fdth_version l@ 17 >= IF
3041: ." struct size : 0x" dup >fdth_struct_size l@ . cr
3042: THEN
3043: THEN
3044: dup >fdth_magic l@ OF_DT_HEADER <> IF
3045: ." Flat device tree has incorrect magic value !" cr
3046: drop -1 throw EXIT
3047: THEN
3048: dup >fdth_version l@ 10 < IF
3049: ." Flat device tree has usupported version !" cr
3050: drop -1 throw EXIT
3051: THEN
3052: drop
3053: ;
3054: fdt-check-header
3055: : fdt-next-tag ( addr -- nextaddr tag )
3056: 0 ( dummy tag on stack for loop )
3057: BEGIN
3058: drop ( drop previous tag )
3059: dup l@ ( read new tag )
3060: swap 4 + swap ( increment addr )
3061: dup OF_DT_NOP <> UNTIL ( loop until not nop )
3062: ;
3063: : fdt-fetch-unit ( addr -- addr $name )
3064: dup from-cstring \ get string size
3065: 2dup + 1 + 3 + fffffffc and -rot
3066: ;
3067: : fdt-fetch-string ( index -- $string)
3068: fdt-strings + dup from-cstring
3069: ;
3070: : fdt-create-dec s" decode-unit" $CREATE , DOES> @ hex-decode-unit ;
3071: : fdt-create-enc s" encode-unit" $CREATE , DOES> @ hex-encode-unit ;
3072: : fdt-unflatten-node ( start -- end )
3073: recursive
3074: fdt-next-tag dup OF_DT_BEGIN_NODE <> IF
3075: s" Weird tag 0x" type . " at start of node" type cr
3076: -1 throw
3077: THEN drop
3078: new-device
3079: fdt-fetch-unit
3080: dup 0 = IF drop drop " /" THEN
3081: 40 left-parse-string
3082: device-name
3083: dup IF
3084: " #address-cells" get-parent get-package-property IF
3085: 2drop
3086: ELSE
3087: decode-int nip nip
3088: hex-decode-unit
3089: set-unit
3090: THEN
3091: ELSE 2drop THEN
3092: BEGIN
3093: fdt-next-tag dup OF_DT_END_NODE <>
3094: WHILE
3095: dup OF_DT_PROP = IF
3096: drop dup ( drop tag, dup addr : a1 a1 )
3097: dup l@ dup rot 4 + ( fetch size, stack is : a1 s s a2)
3098: dup l@ swap 4 + ( fetch nameid, stack is : a1 s s i a3 )
3099: rot ( we now have: a1 s i a3 s )
3100: encode-bytes rot ( a1 s pa ps i)
3101: fdt-fetch-string ( a1 s pa ps $pn )
3102: property
3103: + 8 + 3 + fffffffc and
3104: ELSE dup OF_DT_BEGIN_NODE = IF
3105: drop ( drop tag )
3106: 4 -
3107: fdt-unflatten-node
3108: ELSE
3109: drop -1 throw
3110: THEN THEN
3111: REPEAT drop \ drop tag
3112: " #address-cells" get-node get-package-property IF ELSE
3113: decode-int dup fdt-create-dec fdt-create-enc 2drop
3114: THEN
3115: finish-device
3116: ;
3117: : fdt-unflatten-tree
3118: fdt-debug IF
3119: ." Unflattening device tree..." cr THEN
3120: fdt-struct fdt-unflatten-node drop
3121: fdt-debug IF
3122: ." Done !" cr THEN
3123: ;
3124: fdt-unflatten-tree
3125: : fdt-parse-memory
3126: " /memory" find-device
3127: " reg" get-node get-package-property IF throw -1 THEN
3128: decode-phys 2drop decode-phys
3129: my-#address-cells 1 > IF 20 << or THEN
3130: fdt-debug IF
3131: dup ." Memory size: " . cr
3132: THEN
3133: MIN-RAM-SIZE swap release
3134: 2drop device-end
3135: ;
3136: fdt-parse-memory
3137: : fdt-claim-reserve
3138: fdt-start
3139: dup dup >fdth_tsize l@ 0 claim drop
3140: dup >fdth_rsvmap_off l@ +
3141: BEGIN
3142: dup dup x@ swap 8 + x@
3143: dup 0 <>
3144: WHILE
3145: fdt-debug IF
3146: 2dup swap ." Reserve map entry: " . ." : " . cr
3147: THEN
3148: 0 claim drop
3149: 10 +
3150: REPEAT drop drop drop
3151: ;
3152: fdt-claim-reserve
3153: defer (client-exec)
3154: defer client-exec
3155: defer callback
3156: defer continue-client
3157: : set-chosen ( prop len name len -- )
3158: s" /chosen" find-node set-property ;
3159: : get-chosen ( name len -- [ prop len ] success )
3160: s" /chosen" find-node get-property 0= ;
3161: " /" find-device
3162: new-device
3163: s" aliases" device-name
3164: finish-device
3165: new-device
3166: s" options" device-name
3167: finish-device
3168: new-device
3169: s" openprom" device-name
3170: s" BootROM" device-type
3171: finish-device
3172: new-device
3173: s" packages" device-name
3174: get-node to packages
3175: new-device
3176: s" deblocker" device-name
3177: INSTANCE VARIABLE offset
3178: INSTANCE VARIABLE block-size
3179: INSTANCE VARIABLE max-transfer
3180: INSTANCE VARIABLE my-block
3181: INSTANCE VARIABLE adr
3182: INSTANCE VARIABLE len
3183: : open
3184: s" block-size" ['] $call-parent CATCH IF 2drop false EXIT THEN
3185: block-size !
3186: s" max-transfer" ['] $call-parent CATCH IF 2drop false EXIT THEN
3187: max-transfer !
3188: block-size @ alloc-mem my-block !
3189: 0 offset !
3190: true ;
3191: : close my-block @ block-size @ free-mem ;
3192: : seek ( lo hi -- status ) \ XXX: perhaps we should fail if the underlying
3193: lxjoin offset ! 0 ;
3194: : block+remainder ( -- block# remainder ) offset @ block-size @ u/mod swap ;
3195: : read-blocks ( addr block# #blocks -- actual ) s" read-blocks" $call-parent ;
3196: : read ( addr len -- actual )
3197: dup >r len ! adr !
3198: block+remainder dup IF ( block# offset-in-block )
3199: >r my-block @ swap 1 read-blocks drop
3200: my-block @ r@ + adr @ block-size @ r> - len @ min dup >r move
3201: r> dup negate len +! dup adr +! offset +! ELSE 2drop THEN
3202: BEGIN len @ block-size @ >= WHILE
3203: adr @ block+remainder drop len @ max-transfer @ min block-size @ / read-blocks
3204: block-size @ * dup negate len +! dup adr +! offset +! REPEAT
3205: len @ IF my-block @ block+remainder drop 1 read-blocks drop
3206: my-block @ adr @ len @ move THEN
3207: r> ;
3208: finish-device
3209: new-device
3210: false VALUE debug-disk-label?
3211: d# 16384 value max-prep-partition-blocks
3212: s" disk-label" device-name
3213: 0 INSTANCE VALUE partition
3214: 0 INSTANCE VALUE part-offset
3215: 0 INSTANCE VALUE part-start
3216: 0 INSTANCE VALUE lpart-start
3217: 0 INSTANCE VALUE part-size
3218: 0 INSTANCE VALUE dos-logical-partitions
3219: 0 INSTANCE VALUE block-size
3220: 0 INSTANCE VALUE block
3221: 0 INSTANCE VALUE args
3222: 0 INSTANCE VALUE args-len
3223: INSTANCE VARIABLE block# \ variable to store logical sector#
3224: INSTANCE VARIABLE hit# \ partition counter
3225: INSTANCE VARIABLE success-flag
3226: 0ff constant END-OF-DESC
3227: 3 constant PARTITION-ID
3228: 48 constant VOL-PART-LOC
3229: STRUCT
3230: 1b8 field mbr>boot-loader
3231: /l field mbr>disk-signature
3232: /w field mbr>null
3233: 40 field mbr>partition-table
3234: /w field mbr>magic
3235: CONSTANT /mbr
3236: STRUCT
3237: /c field part-entry>active
3238: /c field part-entry>start-head
3239: /c field part-entry>start-sect
3240: /c field part-entry>start-cyl
3241: /c field part-entry>id
3242: /c field part-entry>end-head
3243: /c field part-entry>end-sect
3244: /c field part-entry>end-cyl
3245: /l field part-entry>sector-offset
3246: /l field part-entry>sector-count
3247: CONSTANT /partition-entry
3248: : offset ( d.rel -- d.abs )
3249: part-offset 0 d+
3250: ;
3251: : seek ( pos.lo pos.hi -- status )
3252: offset
3253: debug-disk-label? IF 2dup ." seek-parent: pos.hi=0x" u. ." pos.lo=0x" u. THEN
3254: s" seek" $call-parent
3255: debug-disk-label? IF dup ." status=" . cr THEN
3256: ;
3257: : read ( addr len -- actual )
3258: debug-disk-label? IF 2dup swap ." read-parent: addr=0x" u. ." len=" .d THEN
3259: s" read" $call-parent
3260: debug-disk-label? IF dup ." actual=" .d cr THEN
3261: ;
3262: : read-sector ( sector-number -- )
3263: block-size * 0 seek drop \ seek to sector
3264: block block-size read drop \ read sector
3265: ;
3266: : (.part-entry) ( part-entry )
3267: cr ." part-entry>active: " dup part-entry>active c@ .d
3268: cr ." part-entry>start-head: " dup part-entry>start-head c@ .d
3269: cr ." part-entry>start-sect: " dup part-entry>start-sect c@ .d
3270: cr ." part-entry>start-cyl: " dup part-entry>start-cyl c@ .d
3271: cr ." part-entry>id: " dup part-entry>id c@ .d
3272: cr ." part-entry>end-head: " dup part-entry>end-head c@ .d
3273: cr ." part-entry>end-sect: " dup part-entry>end-sect c@ .d
3274: cr ." part-entry>end-cyl: " dup part-entry>end-cyl c@ .d
3275: cr ." part-entry>sector-offset: " dup part-entry>sector-offset l@-le .d
3276: cr ." part-entry>sector-count: " dup part-entry>sector-count l@-le .d
3277: cr
3278: ;
3279: : (.name) r@ begin cell - dup @ <colon> = UNTIL xt>name cr type space ;
3280: : init-block ( -- )
3281: s" block-size" ['] $call-parent CATCH IF ABORT" parent has no block-size." THEN
3282: to block-size
3283: d# 2048 alloc-mem
3284: dup d# 2048 erase
3285: to block
3286: debug-disk-label? IF
3287: ." init-block: block-size=" block-size .d ." block=0x" block u. cr
3288: THEN
3289: ;
3290: : no-mbr? ( -- true|false )
3291: 0 read-sector block mbr>magic w@-le aa55 <>
3292: ;
3293: : pc-extended-partition? ( part-entry-addr -- true|false )
3294: part-entry>id c@ ( id )
3295: dup 5 = swap ( true|false id )
3296: dup f = swap ( true|false true|false id )
3297: 85 = ( true|false true|false true|false )
3298: or or ( true|false )
3299: ;
3300: : partition>part-entry ( partition -- part-entry )
3301: 1- /partition-entry * block mbr>partition-table +
3302: ;
3303: : partition>start-sector ( partition -- sector-offset )
3304: partition>part-entry part-entry>sector-offset l@-le
3305: ;
3306: : count-dos-logical-partitions ( -- #logical-partitions )
3307: no-mbr? IF 0 EXIT THEN
3308: 0 5 1 DO ( current )
3309: i partition>part-entry ( current part-entry )
3310: dup pc-extended-partition? IF
3311: part-entry>sector-offset l@-le ( current sector )
3312: dup to part-start to lpart-start ( current )
3313: BEGIN
3314: part-start read-sector \ read EBR
3315: 1 partition>start-sector IF
3316: 1+
3317: THEN \ another logical partition
3318: 2 partition>start-sector
3319: ?dup IF lpart-start + to part-start false ELSE true THEN
3320: UNTIL
3321: ELSE
3322: drop
3323: THEN
3324: LOOP
3325: ;
3326: : (get-dos-partition-params) ( ext-part-start part-entry -- offset count active? id )
3327: dup part-entry>sector-offset l@-le rot + swap ( offset part-entry )
3328: dup part-entry>sector-count l@-le swap ( offset count part-entry )
3329: dup part-entry>active c@ 80 = swap ( offset count active? part-entry )
3330: part-entry>id c@ ( offset count active? id )
3331: ;
3332: : find-dos-partition ( partition# -- false | offset count active? id true )
3333: to partition 0 to part-start 0 to part-offset
3334: partition 0<= IF 0 to partition false EXIT THEN
3335: no-mbr? IF 0 to partition false EXIT THEN
3336: partition 4 <= IF \ Is this a primary partition?
3337: 0 partition partition>part-entry
3338: (get-dos-partition-params)
3339: true EXIT
3340: ELSE
3341: partition 4 - 0 5 1 DO ( logical-partition current )
3342: i partition>part-entry ( log-part current part-entry )
3343: dup pc-extended-partition? IF
3344: part-entry>sector-offset l@-le ( log-part current sector )
3345: dup to part-start to lpart-start ( log-part current )
3346: BEGIN
3347: part-start read-sector \ read EBR
3348: 1 partition>start-sector IF \ first partition entry
3349: 1+ 2dup = IF ( log-part current )
3350: 2drop
3351: part-start 1 partition>part-entry
3352: (get-dos-partition-params)
3353: true UNLOOP EXIT
3354: THEN
3355: 2 partition>start-sector
3356: ?dup IF lpart-start + to part-start false ELSE true THEN
3357: ELSE
3358: true
3359: THEN
3360: UNTIL
3361: ELSE
3362: drop
3363: THEN
3364: LOOP
3365: 2drop false
3366: THEN
3367: ;
3368: : try-dos-partition ( -- okay? )
3369: no-mbr? IF cr ." No DOS disk-label found." cr false EXIT THEN
3370: count-dos-logical-partitions TO dos-logical-partitions
3371: debug-disk-label? IF
3372: ." Found " dos-logical-partitions .d ." logical partitions" cr
3373: ." Partition = " partition .d cr
3374: THEN
3375: partition 1 5 dos-logical-partitions +
3376: within 0= IF
3377: cr ." Partition # not 1-" 4 dos-logical-partitions + . cr false EXIT
3378: THEN
3379: partition find-dos-partition IF
3380: 2drop drop
3381: block-size * to part-offset
3382: true
3383: ELSE
3384: false
3385: THEN
3386: ;
3387: : has-iso9660-filesystem ( -- TRUE|FALSE )
3388: 10 800 * 0 seek drop \ seek to sector
3389: block 800 read drop \ read sector
3390: block c@ 1 =
3391: block 1+ 5 s" CD001" str=
3392: and
3393: dup IF 800 to block-size THEN
3394: ;
3395: : load-from-dos-boot-partition ( addr -- size )
3396: no-mbr? IF FALSE EXIT THEN \ read MBR and check for DOS disk-label magic
3397: count-dos-logical-partitions TO dos-logical-partitions
3398: debug-disk-label? IF
3399: ." Found " dos-logical-partitions .d ." logical partitions" cr
3400: ." Partition = " partition .d cr
3401: THEN
3402: 5 dos-logical-partitions + 1 DO
3403: i find-dos-partition IF ( addr offset count active? id )
3404: 41 = and ( addr offset count prep-boot-part? )
3405: IF ( addr offset count )
3406: max-prep-partition-blocks min \ reduce load size
3407: swap ( addr count offset )
3408: block-size * to part-offset
3409: 0 0 seek drop ( addr offset )
3410: block-size * read ( size )
3411: UNLOOP EXIT
3412: ELSE
3413: 2drop ( addr )
3414: THEN
3415: THEN
3416: LOOP
3417: drop 0
3418: ;
3419: : load-from-boot-partition ( addr -- size )
3420: load-from-dos-boot-partition
3421: ;
3422: : parse-bootinfo-txt ( addr len -- str len )
3423: 2dup s" <boot-script>" find-substr ( addr len pos1 )
3424: 2dup = IF
3425: 3drop 0 0 EXIT
3426: THEN
3427: dup >r - swap r> + swap ( addr1 len1 )
3428: 2dup [char] \ findchar drop ( addr1 len1 pos2 )
3429: dup >r - swap r> + swap ( addr2 len2 )
3430: 2dup s" </boot-script>" find-substr nip ( addr2 len3 )
3431: ;
3432: : load-chrp-boot-file ( addr -- size )
3433: my-self parent ihandle>phandle node>path
3434: s" :\ppc\bootinfo.txt" $cat strdup ( addr str len )
3435: open-dev dup 0= IF 2drop 0 EXIT THEN
3436: >r dup ( addr addr R:ihandle )
3437: dup s" load" r@ $call-method ( addr addr size R:ihandle )
3438: r> close-dev ( addr addr size )
3439: parse-bootinfo-txt ( addr fnstr fnlen )
3440: dup 0= IF 3drop 0 EXIT THEN
3441: my-self parent ihandle>phandle node>path ( addr fnstr fnlen nstr nlen )
3442: s" :" $cat 2swap $cat strdup ( addr str len )
3443: 2dup encode-string s" bootpath" set-chosen
3444: open-dev dup 0= IF ." failed to load CHRP boot loader." 2drop 0 EXIT THEN
3445: >r s" load" r@ $call-method ( size R:ihandle )
3446: r> close-dev ( size )
3447: ;
3448: : parse-partition ( -- okay? )
3449: 0 to partition
3450: 0 to part-offset
3451: my-args to args-len to args
3452: args-len 1 = IF args c@ [char] 0 = IF 0 to args-len THEN THEN
3453: my-args [char] , findchar 0= IF true EXIT THEN drop \ no comma
3454: my-args [char] , split to args-len to args
3455: dup 0= IF 2drop true EXIT THEN \ no first argument
3456: base @ >r decimal $number r> base !
3457: IF cr ." Not a partition #" false EXIT THEN
3458: to partition
3459: true
3460: ;
3461: : (interpose-filesystem) ( str len -- )
3462: find-package IF args args-len rot interpose THEN
3463: ;
3464: : try-dos-files ( -- found? )
3465: no-mbr? IF false EXIT THEN
3466: block c@ e9 <> IF
3467: block c@ eb <>
3468: block 2+ c@ 90 <> or
3469: IF false EXIT THEN
3470: THEN
3471: s" fat-files" (interpose-filesystem)
3472: true
3473: ;
3474: : try-ext2-files ( -- found? )
3475: 2 read-sector \ read first superblock
3476: block d# 56 + w@-le \ fetch s_magic
3477: ef53 <> IF false EXIT THEN \ s_magic found?
3478: s" ext2-files" (interpose-filesystem)
3479: true
3480: ;
3481: : try-iso9660-files
3482: has-iso9660-filesystem 0= IF false exit THEN
3483: s" iso-9660" (interpose-filesystem)
3484: true
3485: ;
3486: : try-files ( -- found? )
3487: args-len 0= IF true EXIT THEN
3488: try-dos-files IF true EXIT THEN
3489: try-ext2-files IF true EXIT THEN
3490: try-iso9660-files IF true EXIT THEN
3491: false
3492: ;
3493: : try-partitions ( -- found? )
3494: try-dos-partition IF try-files EXIT THEN
3495: false
3496: ;
3497: : close ( -- )
3498: debug-disk-label? IF ." Closing disk-label: block=0x" block u. ." block-size=" block-size .d cr THEN
3499: block d# 2048 free-mem
3500: ;
3501: : open ( -- true|false )
3502: init-block
3503: parse-partition 0= IF
3504: close
3505: false EXIT
3506: THEN
3507: partition IF
3508: try-partitions
3509: ELSE
3510: try-files
3511: THEN
3512: dup 0= IF debug-disk-label? IF ." not found." cr THEN close THEN \ free memory again
3513: ;
3514: : load ( addr -- size )
3515: debug-disk-label? IF
3516: ." load: " dup u. cr
3517: THEN
3518: args-len IF
3519: TRUE ABORT" Load done w/o filesystem"
3520: ELSE
3521: partition IF
3522: 0 0 seek drop
3523: 200000 read
3524: ELSE
3525: has-iso9660-filesystem IF
3526: dup load-chrp-boot-file ?dup 0 > IF nip EXIT THEN
3527: THEN
3528: load-from-boot-partition
3529: dup 0= ABORT" No boot partition found"
3530: THEN
3531: THEN
3532: ;
3533: finish-device
3534: new-device
3535: s" fat-files" device-name
3536: INSTANCE VARIABLE bytes/sector
3537: INSTANCE VARIABLE sectors/cluster
3538: INSTANCE VARIABLE #reserved-sectors
3539: INSTANCE VARIABLE #fats
3540: INSTANCE VARIABLE #root-entries
3541: INSTANCE VARIABLE total-#sectors
3542: INSTANCE VARIABLE media-descriptor
3543: INSTANCE VARIABLE sectors/fat
3544: INSTANCE VARIABLE sectors/track
3545: INSTANCE VARIABLE #heads
3546: INSTANCE VARIABLE #hidden-sectors
3547: INSTANCE VARIABLE fat-type
3548: INSTANCE VARIABLE bytes/cluster
3549: INSTANCE VARIABLE fat-offset
3550: INSTANCE VARIABLE root-offset
3551: INSTANCE VARIABLE cluster-offset
3552: INSTANCE VARIABLE #clusters
3553: : seek s" seek" $call-parent ;
3554: : read s" read" $call-parent ;
3555: INSTANCE VARIABLE data
3556: INSTANCE VARIABLE #data
3557: : free-data
3558: data @ ?dup IF #data @ free-mem 0 data ! THEN ;
3559: : read-data ( offset size -- )
3560: free-data dup #data ! alloc-mem data !
3561: xlsplit seek -2 and ABORT" fat-files read-data: seek failed"
3562: data @ #data @ read #data @ <> ABORT" fat-files read-data: read failed" ;
3563: CREATE fat-buf 8 allot
3564: : read-fat ( cluster# -- data )
3565: fat-buf 8 erase
3566: 1 #split fat-type @ * 2/ 2/ fat-offset @ +
3567: xlsplit seek -2 and ABORT" fat-files read-fat: seek failed"
3568: fat-buf 8 read 8 <> ABORT" fat-files read-fat: read failed"
3569: fat-buf 8c@ bxjoin fat-type @ dup >r 2* #split drop r> #split
3570: rot IF swap THEN drop ;
3571: INSTANCE VARIABLE next-cluster
3572: : read-cluster ( cluster# -- )
3573: dup bytes/cluster @ * cluster-offset @ + bytes/cluster @ read-data
3574: read-fat dup #clusters @ >= IF drop 0 THEN next-cluster ! ;
3575: : read-dir ( cluster# -- )
3576: ?dup 0= IF root-offset @ #root-entries @ 20 * read-data 0 next-cluster !
3577: ELSE read-cluster THEN ;
3578: : .time ( x -- )
3579: base @ >r decimal
3580: b #split 2 0.r [char] : emit 5 #split 2 0.r [char] : emit 2* 2 0.r
3581: r> base ! ;
3582: : .date ( x -- )
3583: base @ >r decimal
3584: 9 #split 7bc + 4 0.r [char] - emit 5 #split 2 0.r [char] - emit 2 0.r
3585: r> base ! ;
3586: : .attr ( attr -- )
3587: 6 0 DO dup 1 and IF s" RHSLDA" drop i + c@ ELSE bl THEN emit u2/ LOOP drop ;
3588: : .dir-entry ( adr -- )
3589: dup 0b + c@ 8 and IF drop EXIT THEN \ volume label, not a file
3590: dup c@ e5 = IF drop EXIT THEN \ deleted file
3591: cr
3592: dup 1a + 2c@ bwjoin [char] # emit 4 0.r space \ starting cluster
3593: dup 18 + 2c@ bwjoin .date space
3594: dup 16 + 2c@ bwjoin .time space
3595: dup 1c + 4c@ bljoin base @ decimal swap a .r base ! space \ size in bytes
3596: dup 0b + c@ .attr space
3597: dup 8 BEGIN 2dup 1- + c@ 20 = over and WHILE 1- REPEAT type
3598: dup 8 + 3 BEGIN 2dup 1- + c@ 20 = over and WHILE 1- REPEAT dup IF
3599: [char] . emit type ELSE 2drop THEN
3600: drop ;
3601: : .dir-entries ( adr n -- )
3602: 0 ?DO dup i 20 * + dup c@ 0= IF drop LEAVE THEN .dir-entry LOOP drop ;
3603: : .dir ( cluster# -- )
3604: read-dir BEGIN data @ #data @ 20 / .dir-entries next-cluster @ WHILE
3605: next-cluster @ read-cluster REPEAT ;
3606: : str-upper ( str len adr -- ) \ Copy string to adr, uppercase
3607: -rot bounds ?DO i c@ upc over c! char+ LOOP drop ;
3608: CREATE dos-name b allot
3609: : make-dos-name ( str len -- )
3610: dos-name b bl fill
3611: 2dup [char] . findchar IF
3612: 3dup 1+ /string 3 min dos-name 8 + str-upper nip THEN
3613: 8 min dos-name str-upper ;
3614: : (find-file) ( -- cluster file-len is-dir? true | false )
3615: data @ BEGIN dup data @ #data @ + < WHILE
3616: dup dos-name b comp WHILE 20 + REPEAT
3617: dup 1a + 2c@ bwjoin swap dup 1c + 4c@ bljoin swap 0b + c@ 10 and 0<> true
3618: ELSE drop false THEN ;
3619: : find-file ( dir-cluster name len -- cluster file-len is-dir? true | false )
3620: make-dos-name read-dir BEGIN (find-file) 0= WHILE next-cluster @ WHILE
3621: next-cluster @ read-cluster REPEAT false ELSE true THEN ;
3622: : find-path ( dir-cluster name len -- cluster file-len true | false )
3623: dup 0= IF 3drop false ." empty name " EXIT THEN
3624: over c@ [char] \ = IF 1 /string ." slash " RECURSE EXIT THEN
3625: [char] \ split 2>r find-file 0= IF 2r> 2drop false ." not found " EXIT THEN
3626: r@ 0<> <> IF 2drop 2r> 2drop false ." no dir<->file match " EXIT THEN
3627: r@ 0<> IF drop 2r> ." more... " RECURSE EXIT THEN
3628: 2r> 2drop true ." got it " ;
3629: : do-super ( -- )
3630: 0 200 read-data
3631: data @ 0b + 2c@ bwjoin bytes/sector !
3632: data @ 0d + c@ sectors/cluster !
3633: bytes/sector @ sectors/cluster @ * bytes/cluster !
3634: data @ 0e + 2c@ bwjoin #reserved-sectors !
3635: data @ 10 + c@ #fats !
3636: data @ 11 + 2c@ bwjoin #root-entries !
3637: data @ 13 + 2c@ bwjoin total-#sectors !
3638: data @ 15 + c@ media-descriptor !
3639: data @ 16 + 2c@ bwjoin sectors/fat !
3640: data @ 18 + 2c@ bwjoin sectors/track !
3641: data @ 1a + 2c@ bwjoin #heads !
3642: data @ 1c + 2c@ bwjoin #hidden-sectors !
3643: total-#sectors @ 0= IF data @ 20 + 4c@ bljoin total-#sectors ! THEN
3644: sectors/fat @ 0= IF data @ 24 + 4c@ bljoin sectors/fat ! THEN
3645: total-#sectors @ #reserved-sectors @ - sectors/fat @ #fats @ * -
3646: #root-entries @ 20 * bytes/sector @ // - sectors/cluster @ /
3647: dup #clusters !
3648: dup ff5 < IF drop c ELSE fff5 < IF 10 ELSE 20 THEN THEN fat-type !
3649: cr ." FAT" base @ decimal fat-type @ . base !
3650: #reserved-sectors @ bytes/sector @ * fat-offset !
3651: #fats @ sectors/fat @ * bytes/sector @ * fat-offset @ + root-offset !
3652: #root-entries @ 20 * bytes/sector @ tuck // * root-offset @ +
3653: bytes/cluster @ 2* - cluster-offset ! ;
3654: INSTANCE VARIABLE file-cluster
3655: INSTANCE VARIABLE file-len
3656: INSTANCE VARIABLE current-pos
3657: INSTANCE VARIABLE pos-in-data
3658: : seek ( lo hi -- status )
3659: lxjoin dup current-pos ! file-cluster @ read-cluster
3660: BEGIN dup #data @ >= WHILE #data @ - next-cluster @ dup 0= IF
3661: 2drop true EXIT THEN read-cluster REPEAT pos-in-data ! false ;
3662: : read ( adr len -- actual )
3663: file-len @ current-pos @ - min \ can't go past end of file
3664: #data @ pos-in-data @ - min >r \ length for this transfer
3665: data @ pos-in-data @ + swap r@ move \ move the data
3666: r@ pos-in-data +! r@ current-pos +! pos-in-data @ #data @ = IF
3667: next-cluster @ ?dup IF read-cluster 0 pos-in-data ! THEN THEN r> ;
3668: : read ( adr len -- actual )
3669: dup >r BEGIN dup WHILE 2dup read dup 0= ABORT" fat-files: read failed"
3670: /string ( tuck - >r + r> ) REPEAT 2drop r> ;
3671: : load ( adr -- len )
3672: file-len @ read dup file-len @ <> ABORT" fat-files: failed loading file" ;
3673: : close free-data ;
3674: : open
3675: do-super
3676: 0 my-args find-path 0= IF close false EXIT THEN
3677: file-len ! file-cluster ! 0 0 seek 0= ;
3678: finish-device
3679: new-device
3680: s" rom-files" device-name
3681: INSTANCE VARIABLE length
3682: INSTANCE VARIABLE next-file
3683: INSTANCE VARIABLE buffer
3684: INSTANCE VARIABLE buffer-size
3685: INSTANCE VARIABLE file
3686: INSTANCE VARIABLE file-size
3687: INSTANCE VARIABLE found
3688: : open true
3689: 100 dup buffer-size ! alloc-mem buffer ! false found ! ;
3690: : close buffer @ buffer-size @ free-mem ;
3691: : read ( addr len -- actual ) s" read" $call-parent ;
3692: : seek ( lo hi -- status ) s" seek" $call-parent ;
3693: : .read-file-name ( offset -- str len )
3694: 0 seek drop
3695: buffer @ buffer-size @ read drop
3696: buffer-size @ 1 - buffer @ + 0 swap c!
3697: buffer @ zcount ;
3698: : .print-info ( offset -- )
3699: dup 2 spaces 6 0.r 2 spaces dup
3700: 8 + 0 seek drop length 8 read drop
3701: 6 length @ swap 0.r 2 spaces
3702: 20 + .read-file-name type cr ;
3703: : .list-header cr
3704: s" --offset---size-----file-name----" type cr ;
3705: : list
3706: .list-header
3707: 0 0 BEGIN + dup
3708: .print-info dup 0 seek drop
3709: next-file 8 read drop next-file @
3710: dup 0= UNTIL 2drop ;
3711: : (find-file) ( name len -- offset | -1 )
3712: 0 0 seek drop false found !
3713: file-size ! file ! 0 0 BEGIN + dup
3714: 20 + .read-file-name file @ file-size @
3715: str= IF true found ! THEN
3716: dup 0 seek drop
3717: next-file 8 read drop next-file @
3718: dup 0= found @ or UNTIL drop found @ 0=
3719: IF drop -1 THEN ;
3720: : load ( addr -- size )
3721: my-parent instance>args 2@ [char] \ left-parse-string 2drop
3722: (find-file) dup -1 = IF 2drop 0 ELSE
3723: 0 0 seek drop
3724: dup 8 + 0 seek drop
3725: here 8 read drop here @ ( dest-addr offset file-size )
3726: over 18 + 0 seek drop
3727: here 8 read drop here @ ( dest-addr offset file-size data-offset )
3728: rot + 0 seek drop ( dest-addr file-size )
3729: read
3730: THEN
3731: ;
3732: finish-device
3733: new-device
3734: s" ext2-files" device-name
3735: INSTANCE VARIABLE first-block
3736: INSTANCE VARIABLE block-size
3737: INSTANCE VARIABLE inodes/group
3738: INSTANCE VARIABLE group-descriptors
3739: : seek s" seek" $call-parent ;
3740: : read s" read" $call-parent ;
3741: INSTANCE VARIABLE data
3742: INSTANCE VARIABLE #data
3743: : free-data
3744: data @ ?dup IF #data @ free-mem 0 data ! THEN ;
3745: : read-data ( offset size -- )
3746: free-data dup #data ! alloc-mem data !
3747: xlsplit seek -2 and ABORT" ext2-files read-data: seek failed"
3748: data @ #data @ read #data @ <> ABORT" ext2-files read-data: read failed" ;
3749: : read-block ( block# -- )
3750: block-size @ * block-size @ read-data ;
3751: INSTANCE VARIABLE inode
3752: INSTANCE VARIABLE file-len
3753: INSTANCE VARIABLE blocks
3754: INSTANCE VARIABLE #blocks
3755: INSTANCE VARIABLE ^blocks
3756: INSTANCE VARIABLE #blocks-left
3757: : blocks-read ( n -- ) dup negate #blocks-left +! 4 * ^blocks +! ;
3758: : read-indirect-blocks ( indirect-block# -- )
3759: read-block data @ data off
3760: dup #blocks-left @ 4 * block-size @ min dup >r ^blocks @ swap move
3761: r> 2 rshift blocks-read block-size @ free-mem ;
3762: : read-double-indirect-blocks ( double-indirect-block# -- )
3763: ;
3764: : read-triple-indirect-blocks ( triple-indirect-block# -- )
3765: ;
3766: : read-block#s ( -- )
3767: blocks @ ?dup IF #blocks @ 4 * free-mem THEN
3768: inode @ 4 + l@-le file-len !
3769: file-len @ block-size @ // #blocks !
3770: #blocks @ 4 * alloc-mem blocks !
3771: blocks @ ^blocks ! #blocks @ #blocks-left !
3772: #blocks-left @ c min \ # direct blocks
3773: inode @ 28 + over 4 * ^blocks @ swap move blocks-read
3774: #blocks-left @ IF inode @ 58 + l@-le read-indirect-blocks THEN
3775: #blocks-left @ IF inode @ 5c + l@-le read-double-indirect-blocks THEN
3776: #blocks-left @ IF inode @ 60 + l@-le read-triple-indirect-blocks THEN ;
3777: : read-inode ( inode# -- )
3778: 1- inodes/group @ u/mod \ # in group, group #
3779: 20 * group-descriptors @ + 8 + l@-le block-size @ * \ # in group, inode table
3780: swap 80 * + xlsplit seek drop inode @ 80 read drop ;
3781: : .rwx ( bits last-char-if-special special? -- )
3782: rot dup 4 and IF ." r" ELSE ." -" THEN
3783: dup 2 and IF ." w" ELSE ." -" THEN
3784: swap IF 1 and 0= IF upc THEN emit ELSE
3785: 1 and IF ." x" ELSE ." -" THEN drop THEN ;
3786: CREATE mode-chars 10 allot s" ?pc?d?b?-?l?s???" mode-chars swap move
3787: : .mode ( mode -- )
3788: dup c rshift f and mode-chars + c@ emit
3789: dup 6 rshift 7 and over 800 and 73 swap .rwx
3790: dup 3 rshift 7 and over 400 and 73 swap .rwx
3791: dup 7 and swap 200 and 74 swap .rwx ;
3792: : .inode ( -- )
3793: base @ >r decimal
3794: inode @ w@-le .mode \ file mode
3795: inode @ 1a + w@-le 5 .r \ link count
3796: inode @ 02 + w@-le 9 .r \ uid
3797: inode @ 18 + w@-le 9 .r \ gid
3798: inode @ 04 + l@-le 9 .r \ size
3799: r> base ! ;
3800: : do-super ( -- )
3801: 400 400 read-data
3802: data @ 14 + l@-le first-block !
3803: 400 data @ 18 + l@-le lshift block-size !
3804: data @ 28 + l@-le inodes/group !
3805: first-block @ 1+ read-block data @ group-descriptors ! data off ;
3806: INSTANCE VARIABLE current-pos
3807: : read ( adr len -- actual )
3808: file-len @ current-pos @ - min \ can't go past end of file
3809: current-pos @ block-size @ u/mod 4 * blocks @ + l@-le read-block
3810: block-size @ over - rot min >r ( adr off r: len )
3811: data @ + swap r@ move r> dup current-pos +! ;
3812: : read ( adr len -- actual )
3813: dup >r BEGIN dup WHILE 2dup read dup 0= ABORT" ext2-files: read failed"
3814: /string REPEAT 2drop r> ;
3815: : seek ( lo hi -- status )
3816: lxjoin dup file-len @ > IF drop true EXIT THEN current-pos ! false ;
3817: : load ( adr -- len )
3818: file-len @ read dup file-len @ <> ABORT" ext2-files: failed loading file" ;
3819: : .name ( adr -- ) dup 8 + swap 6 + c@ type ;
3820: : read-dir ( inode# -- adr )
3821: read-inode read-block#s file-len @ alloc-mem
3822: 0 0 seek ABORT" ext2-files read-dir: seek failed"
3823: dup file-len @ read file-len @ <> ABORT" ext2-files read-dir: read failed" ;
3824: : .dir ( inode# -- )
3825: read-dir dup BEGIN 2dup file-len @ - > over l@-le tuck and WHILE
3826: cr dup 8 0.r space read-inode .inode space space dup .name
3827: dup 4 + w@-le + REPEAT 2drop file-len @ free-mem ;
3828: : (find-file) ( adr name len -- inode#|0 )
3829: 2>r dup BEGIN 2dup file-len @ - > over l@-le and WHILE
3830: dup 8 + over 6 + c@ 2r@ str= IF 2r> 2drop nip l@-le EXIT THEN
3831: dup 4 + w@-le + REPEAT 2drop 2r> 2drop 0 ;
3832: : find-file ( inode# name len -- inode#|0 )
3833: 2>r read-dir dup 2r> (find-file) swap file-len @ free-mem ;
3834: : find-path ( inode# name len -- inode#|0 )
3835: dup 0= IF 3drop 0 ." empty name " EXIT THEN
3836: over c@ [char] \ = IF 1 /string ." slash " RECURSE EXIT THEN
3837: [char] \ split 2>r find-file ?dup 0= IF
3838: 2r> 2drop false ." not found " EXIT THEN
3839: r@ 0<> IF 2r> ." more... " RECURSE EXIT THEN
3840: 2r> 2drop ." got it " ;
3841: : close ;
3842: : open
3843: do-super
3844: 80 alloc-mem inode !
3845: my-args nip 0= IF 0 0 ELSE
3846: 2 my-args find-path ?dup 0= IF close false EXIT THEN THEN
3847: read-inode read-block#s 0 0 seek 0= ;
3848: finish-device
3849: new-device
3850: s" obp-tftp" device-name
3851: INSTANCE VARIABLE ciregs-buffer
3852: : open ( -- okay? )
3853: ciregs-size alloc-mem ciregs-buffer !
3854: true
3855: ;
3856: : load ( addr -- size )
3857: ciregs ciregs-buffer @ ciregs-size move
3858: s" bootargs" get-chosen 0= IF 0 0 THEN >r >r
3859: s" bootpath" get-chosen 0= IF 0 0 THEN >r >r
3860: my-parent ihandle>phandle node>path encode-string
3861: s" bootpath" set-chosen
3862: (u.) s" netboot " 2swap $cat s" 60000000 " $cat
3863: 6B8 alloc-mem dup >r (u.) $cat s" " $cat
3864: huge-tftp-load @ IF s" 1 " ELSE s" 0 " THEN $cat
3865: s" 1432 " $cat
3866: my-args $cat
3867: (client-exec) dup 0< IF drop 0 THEN
3868: ciregs-buffer @ ciregs ciregs-size move
3869: r>
3870: r> r> over IF s" bootpath" set-chosen ELSE 2drop THEN
3871: r> r> over IF s" bootargs" set-chosen ELSE 2drop THEN
3872: s" /chosen" select-dev
3873: dup 6B8 encode-bytes s" bootp-response" property
3874: device-end
3875: 6B8 free-mem
3876: ;
3877: : close ( -- )
3878: ciregs-buffer @ ciregs-size free-mem
3879: ;
3880: : ping ( -- )
3881: s" ping " my-args $cat (client-exec)
3882: ;
3883: finish-device
3884: new-device
3885: s" iso-9660" device-name
3886: 0 VALUE iso-debug-flag
3887: : iso-debug-print ( str len -- ) iso-debug-flag IF type cr ELSE 2drop THEN ;
3888: 0 VALUE path-tbl-size
3889: 0 VALUE path-tbl-addr
3890: 0 VALUE root-dir-size
3891: 0 VALUE vol-size
3892: 0 VALUE logical-blk-size
3893: 0 VALUE path-table
3894: 0 VALUE count
3895: INSTANCE VARIABLE dir-addr
3896: INSTANCE VARIABLE data-buff
3897: INSTANCE VARIABLE #data
3898: INSTANCE VARIABLE ptable
3899: INSTANCE VARIABLE file-loc
3900: INSTANCE VARIABLE file-size
3901: INSTANCE VARIABLE cur-file-offset
3902: INSTANCE VARIABLE self
3903: INSTANCE VARIABLE index
3904: : seek ( pos.lo pos.hi -- status ) s" seek" $call-parent ;
3905: : read ( addr len -- actual ) s" read" $call-parent ;
3906: : free-data ( -- )
3907: data-buff @ ( data-buff )
3908: ?DUP IF #data @ free-mem 0 data-buff ! THEN
3909: ;
3910: : read-data ( offset size -- )
3911: free-data DUP ( offset size size )
3912: #data ! alloc-mem data-buff ! ( offset )
3913: xlsplit ( pos.lo pos.hi )
3914: seek -2 and ABORT" seek failed."
3915: data-buff @ #data @ read ( actual )
3916: #data @ <> ABORT" read failed."
3917: ;
3918: : extract-vol-info ( -- )
3919: 10 800 * 800 read-data
3920: data-buff @ 88 + l@-be to path-tbl-size \ read path table size
3921: data-buff @ 94 + l@-be to path-tbl-addr \ read big-endian path table
3922: data-buff @ a2 + l@-be dir-addr ! \ gather of root directory info
3923: data-buff @ 0aa + l@-be to root-dir-size \ get volume info
3924: data-buff @ 54 + l@-be to vol-size \ size in blocks
3925: data-buff @ 82 + l@-be to logical-blk-size
3926: path-tbl-size alloc-mem dup TO path-table path-tbl-size erase
3927: path-tbl-addr 800 * xlsplit seek drop
3928: path-table path-tbl-size read drop \ pathtable in-system-memory copy
3929: ;
3930: : file-name ( str len -- str' len' )
3931: 2dup [char] ; findchar IF
3932: nip \ Omit the trailing ";1" revision of ISO9660 file name
3933: 2dup + 1- ( str newlen endptr )
3934: c@ [CHAR] . = IF
3935: 1- ( str len' ) \ Remove trailing dot
3936: THEN
3937: THEN
3938: ;
3939: : dup3 ( num -- num num num ) dup dup dup ;
3940: : get-next-record ( rec-addr -- next-rec-offset )
3941: dup3 ( rec-addr rec-addr rec-addr rec-addr )
3942: self @ 1 + self ! ( rec-addr rec-addr rec-addr rec-addr )
3943: c@ 1 AND IF ( rec-addr rec-addr rec-addr )
3944: c@ + 9 ( rec-addr rec-addr' rec-len )
3945: ELSE
3946: c@ + 8 ( rec-addr rec-addr' rec-len )
3947: THEN
3948: + swap - ( next-rec-offset )
3949: ;
3950: : path-table-search ( str len -- TRUE | FALSE )
3951: path-table path-tbl-size + path-table ptable @ + DO ( str len )
3952: 2dup I 6 + w@-be index @ = ( str len str len )
3953: -rot I 8 + I c@ string=ci and IF ( str len )
3954: s" Directory Matched!! " iso-debug-print ( str len )
3955: self @ index ! ( str len )
3956: I 2 + l@-be dir-addr ! I dup ( str len rec-addr )
3957: get-next-record + path-table - ptable ! ( str len )
3958: 2drop TRUE UNLOOP EXIT ( TRUE )
3959: THEN
3960: I get-next-record ( str len next-rec-offset )
3961: +LOOP
3962: 2drop
3963: FALSE ( FALSE )
3964: s" Invalid path / directory " iso-debug-print
3965: ;
3966: : search-file-dir ( str len -- TRUE | FALSE )
3967: dir-addr @ 800 * dir-addr ! ( str len )
3968: dir-addr @ 100 read-data ( str len )
3969: data-buff @ 0e + l@-be dup >r ( str len rec-len )
3970: 100 > IF ( str len )
3971: s" size dir record" iso-debug-print ( str len )
3972: dir-addr @ r@ read-data ( str len )
3973: THEN
3974: r> data-buff @ + data-buff @ DO ( str len )
3975: I 19 + c@ 2 and 0= IF ( str len )
3976: 2dup ( str len str len )
3977: I 21 + I 20 + c@ ( str len str len str' len' )
3978: file-name string=ci IF ( str len )
3979: s" File found!" iso-debug-print ( str len )
3980: I 6 + l@-be 800 * ( str len file-loc )
3981: file-loc ! ( str len )
3982: I 0e + l@-be file-size ! ( str len )
3983: 2drop
3984: TRUE ( TRUE )
3985: UNLOOP
3986: EXIT
3987: THEN
3988: THEN
3989: I c@ dup 0= IF ( str len len )
3990: s" file not found" iso-debug-print
3991: drop 2drop FALSE ( FALSE )
3992: UNLOOP
3993: EXIT
3994: THEN
3995: +LOOP
3996: 2drop
3997: FALSE ( FALSE )
3998: s" file not found" iso-debug-print
3999: ;
4000: : search-path ( str len -- FALSE|TRUE )
4001: 0 ptable !
4002: 1 self !
4003: 1 index !
4004: dup ( str len len )
4005: 0= IF
4006: 3drop FALSE ( FALSE )
4007: s" Empty path name " iso-debug-print EXIT ( FALSE )
4008: THEN
4009: OVER c@ ( str len char )
4010: [char] \ = IF ( str len )
4011: swap 1 + swap 1 - BEGIN ( str len )
4012: [char] \ split ( str len str' len ' )
4013: dup 0 = IF ( str len str' len ' )
4014: 2drop search-file-dir EXIT ( TRUE | FALSE )
4015: ELSE
4016: 2swap path-table-search invert IF ( str' len ' )
4017: 2drop FALSE EXIT ( FALSE )
4018: THEN
4019: THEN
4020: AGAIN
4021: ELSE BEGIN
4022: [char] \ split dup 0 = IF ( str len str' len' )
4023: 2drop search-file-dir EXIT ( TRUE | FALSE )
4024: ELSE
4025: 2swap path-table-search invert IF ( str' len ' )
4026: 2drop FALSE EXIT ( FALSE )
4027: THEN
4028: THEN
4029: AGAIN
4030: THEN
4031: ;
4032: 0 VALUE loc
4033: : load ( addr -- len )
4034: dup to loc ( addr )
4035: file-loc @ xlsplit seek drop
4036: file-size @ read ( file-size )
4037: iso-debug-flag IF s" Bytes returned from read:" type dup . cr THEN
4038: dup file-size @ <> ABORT" read failed!"
4039: ;
4040: : close ( -- )
4041: free-data count 1 - dup to count 0 = IF
4042: path-table path-tbl-size free-mem
4043: 0 TO path-table
4044: THEN
4045: ;
4046: : open ( -- TRUE | FALSE )
4047: 0 data-buff !
4048: 0 #data !
4049: 0 ptable !
4050: 0 file-loc !
4051: 0 file-size !
4052: 0 cur-file-offset !
4053: 1 self !
4054: 1 index !
4055: count 0 = IF
4056: s" extract-vol-info called " iso-debug-print
4057: extract-vol-info
4058: THEN
4059: count 1 + to count
4060: my-args search-path IF
4061: file-loc @ xlsplit seek drop
4062: TRUE ( TRUE )
4063: ELSE
4064: close
4065: FALSE ( FALSE )
4066: THEN
4067: 0 cur-file-offset !
4068: s" opened ISO9660 package" iso-debug-print
4069: ;
4070: : seek ( pos.lo pos.hi -- status )
4071: lxjoin dup cur-file-offset ! ( offset )
4072: file-loc @ + xlsplit ( pos.lo pos.hi )
4073: s" seek" $call-parent ( status )
4074: ;
4075: : read ( addr len -- actual )
4076: file-size @ cur-file-offset @ - ( addr len remainder-of-file )
4077: min ( addr len|remainder-of-file )
4078: s" read" $call-parent ( actual )
4079: dup cur-file-offset @ + cur-file-offset ! ( actual )
4080: cur-file-offset @ ( offset actual )
4081: xlsplit seek drop ( actual )
4082: ;
4083: finish-device
4084: new-device
4085: s" bulk" device-name
4086: : open true ;
4087: : close ;
4088: 8 chars alloc-mem VALUE setup-packet
4089: 0 VALUE cbw-addr
4090: : build-cbw ( address tag transfer-len direction lun command-len -- )
4091: 5 pick TO cbw-addr ( address tag transfer-len direction lun command-len )
4092: cbw-addr 0f erase ( address tag transfer-len direction lun command-len )
4093: cbw-addr e + c! ( address tag transfer-len direction lun )
4094: cbw-addr d + c! ( address tag transfer-len direction )
4095: cbw-addr c + c! ( address tag transfer-len )
4096: cbw-addr 8 + l!-le ( address tag )
4097: cbw-addr 4 + l!-le ( address )
4098: 43425355 cbw-addr l!-le ( address )
4099: drop ;
4100: 0 VALUE csw-addr
4101: : analyze-csw ( address -- residue tag true|reason false )
4102: TO csw-addr
4103: csw-addr l@-le 53425355 = IF
4104: csw-addr c + c@ dup 0= IF ( reason )
4105: drop
4106: csw-addr 8 + l@-le ( residue )
4107: csw-addr 4 + l@-le ( residue tag ) \ command block tag
4108: TRUE ( residue tag TRUE )
4109: ELSE
4110: FALSE ( reason FALSE )
4111: THEN
4112: ELSE
4113: FALSE ( FALSE )
4114: THEN
4115: csw-addr 0c erase
4116: ;
4117: : bulk-reset-recovery-procedure ( bulk-out-endp bulk-in-endp usb-addr -- )
4118: s" bulk-reset-recovery-procedure" $call-parent
4119: ;
4120: finish-device
4121: finish-device
4122: : open true ;
4123: : close ;
4124: device-end
4125: 370 cp
4126: : strequal ( str1 len1 str2 len2 -- flag )
4127: rot dup rot = IF comp 0= ELSE 2drop drop 0 THEN ;
4128: 400 cp
4129: 0 value puid
4130: 440 cp
4131: 480 cp
4132: " /" find-device
4133: " QEMU" encode-string s" model" property
4134: 2 encode-int s" #address-cells" property
4135: 2 encode-int s" #size-cells" property
4136: s" chrp" device-type
4137: new-device
4138: s" mmu" 2dup device-name device-type
4139: 0 0 s" translations" property
4140: : open true ;
4141: : close ;
4142: finish-device
4143: device-end
4144: 4c0 cp
4145: : fixup-tbfreq
4146: " /cpus/@0" find-device
4147: " timebase-frequency" get-node get-package-property IF
4148: 2drop
4149: ELSE
4150: decode-int to tb-frequency 2drop
4151: THEN
4152: device-end
4153: ;
4154: fixup-tbfreq
4155: 4d0 cp
4156: 4d0 cp
4157: STRUCT
4158: /l field rtas>token
4159: /l field rtas>nargs
4160: /l field rtas>nret
4161: /l field rtas>args0
4162: /l field rtas>args1
4163: /l field rtas>args2
4164: /l field rtas>args3
4165: /l field rtas>args4
4166: /l field rtas>args5
4167: /l field rtas>args6
4168: /l field rtas>args7
4169: /l C * field rtas>args
4170: /l field rtas>bla
4171: CONSTANT /rtas-control-block
4172: CREATE rtas-cb /rtas-control-block allot
4173: rtas-cb /rtas-control-block erase
4174: 0 VALUE rtas-base
4175: 0 VALUE rtas-size
4176: 0 VALUE rtas-entry
4177: 0 VALUE rtas-node
4178: 4d1 cp
4179: : find-qemu-rtas ( -- )
4180: " /rtas" find-device get-node to rtas-node
4181: " linux,rtas-base" rtas-node get-package-property IF
4182: device-end EXIT THEN
4183: drop l@ to rtas-base
4184: " linux,rtas-base" delete-property
4185: " rtas-size" rtas-node get-package-property IF
4186: device-end EXIT THEN
4187: drop l@ to rtas-size
4188: " linux,rtas-entry" rtas-node get-package-property IF
4189: rtas-base to rtas-entry
4190: ELSE
4191: drop l@ to rtas-entry
4192: " linux,rtas-entry" delete-property
4193: THEN
4194: device-end
4195: ;
4196: find-qemu-rtas
4197: 4d2 cp
4198: : enter-rtas ( -- )
4199: rtas-cb rtas-base 0 rtas-entry call-c drop
4200: ;
4201: : rtas-get-token ( str len -- token | 0 )
4202: rtas-node get-package-property IF 0 ELSE drop l@ THEN
4203: ;
4204: : rtas-start-cpu ( pid loc r3 -- status )
4205: " start-cpu" rtas-get-token rtas-cb rtas>token l!
4206: 3 rtas-cb rtas>nargs l!
4207: 1 rtas-cb rtas>nret l!
4208: rtas-cb rtas>args2 l!
4209: rtas-cb rtas>args1 l!
4210: rtas-cb rtas>args0 l!
4211: 0 rtas-cb rtas>args3 l!
4212: enter-rtas
4213: rtas-cb rtas>args3 l@
4214: ;
4215: : rtas-set-tce-bypass ( unit enable -- )
4216: " ibm,set-tce-bypass" rtas-get-token rtas-cb rtas>token l!
4217: 2 rtas-cb rtas>nargs l!
4218: 0 rtas-cb rtas>nret l!
4219: rtas-cb rtas>args1 l!
4220: rtas-cb rtas>args0 l!
4221: enter-rtas
4222: ;
4223: : rtas-quiesce ( -- )
4224: " quiesce" rtas-get-token rtas-cb rtas>token l!
4225: 0 rtas-cb rtas>nargs l!
4226: 0 rtas-cb rtas>nret l!
4227: enter-rtas
4228: ;
4229: : of-start-cpu rtas-start-cpu ;
4230: rtas-node set-node
4231: : open true ;
4232: : close ;
4233: : instantiate-rtas ( adr -- entry )
4234: dup rtas-base swap rtas-size move
4235: rtas-entry rtas-base - +
4236: ;
4237: device-end
4238: 4d8 cp
4239: 500 cp
4240: : populate-vios ( -- )
4241: ." Populating /vdevice methods" cr
4242: " /vdevice" find-device get-node child
4243: BEGIN
4244: dup 0 <>
4245: WHILE
4246: dup set-node
4247: dup " compatible" rot get-package-property 0 = IF
4248: drop dup from-cstring
4249: 2dup " hvterm1" strequal IF
4250: " vio-hvterm.fs" included
4251: THEN
4252: 2dup " IBM,v-scsi" strequal IF
4253: " vio-vscsi.fs" included
4254: THEN
4255: 2dup " IBM,l-lan" strequal IF
4256: " vio-veth.fs" included
4257: THEN
4258: 2drop
4259: THEN
4260: peer
4261: REPEAT drop
4262: device-end
4263: ;
4264: populate-vios
4265: 580 cp
4266: 5a0 cp
4267: 600 cp
4268: ' rtas-quiesce add-quiesce-xt
4269: 640 cp
4270: 690 cp
4271: 6a0 cp
4272: 6a8 cp
4273: 6b0 cp
4274: 6b8 cp
4275: 6c0 cp
4276: s" /cpus/@0" open-dev encode-int s" cpu" set-chosen
4277: s" /memory" open-dev encode-int s" memory" set-chosen
4278: 6e0 cp
4279: 700 cp
4280: s" /openprom" find-device
4281: s" SLOF," slof-build-id here swap rmove here slof-build-id nip $cat encode-string s" model" property
4282: 0 0 s" relative-addressing" property
4283: device-end
4284: s" /aliases" find-device
4285: : open true ;
4286: : close ;
4287: device-end
4288: s" /mmu" open-dev encode-int s" mmu" set-chosen
4289: VARIABLE chosen-memory-ih 0 chosen-memory-ih !
4290: : (chosen-memory-ph) ( -- phandle )
4291: chosen-memory-ih @ ?dup 0= IF
4292: s" memory" get-chosen IF
4293: decode-int nip nip dup chosen-memory-ih !
4294: ihandle>phandle
4295: ELSE 0 THEN
4296: ELSE ihandle>phandle THEN
4297: ;
4298: : (set-available-prop) ( prop plen -- )
4299: s" available"
4300: (chosen-memory-ph) ?dup 0<> IF set-property ELSE
4301: cr ." Can't find chosen memory node - "
4302: ." no available property created" cr
4303: 2dup 2dup
4304: THEN
4305: ;
4306: : update-available-property ( available-ptr -- )
4307: dup >r available>size@
4308: 0= r@ available AVAILABLE-SIZE /available * + >= or IF
4309: available r> available - encode-bytes (set-available-prop)
4310: ELSE
4311: r> /available + RECURSE
4312: THEN
4313: ;
4314: : update-available-property available update-available-property ;
4315: : claim ( [ addr ] len align -- base ) claim update-available-property ;
4316: : release ( addr len -- ) release update-available-property ;
4317: update-available-property
4318: : input ( dev-str dev-len -- )
4319: open-dev ?dup IF
4320: s" stdin" get-chosen IF
4321: decode-int nip nip ?dup IF close-dev THEN
4322: THEN
4323: encode-int s" stdin" set-chosen
4324: THEN
4325: ;
4326: : output ( dev-str dev-len -- )
4327: open-dev ?dup IF
4328: s" stdout" get-chosen IF
4329: decode-int nip nip ?dup IF close-dev THEN
4330: THEN
4331: encode-int s" stdout" set-chosen
4332: THEN
4333: ;
4334: : io ( dev-str dev-len -- )
4335: 2dup input output
4336: ;
4337: 1 BUFFER: (term-io-char-buf)
4338: : term-io-key ( -- char )
4339: s" stdin" get-chosen IF
4340: decode-int nip nip dup 0= IF 0 EXIT THEN
4341: >r BEGIN
4342: (term-io-char-buf) 1 s" read" r@ $call-method
4343: 0 >
4344: UNTIL
4345: (term-io-char-buf) c@
4346: r> drop
4347: THEN
4348: ;
4349: ' term-io-key to key
4350: : term-io-key? ( -- true|false )
4351: s" stdin" get-chosen IF
4352: decode-int nip nip dup 0= IF drop 0 EXIT THEN \ return false and exit if no stdin set
4353: >r \ store ihandle on return stack
4354: s" device_type" r@ ihandle>phandle ( propstr len phandle )
4355: get-property ( true | data dlen false )
4356: IF
4357: false
4358: ELSE
4359: 1 - \ remove 1 from length to ignore null-termination char
4360: 2dup s" serial" str= IF
4361: 2drop serial-key? r> drop EXIT
4362: THEN \ call serial-key, cleanup return-stack, exit
4363: 2dup s" keyboard" str= IF
4364: 2drop ( )
4365: s" key-available?" r@ ihandle>phandle find-method IF
4366: drop s" key-available?" r@ $call-method
4367: ELSE
4368: false
4369: THEN
4370: r> drop EXIT \ cleanup return-stack, exit
4371: THEN
4372: 2drop r> drop false EXIT \ unknown device_type cleanup return-stack, return false
4373: THEN
4374: ELSE
4375: false
4376: THEN
4377: ;
4378: ' term-io-key? to key?
4379: " hvterm" find-alias IF drop
4380: " hvterm" io
4381: THEN
4382: 800 cp
4383: 51 CONSTANT nvram-partition-type-cpulog
4384: 60 CONSTANT nvram-partition-type-sas
4385: 61 CONSTANT nvram-partition-type-sms
4386: 6e CONSTANT nvram-partition-type-debug
4387: 6f CONSTANT nvram-partition-type-history
4388: 70 CONSTANT nvram-partition-type-common
4389: 7f CONSTANT nvram-partition-type-freespace
4390: a0 CONSTANT nvram-partition-type-linux
4391: : rztype ( str len -- ) \ stop at zero byte, read with nvram-c@
4392: 0 DO
4393: dup i + nvram-c@ ?dup IF ( str char )
4394: emit
4395: ELSE ( str )
4396: drop UNLOOP EXIT
4397: THEN
4398: LOOP
4399: ;
4400: create tmpStr 500 allot
4401: : rzcount ( zstr -- str len )
4402: dup tmpStr >r BEGIN
4403: dup nvram-c@ dup r> dup 1+ >r c!
4404: WHILE
4405: char+
4406: REPEAT
4407: r> drop over - swap drop tmpStr swap
4408: ;
4409: : calc-header-cksum ( offset -- cksum )
4410: dup nvram-c@
4411: 10 2 DO
4412: over I + nvram-c@ +
4413: LOOP
4414: wbsplit + nip
4415: ;
4416: : bad-header? ( offset -- flag )
4417: dup 2+ nvram-w@ ( offset length )
4418: 0= IF ( offset )
4419: drop true EXIT ( )
4420: THEN
4421: dup calc-header-cksum ( offset checksum' )
4422: swap 1+ nvram-c@ ( checksum ' checksum )
4423: <> ( flag )
4424: ;
4425: : .header ( offset -- )
4426: cr ( offset )
4427: dup bad-header? IF ( offset )
4428: ." BAD HEADER -- trying to print it anyway" cr
4429: THEN
4430: space ( offset )
4431: dup nvram-c@ 2 0.r ( offset )
4432: space space ( offset )
4433: dup 2+ nvram-w@ 10 * 5 .r ( offset )
4434: space space ( offset )
4435: 4 + 0c rztype ( )
4436: ;
4437: : .headers ( -- )
4438: cr cr ." Type Size Name"
4439: cr ." ========================"
4440: 0 BEGIN ( offset )
4441: dup nvram-c@ ( offset type )
4442: WHILE
4443: dup .header ( offset )
4444: dup 2+ nvram-w@ 10 * + ( offset offset' )
4445: dup nvram-size < IF ( offset )
4446: ELSE
4447: drop EXIT ( )
4448: THEN
4449: REPEAT
4450: drop ( )
4451: cr cr
4452: ;
4453: : reset-nvram ( -- )
4454: internal-reset-nvram
4455: ;
4456: : dump-partition ['] nvram-c@ 1 (dump) ;
4457: : type-no-zero ( addr len -- )
4458: 0 DO
4459: dup I + dup nvram-c@ 0= IF drop ELSE nvram-c@ emit THEN
4460: LOOP
4461: drop
4462: ;
4463: : type-no-zero-part ( from-str cnt-str addr len )
4464: 0 DO
4465: dup i + dup nvram-c@ 0= IF
4466: drop
4467: ELSE
4468: 3 pick 0= 3 pick 0 > AND IF
4469: dup 1 type-no-zero
4470: THEN
4471: nvram-c@ a = IF
4472: 2 pick 0= IF
4473: over 1- 0 max
4474: rot drop swap
4475: THEN
4476: 2 pick 1- 0 max
4477: 3 roll drop rot rot
4478: THEN
4479: THEN
4480: LOOP
4481: drop
4482: ;
4483: : (dmesg-prepare) ( base-addr -- base-addr' addr len act-off )
4484: 10 - \ go back to header
4485: dup 14 + nvram-l@ dup >r
4486: ( base-addr act-off ) ( R: act-off )
4487: over over over + swap 10 + nvram-w@ + >r
4488: ( base-addr act-off ) ( R: act-off nvram-act-addr )
4489: over 2 + nvram-w@ 10 * swap - over swap
4490: ( base-addr base-addr start-size ) ( R: act-off nvram-act-addr )
4491: r> swap rot 10 + nvram-w@ - r>
4492: ;
4493: : .dmesg ( base-addr -- )
4494: (dmesg-prepare) >r
4495: cr type-no-zero
4496: ( base-addr ) ( R: act-off )
4497: dup 10 + nvram-w@ + r> type-no-zero
4498: ;
4499: : .dmesg-part ( from-str cnt-str base-addr -- )
4500: (dmesg-prepare) >r
4501: >r >r -rot r> r>
4502: cr type-no-zero-part rot
4503: ( base-addr ) ( R: act-off )
4504: dup 10 + nvram-w@ + r> type-no-zero-part
4505: ;
4506: : dmesg-part ( from-str cnt-str -- left-from-str left-cnt-str )
4507: 2dup
4508: s" ibm,BE0log" get-named-nvram-partition IF
4509: s" ibm,CPU0log" get-named-nvram-partition IF
4510: 2drop EXIT
4511: THEN
4512: THEN
4513: drop .dmesg-part nip nip
4514: ;
4515: : dmesg2 ( -- )
4516: s" ibm,BE1log" get-named-nvram-partition IF
4517: s" ibm,CPU1log" get-named-nvram-partition IF
4518: ." No log partition." cr EXIT
4519: THEN
4520: THEN
4521: drop .dmesg
4522: ;
4523: : dmesg ( -- )
4524: s" ibm,BE0log" get-named-nvram-partition IF
4525: s" ibm,CPU0log" get-named-nvram-partition IF
4526: ." No log partition." cr EXIT
4527: THEN
4528: THEN
4529: drop .dmesg
4530: ;
4531: 880 cp
4532: wordlist CONSTANT envvars
4533: : listenv ( -- )
4534: get-current envvars set-current words set-current
4535: ;
4536: : create-env ( "name" -- )
4537: get-current envvars set-current CREATE set-current
4538: ;
4539: : env-int ( n -- ) 1 c, align , DOES> char+ aligned @ ;
4540: : env-bytes ( a len -- )
4541: 2 c, align dup , here swap dup allot move
4542: DOES> char+ aligned dup @ >r cell+ r>
4543: ;
4544: : env-string ( str len -- ) 3 c, string, DOES> char+ count ;
4545: : env-flag ( f -- ) 4 c, c, DOES> char+ c@ 0<> ;
4546: : env-secmode ( sm -- ) 5 c, c, DOES> char+ c@ ;
4547: : default-int ( n "name" -- ) create-env env-int ;
4548: : default-bytes ( a len "name" -- ) create-env env-bytes ;
4549: : default-string ( a len "name" -- ) create-env env-string ;
4550: : default-flag ( f "name" -- ) create-env env-flag ;
4551: : default-secmode ( sm "name" -- ) create-env env-secmode ;
4552: : set-option ( option-name len option len -- )
4553: 2swap encode-string
4554: 2swap s" /options" find-node dup IF set-property ELSE drop 2drop 2drop THEN
4555: ;
4556: : findenv ( name len -- adr def-adr type | 0 )
4557: 2dup envvars voc-find dup 0<> IF ( ABORT" not a configuration variable" )
4558: link> >body char+ >r (find-order) link> >body dup char+ swap c@ r> swap
4559: ELSE
4560: nip nip
4561: THEN
4562: ;
4563: : test-flag ( param len -- true | false )
4564: 2dup s" true" string=ci -rot s" false" string=ci or
4565: ;
4566: : test-secmode ( param len -- true | false )
4567: 2dup s" none" string=ci -rot 2dup s" command" string=ci -rot s" full"
4568: string=ci or or
4569: ;
4570: : isdigit ( char -- true | false )
4571: 30 39 between
4572: ;
4573: : test-int ( param len -- true | false )
4574: drop c@ isdigit if true else false then ;
4575: : test-string ( param len -- true | false )
4576: 0 ?DO
4577: dup i + c@ \ Get character / byte at current index
4578: dup 20 < swap 7e > OR IF \ Is it out of range 32 to 126 (=ASCII)
4579: drop FALSE UNLOOP EXIT \ FALSE means: No ASCII string
4580: THEN
4581: LOOP
4582: drop TRUE \ Only ASCII found --> it is a string
4583: ;
4584: : findtype ( param len name len -- param len name len type )
4585: 2dup findenv dup 0= \ try to find type of envvar
4586: IF \ no type found
4587: drop 2swap
4588: 2dup test-flag if 4 -rot else
4589: 2dup test-secmode if 5 -rot else
4590: 2dup test-int if 1 -rot else
4591: 2dup test-string IF 3 ELSE 2 THEN \ 3 = string, 2 = default to bytes
4592: -rot then then then
4593: rot
4594: >r 2swap r>
4595: else \ take type from default value
4596: nip nip
4597: THEN
4598: ;
4599: : $setenv ( param len name len -- )
4600: 4dup set-option
4601: findtype dup 0=
4602: IF
4603: true ABORT" not a configuration variable"
4604: ELSE
4605: -rot $CREATE CASE
4606: 1 OF evaluate env-int ENDOF \ XXX: wants decimal and 0x...
4607: 2 OF
4608: 2dup ( param len param len )
4609: depth >r ( param len param len R: depth-before )
4610: ['] evaluate CATCH IF \ Catch 'unknown Forth words'...
4611: 2drop r> drop
4612: env-string \ and encode 'unknown word' as string
4613: ELSE
4614: depth r> = IF env-bytes ELSE env-int THEN
4615: 2drop
4616: THEN
4617: ENDOF
4618: 3 OF env-string ENDOF
4619: 4 OF evaluate env-flag ENDOF
4620: 5 OF evaluate env-secmode ENDOF \ XXX: recognize none, command, full
4621: ENDCASE
4622: THEN
4623: ;
4624: : (printenv) ( adr type -- )
4625: CASE
4626: 1 OF aligned @ . ENDOF
4627: 2 OF aligned dup cell+ swap @ dup IF dump ELSE 2drop THEN ENDOF
4628: 3 OF count type ENDOF
4629: 4 OF c@ IF ." true" ELSE ." false" THEN ENDOF
4630: 5 OF c@ . ENDOF \ XXX: print symbolically
4631: ENDCASE
4632: ;
4633: : .printenv-header ( -- )
4634: cr
4635: s" ---environment variable--------current value-------------default value------"
4636: type cr
4637: ;
4638: DEFER old-emit
4639: 0 VALUE emit-counter
4640: : emit-and-count emit-counter 1 + to emit-counter old-emit ;
4641: : .enable-emit-counter
4642: 0 to emit-counter
4643: ['] emit behavior to old-emit
4644: ['] emit-and-count to emit
4645: ;
4646: : .disable-emit-counter
4647: ['] old-emit behavior to emit
4648: ;
4649: : .spaces
4650: dup 0 > IF spaces ELSE
4651: drop space THEN
4652: ;
4653: : .print-one-env
4654: 3 .spaces
4655: 2dup dup -rot type 1c swap - .spaces
4656: findenv rot over
4657: .enable-emit-counter
4658: (printenv) .disable-emit-counter
4659: 1a emit-counter - .spaces
4660: (printenv)
4661: ;
4662: : .print-all-env
4663: .printenv-header
4664: envvars cell+ BEGIN @ dup WHILE dup link> >name
4665: name>string .print-one-env cr REPEAT drop
4666: ;
4667: : printenv
4668: parse-word dup 0= IF
4669: 2drop .print-all-env ELSE findenv dup 0=
4670: ABORT" not a configuration variable"
4671: rot over cr ." Current: " (printenv)
4672: cr ." Default: " (printenv) THEN
4673: ;
4674: : (set-default) ( def-xt -- )
4675: dup >name name>string $CREATE dup >body c@ >r execute r> CASE
4676: 1 OF env-int ENDOF
4677: 2 OF env-bytes ENDOF
4678: 3 OF env-string ENDOF
4679: 4 OF env-flag ENDOF
4680: 5 OF env-secmode ENDOF ENDCASE
4681: ;
4682: true default-flag auto-boot?
4683: s" " default-string boot-device
4684: s" " default-string boot-file
4685: s" boot" default-string boot-command
4686: s" " default-string diag-device
4687: s" " default-string diag-file
4688: false default-flag diag-switch?
4689: true default-flag fcode-debug?
4690: s" " default-string input-device
4691: s" " default-string nvramrc
4692: s" " default-string oem-banner
4693: false default-flag oem-banner?
4694: 0 0 default-bytes oem-logo
4695: false default-flag oem-logo?
4696: s" " default-string output-device
4697: 200 default-int screen-#columns
4698: 200 default-int screen-#rows
4699: 0 default-int security-#badlogins
4700: 0 default-secmode security-mode
4701: s" " default-string security-password
4702: 0 default-int selftest-#megs
4703: false default-flag use-nvramrc?
4704: false default-flag direct-serial?
4705: true default-flag real-mode?
4706: true default-flag use-axon-ddr?
4707: VARIABLE nvoff \ offset in envvar partition
4708: : (nvupdate-one) ( adr type -- "value" )
4709: CASE
4710: 1 OF aligned @ (.) ENDOF
4711: 2 OF drop s" 0 0" ENDOF
4712: 3 OF count ENDOF
4713: 4 OF c@ IF s" true" ELSE s" false" THEN ENDOF
4714: 5 OF c@ (.) ENDOF \ XXX: print symbolically
4715: ENDCASE
4716: ;
4717: : nvupdate-one ( def-xt -- )
4718: >r nvram-partition-type-common get-nvram-partition ( part.addr part.len FALSE|TRUE R: def-xt )
4719: ABORT" No valid NVRAM." r> ( part.addr part.len def-xt )
4720: >name name>string ( part.addr part.len var.a var.l )
4721: 2dup findenv nip (nvupdate-one)
4722: internal-add-env
4723: drop
4724: ;
4725: : (nvupdate) ( -- )
4726: nvram-partition-type-common get-nvram-partition ABORT" No valid NVRAM."
4727: erase-nvram-partition drop
4728: envvars cell+
4729: BEGIN @ dup WHILE dup link> nvupdate-one REPEAT
4730: drop
4731: ;
4732: : nvupdate ( -- )
4733: ." nvupdate is obsolete." cr
4734: ;
4735: : set-default
4736: parse-word envvars voc-find
4737: dup 0= ABORT" not a configuration variable" link> (set-default)
4738: ;
4739: : (set-defaults)
4740: envvars cell+
4741: BEGIN @ dup WHILE dup link> (set-default) REPEAT
4742: drop
4743: ;
4744: (set-defaults)
4745: : set-defaults
4746: (set-defaults) (nvupdate)
4747: ;
4748: : setenv parse-word ( skipws ) 0d parse -leading 2swap $setenv (nvupdate) ;
4749: : get-nv ( -- )
4750: nvram-partition-type-common get-nvram-partition ( addr offset not-found | not-found ) \ find partition header
4751: IF
4752: ." No NVRAM common partition, re-initializing..." cr
4753: internal-reset-nvram
4754: (nvupdate)
4755: nvram-partition-type-common get-nvram-partition IF ." NVRAM seems to be broken." cr EXIT THEN
4756: THEN
4757: drop ( addr ) \ throw away offset
4758: BEGIN
4759: dup rzcount dup \ make string from offset and make condition
4760: WHILE ( offset offset length )
4761: 2dup [char] = split \ Split string at equal sign (=)
4762: 2swap ( offset offset length param len name len )
4763: $setenv \ Set envvar
4764: nip \ throw away old string begin
4765: + 1+ \ calc new offset
4766: REPEAT
4767: 2drop drop \ cleanup
4768: ;
4769: get-nv
4770: : check-for-nvramrc ( -- )
4771: use-nvramrc? IF
4772: s" Executing following code from nvramrc: "
4773: s" nvramrc" evaluate $cat
4774: nvramlog-write-string-cr
4775: s" (!) Executing code specified in nvramrc" type
4776: cr s" SLOF Setup = " type
4777: .enable-emit-counter
4778: s" nvramrc" evaluate ['] evaluate CATCH IF
4779: 2drop
4780: emit-counter 0 DO 8 emit LOOP
4781: s" (!) Code in nvramrc triggered exception. "
4782: 2dup nvramlog-write-string
4783: type cr 12 spaces s" Aborting nvramrc execution" 2dup
4784: nvramlog-write-string-cr type cr
4785: s" SLOF Setup = " type
4786: THEN
4787: .disable-emit-counter
4788: THEN
4789: ;
4790: : (nv-findalias) ( alias-ptr alias-len -- pos )
4791: here 0
4792: s" devalias " string-cat
4793: 3 pick 3 pick string-cat
4794: s" " string-cat
4795: s" nvramrc" evaluate
4796: 2swap find-substr
4797: nip nip
4798: ;
4799: : (nv-build-real-entry) ( name-ptr name-len dev-ptr dev-len -- str-ptr str-len )
4800: 2swap here 0
4801: s" devalias " string-cat
4802: 2swap string-cat
4803: s" " string-cat
4804: 2swap string-cat
4805: 0d char-cat
4806: 0a char-cat
4807: ;
4808: : (nv-build-null-entry) ( name-ptr name-len dev-ptr dev-len -- str-ptr str-len )
4809: 4drop here 0
4810: ;
4811: : (nv-build-nvramrc) ( name-str name-len dev-str dev-len xt-build-entry -- )
4812: 4 pick 4 pick (nv-findalias)
4813: dup s" nvramrc" evaluate nip >= IF
4814: drop execute
4815: s" nvramrc" evaluate string-cat
4816: dup allot
4817: s" nvramrc" $setenv
4818: ELSE \ if our alias is still defined in nvramrc
4819: 5 pick 5 pick 5 pick 5 pick 5 pick execute nip over +
4820: s" nvramrc" evaluate 3 pick string-at
4821: 2dup find-nextline string-at nip +
4822: alloc-mem 0
4823: s" nvramrc" evaluate drop 3 pick string-cat
4824: rot >r >r >r execute r> r> 2swap string-cat
4825: ( mem, len ) ( R: alias-pos )
4826: s" nvramrc" evaluate r> string-at
4827: 2dup find-nextline string-at string-cat
4828: 2dup s" nvramrc" $setenv free-mem
4829: THEN
4830: ;
4831: : $nvalias ( name-str name-len dev-str dev-len -- )
4832: 4dup ['] (nv-build-real-entry) (nv-build-nvramrc)
4833: set-alias
4834: s" true" s" use-nvramrc?" $setenv
4835: (nvupdate)
4836: ;
4837: : nvalias ( "alias-name< >device-specifier<eol>" -- )
4838: parse-word parse-word dup 0<> IF
4839: $nvalias
4840: ELSE
4841: 2drop 2drop
4842: cr
4843: " Usage: nvalias (""alias-name< >device-specifier<eol>"" -- )" type
4844: cr
4845: THEN
4846: ;
4847: : $nvunalias ( name-str name-len -- )
4848: s" " ['] (nv-build-null-entry) (nv-build-nvramrc)
4849: (nvupdate)
4850: ;
4851: : nvunalias ( "alias-name< >" -- )
4852: parse-word $nvunalias
4853: ;
4854: : diagnostic-mode? ( -- diag-switch? ) diag-switch? ;
4855: check-for-nvramrc
4856: 890 cp
4857: defer set-boot-device
4858: defer add-boot-device
4859: : qemu-read-bootlist ( -- )
4860: 0 0 set-boot-device
4861: " boot-device" evaluate swap drop 0 <> IF EXIT THEN
4862: " qemu,boot-device" get-chosen not IF EXIT THEN
4863: 0 ?DO
4864: dup i + c@ CASE
4865: 0 OF ENDOF
4866: [char] a OF ENDOF
4867: [char] b OF ENDOF
4868: [char] c OF " disk" add-boot-device ENDOF
4869: [char] d OF " cdrom" add-boot-device ENDOF
4870: [char] n OF " net" add-boot-device ENDOF
4871: ENDCASE cr
4872: LOOP
4873: drop
4874: ;
4875: ' qemu-read-bootlist to read-bootlist
4876: 8a0 cp
4877: VOCABULARY client-voc \ We store all client-interface callable words here.
4878: 6789 CONSTANT sc-exit
4879: 4711 CONSTANT sc-yield
4880: VARIABLE client-callback \ Address of client's callback function
4881: : client-data ciregs >r3 @ ;
4882: : nargs client-data la1+ l@ ;
4883: : nrets client-data la1+ la1+ l@ ;
4884: : client-data-to-stack
4885: client-data 3 la+ nargs 0 ?DO dup l@ swap la1+ LOOP drop ;
4886: : stack-to-client-data
4887: client-data nargs nrets + 2 + la+ nrets 0 ?DO tuck l! /l - LOOP drop ;
4888: : call-client ( args len client-entry -- )
4889: >r ciregs >r7 ! ciregs >r6 ! client-entry-point @ ciregs >r5 !
4890: cistack ciregs >r1 !
4891: r> jump-client drop
4892: BEGIN
4893: client-data-to-stack
4894: client-data l@ zcount
4895: ALSO client-voc $find PREVIOUS
4896: dup 0= >r IF
4897: CATCH
4898: ?dup IF
4899: dup CASE
4900: sc-exit OF drop r> drop EXIT ENDOF
4901: sc-yield OF drop r> drop EXIT ENDOF
4902: ENDCASE
4903: THROW
4904: THEN
4905: stack-to-client-data
4906: ELSE
4907: cr type ." NOT FOUND"
4908: THEN
4909: r> ciregs >r3 ! ciregs >r4 @ jump-client
4910: UNTIL ;
4911: : flip-stack ( a1 ... an n -- an ... a1 ) ?dup IF 1 ?DO i roll LOOP THEN ;
4912: : (callback) ( "service-name<>" "arguments<cr>" -- )
4913: client-callback @ \ client-callback points to the function prolog
4914: dup 8 + @ ciregs >r2 ! \ Set up the TOC pointer (???)
4915: @ call-client ; \ Resolve the function's address from the prolog
4916: ' (callback) to callback
4917: : (continue-client)
4918: s" " \ make call-client happy, client won't use the string anyways.
4919: ciregs >r4 @ call-client ;
4920: ' (continue-client) to continue-client
4921: : string-to-buffer ( str len buf len -- len' )
4922: 2dup erase rot min dup >r move r> ;
4923: ALSO client-voc DEFINITIONS
4924: : exit sc-exit THROW ;
4925: : yield sc-yield THROW ;
4926: : test ( zstr -- missing? )
4927: zcount
4928: ALSO client-voc $find PREVIOUS IF nip FALSE ELSE nip nip TRUE THEN
4929: ;
4930: : finddevice ( zstr -- phandle )
4931: zcount find-node dup 0= IF drop -1 THEN ;
4932: : getprop ( phandle zstr buf len -- len' )
4933: >r >r zcount rot get-property
4934: 0= IF r> swap dup r> min swap >r move r>
4935: ELSE r> r> 2drop -1 THEN ;
4936: : getproplen ( phandle zstr -- len )
4937: zcount rot get-property 0= IF nip ELSE -1 THEN ;
4938: : setprop ( phandle zstr buf len -- size|-1 )
4939: dup >r \ save len
4940: encode-bytes ( phandle zstr prop-addr prop-len )
4941: 2swap zcount rot ( prop-addr prop-len name-addr name-len phandle )
4942: current-node @ >r \ save current node
4943: set-node \ change to specified node
4944: property \ set property
4945: r> set-node \ restore original node
4946: r> \ always return size, because we can not fail.
4947: ;
4948: : canon ( zstr buf len -- len' )
4949: over >r move r> zcount nip ;
4950: : nextprop ( phandle zstr buf -- flag ) \ -1 invalid, 0 end, 1 ok
4951: >r zcount rot next-property IF r> zplace 1 ELSE r> drop 0 THEN ;
4952: : open ( zstr -- ihandle ) zcount open-dev ;
4953: : close ( ihandle -- ) close-dev ;
4954: : write ( ihandle str len -- len' ) rot s" write" rot
4955: ['] $call-method CATCH IF 2drop 3drop -1 THEN ;
4956: : read ( ihandle str len -- len' ) rot s" read" rot
4957: ['] $call-method CATCH IF 2drop 3drop -1 THEN ;
4958: : seek ( ihandle hi lo -- status ) swap rot s" seek" rot
4959: ['] $call-method CATCH IF 2drop 3drop -1 THEN ;
4960: : claim ( addr len align -- base )
4961: dup IF rot drop
4962: ['] claim CATCH IF 2drop -1 THEN
4963: ELSE
4964: ['] claim CATCH IF 3drop -1 THEN
4965: THEN
4966: ;
4967: : release ( addr len -- ) release ;
4968: : instance-to-package ( ihandle -- phandle )
4969: ihandle>phandle ;
4970: : package-to-path ( phandle buf len -- len' )
4971: 2>r node>path 2r> string-to-buffer ;
4972: : instance-to-path ( ihandle buf len -- len' )
4973: 2>r instance>path 2r> string-to-buffer ;
4974: : instance-to-interposed-path ( ihandle buf len -- len' )
4975: 2>r instance>qpath 2r> string-to-buffer ;
4976: : call-method ( str ihandle arg ... arg -- result return ... return )
4977: nargs flip-stack zcount rot ['] $call-method CATCH
4978: nrets 0= IF drop ELSE \ if called with 0 return args do not return the catch result
4979: dup IF nrets 1 ?DO -444 LOOP THEN
4980: nrets flip-stack
4981: THEN ;
4982: : test-method ( phandle str -- missing? )
4983: zcount rot find-method dup IF nip THEN 0= ;
4984: : milliseconds milliseconds ;
4985: : start-cpu ( phandle addr r3 -- )
4986: >r >r
4987: s" reg" rot get-property 0= IF drop l@
4988: ELSE true ABORT" start-cpu called with invalid phandle" THEN
4989: r> r> of-start-cpu drop
4990: ;
4991: : quiesce ( -- )
4992: quiesce
4993: ;
4994: : interpret ( ... zstr -- result ... )
4995: zcount ['] evaluate CATCH ;
4996: : set-callback ( newfunc -- oldfunc )
4997: client-callback @ swap client-callback ! ;
4998: PREVIOUS DEFINITIONS
4999: STRUCT
5000: /l field ehdr>e_ident
5001: /c field ehdr>e_class
5002: /c field ehdr>e_data
5003: /c field ehdr>e_version
5004: /c field ehdr>e_pad
5005: /l field ehdr>e_ident_2
5006: /l field ehdr>e_ident_3
5007: /w field ehdr>e_type
5008: /w field ehdr>e_machine
5009: /l field ehdr>e_version
5010: /l field ehdr>e_entry
5011: /l field ehdr>e_phoff
5012: /l field ehdr>e_shoff
5013: /l field ehdr>e_flags
5014: /w field ehdr>e_ehsize
5015: /w field ehdr>e_phentsize
5016: /w field ehdr>e_phnum
5017: /w field ehdr>e_shentsize
5018: /w field ehdr>e_shnum
5019: /w field ehdr>e_shstrndx
5020: END-STRUCT
5021: STRUCT
5022: /l field phdr>p_type
5023: /l field phdr>p_offset
5024: /l field phdr>p_vaddr
5025: /l field phdr>p_paddr
5026: /l field phdr>p_filesz
5027: /l field phdr>p_memsz
5028: /l field phdr>p_flags
5029: /l field phdr>p_align
5030: END-STRUCT
5031: 0 value elf-segment-offset
5032: : xlate-vaddr32 ( programm-header-addr -- addr )
5033: phdr>p_vaddr l@ elf-segment-offset +
5034: ;
5035: STRUCT
5036: /l field ehdr64>e_ident
5037: /c field ehdr64>e_class
5038: /c field ehdr64>e_data
5039: /c field ehdr64>e_version
5040: /c field ehdr64>e_pad
5041: /l field ehdr64>e_ident_2
5042: /l field ehdr64>e_ident_3
5043: /w field ehdr64>e_type
5044: /w field ehdr64>e_machine
5045: /l field ehdr64>e_version
5046: cell field ehdr64>e_entry
5047: cell field ehdr64>e_phoff
5048: cell field ehdr64>e_shoff
5049: /l field ehdr64>e_flags
5050: /w field ehdr64>e_ehsize
5051: /w field ehdr64>e_phentsize
5052: /w field ehdr64>e_phnum
5053: /w field ehdr64>e_shentsize
5054: /w field ehdr64>e_shnum
5055: /w field ehdr64>e_shstrndx
5056: END-STRUCT
5057: STRUCT
5058: /l field phdr64>p_type
5059: /l field phdr64>p_flags
5060: cell field phdr64>p_offset
5061: cell field phdr64>p_vaddr
5062: cell field phdr64>p_paddr
5063: cell field phdr64>p_filesz
5064: cell field phdr64>p_memsz
5065: cell field phdr64>p_align
5066: END-STRUCT
5067: false value elf-claim?
5068: 0 value last-claim
5069: : claim-segment ( file-addr program-header-addr -- )
5070: elf-claim? IF
5071: >r
5072: here last-claim , to last-claim \ Setup ptr to last claim
5073: r@ phdr>p_vaddr l@ dup , r> phdr>p_memsz l@ dup , ( file-addr addr size )
5074: 0 ['] claim CATCH IF ABORT" Memory for ELF file already in use " THEN
5075: THEN
5076: 2drop
5077: ;
5078: : claim-segment64 ( file-addr program-header-addr -- )
5079: elf-claim? IF
5080: >r
5081: here last-claim , to last-claim \ Setup ptr to last claim
5082: r@ phdr64>p_vaddr @ dup , r> phdr64>p_memsz @ dup , ( file-addr addr size )
5083: 0 ['] claim CATCH IF ABORT" Memory for ELF file already in use " THEN
5084: THEN
5085: 2drop
5086: ;
5087: : load-segment ( file-addr program-header-addr -- )
5088: >r
5089: r@ phdr>p_offset l@ + r@ xlate-vaddr32 r@ phdr>p_filesz l@ move
5090: r@ xlate-vaddr32 r@ phdr>p_filesz l@ +
5091: r@ phdr>p_memsz l@ r@ phdr>p_filesz l@ - erase
5092: r@ xlate-vaddr32 r> phdr>p_memsz l@ dup 0= IF 2drop ELSE flushcache THEN
5093: ;
5094: : load-segments ( file-addr -- )
5095: dup dup ehdr>e_phoff l@ + \ Calculate program header address
5096: over ehdr>e_phnum w@ 0 ?DO \ loop e_phnum times
5097: dup phdr>p_type l@ 1 = IF \ PT_LOAD ?
5098: 2dup claim-segment \ claim segment
5099: 2dup load-segment THEN \ copy segment
5100: over ehdr>e_phentsize w@ + LOOP \ step to next header
5101: over ehdr>e_entry l@
5102: nip nip \ cleanup
5103: ;
5104: : load-segment64 ( file-addr program-header-addr -- )
5105: >r
5106: r@ phdr64>p_offset @ + r@ phdr64>p_vaddr @ r@ phdr64>p_filesz @ move
5107: r@ phdr64>p_vaddr @ r@ phdr64>p_filesz @ +
5108: r@ phdr64>p_memsz @ r@ phdr64>p_filesz @ - erase
5109: r@ phdr64>p_vaddr @ r> phdr64>p_memsz @ dup 0= IF 2drop ELSE flushcache THEN
5110: ;
5111: : load-segments64 ( file-addr -- entry )
5112: dup dup ehdr64>e_phoff @ + \ Calculate program header address
5113: over ehdr64>e_phnum w@ 0 ?DO \ loop e_phnum times
5114: dup phdr64>p_type l@ 1 = IF \ PT_LOAD ?
5115: 2dup claim-segment64 \ claim segment
5116: 2dup load-segment64 THEN \ copy segment
5117: over ehdr64>e_phentsize w@ + LOOP \ step to next header
5118: over ehdr64>e_entry @
5119: nip nip \ cleanup
5120: ;
5121: : elf-check-file ( file-addr -- image-type )
5122: dup ehdr>e_ident l@-be 7f454c46 <> IF
5123: ABORT" Not an ELF executable"
5124: THEN
5125: dup ehdr>e_data c@
5126: ?bigendian IF
5127: 2 <> ABORT" Not a Big Endian ELF file"
5128: ELSE
5129: 2 = ABORT" Not a Little Endian ELF file"
5130: THEN
5131: dup ehdr>e_type w@ 2 <> ABORT" Not an ELF executable"
5132: dup ehdr>e_machine w@
5133: CASE
5134: 14 OF ehdr>e_class c@ ENDOF \ PPC 32 bit executable
5135: 15 OF ehdr>e_class c@ ENDOF \ PPC 64 bit executable
5136: 17 OF ehdr>e_class c@ 4 or ENDOF \ SPU 32 bit executable
5137: dup OF drop ABORT" Not a PPC / SPU ELF executable" ENDOF
5138: ENDCASE
5139: ;
5140: : load-elf32 ( file-addr -- entry )
5141: ( file-addr)
5142: load-segments
5143: ;
5144: : load-elf32-claim ( file-addr -- claim-list entry )
5145: true to elf-claim?
5146: 0 to last-claim
5147: ['] load-elf32 CATCH IF false to elf-claim? ABORT THEN
5148: last-claim swap
5149: false to elf-claim?
5150: ;
5151: : load-elf64 ( file-addr -- entry )
5152: ( file-addr)
5153: load-segments64
5154: ;
5155: : load-elf64-claim ( file-addr -- claim-list entry )
5156: true to elf-claim?
5157: 0 to last-claim
5158: ['] load-elf64 CATCH IF false to elf-claim? ABORT THEN
5159: last-claim swap
5160: false to elf-claim?
5161: ;
5162: : load-elf-file ( file-addr -- entry 32-bit )
5163: dup elf-check-file
5164: CASE
5165: 1 OF 0 to elf-segment-offset load-elf32 true ENDOF
5166: 2 OF 0 to elf-segment-offset load-elf64 false ENDOF
5167: 5 OF load-elf32 true ENDOF
5168: dup OF true ABORT" load-elf-file: Not valid image" ENDOF
5169: ENDCASE
5170: ;
5171: : elf-spu-load ( ls-start-addr file-addr -- entry )
5172: swap to elf-segment-offset
5173: load-elf-file drop
5174: ;
5175: : elf-release ( claim-list -- )
5176: BEGIN
5177: dup cell+ ( claim-list claim-list-addr )
5178: dup @ swap cell+ @ ( claim-list claim-list-addr claim-list-sz )
5179: release ( claim-list )
5180: @ dup 0= ( Next-element )
5181: UNTIL
5182: drop
5183: ;
5184: CREATE bootdevice 2 cells allot bootdevice 2 cells erase
5185: CREATE bootargs 2 cells allot bootargs 2 cells erase
5186: CREATE load-list 2 cells allot load-list 2 cells erase
5187: : start-elf ( arg len entry -- )
5188: msr@ 7fffffffffffffff and 2000 or ciregs >srr1 ! call-client
5189: ;
5190: : start-elf64 ( arg len entry -- )
5191: msr@ 2000 or ciregs >srr1 !
5192: dup 8 + @ ciregs >r2 ! @ call-client \ entry point is pointer to .opd
5193: ;
5194: 10000000 VALUE LOAD-BASE
5195: 2000000 VALUE FLASH-LOAD-BASE
5196: : set-bootpath
5197: s" disk" find-alias
5198: dup IF ELSE drop s" boot-device" evaluate find-alias THEN
5199: dup IF strdup ELSE 0 THEN
5200: encode-string s" bootpath" set-chosen
5201: ;
5202: : set-netbootpath
5203: s" net" find-alias
5204: ?dup IF strdup encode-string s" bootpath" set-chosen THEN
5205: ;
5206: : set-bootargs
5207: skipws 0 parse dup 0= IF
5208: 2drop s" boot-file" evaluate
5209: THEN
5210: encode-string s" bootargs" set-chosen
5211: ;
5212: : .(client-exec) ( arg len -- rc )
5213: s" snk" romfs-lookup 0<> IF load-elf-file drop start-elf64 client-data
5214: ELSE 2drop false THEN
5215: ;
5216: ' .(client-exec) to (client-exec)
5217: : .client-exec ( arg len -- rc ) set-bootargs (client-exec) ;
5218: ' .client-exec to client-exec
5219: : netflash ( -- rc ) s" netflash 2000000 " (parse-line) $cat set-netbootpath
5220: client-exec
5221: ;
5222: : netsave ( "addr len {filename}[,params]" -- rc )
5223: (parse-line) dup 0> IF
5224: s" netsave " 2swap $cat set-netbootpath client-exec
5225: ELSE
5226: cr
5227: ." Usage: netsave addr len [bootp|dhcp,]filename[,siaddr][,ciaddr][,giaddr][,bootp-retries][,tftp-retries][,use_ci]"
5228: cr 2drop
5229: THEN
5230: ;
5231: : ping ( "{device-path:[device-args,]server-ip,[client-ip],[gateway-ip][,timeout]}" -- )
5232: my-self >r current-node @ >r \ Save my-self
5233: (parse-line) open-dev dup IF
5234: dup to my-self dup ihandle>phandle set-node
5235: s" ping" rot ['] $call-method CATCH IF
5236: cr
5237: ." Not a pingable device"
5238: cr 3drop
5239: THEN
5240: ELSE
5241: cr
5242: ." Usage: ping device-path:[device-args,]server-ip,[client-ip],[gateway-ip][,timeout]"
5243: cr drop
5244: THEN
5245: r> set-node r> to my-self \ Restore my-self
5246: ;
5247: 8b0 cp
5248: 8e0 cp
5249: 8ff cp
5250: : (boot) ( -- )
5251: s" Executing following boot-command: "
5252: boot-command $cat nvramlog-write-string-cr
5253: s" boot-command" evaluate \ get boot command
5254: ['] evaluate catch ?dup IF \ and execute it
5255: ." boot attempt returned: "
5256: abort"-str @ count type cr
5257: nip nip \ drop string from 1st evaluate
5258: throw
5259: THEN
5260: ;
5261: : (function-key) ( -- n )
5262: key? IF
5263: key CASE
5264: 50 OF 1 ENDOF
5265: 7e OF 1 ENDOF
5266: dup OF 0 ENDOF
5267: ENDCASE
5268: THEN
5269: ;
5270: : (esc-sequence) ( -- n )
5271: key? IF
5272: key CASE
5273: 4f OF (function-key) ENDOF
5274: 5b OF
5275: key key drop (function-key) ENDOF
5276: dup OF 0 ENDOF
5277: ENDCASE
5278: THEN
5279: ;
5280: : (s-pressed) ( -- )
5281: s" An 's' has been pressed. Entering Open Firmware Prompt"
5282: nvramlog-write-string-cr
5283: ;
5284: : (boot?) ( -- )
5285: of-prompt? not auto-boot? and IF
5286: (boot)
5287: THEN
5288: ;
5289: false VALUE (sms-loaded?)
5290: false value (sms-available?)
5291: s" sms.fs" romfs-lookup IF true to (sms-available?) drop THEN
5292: (sms-available?) [IF]
5293: s" /packages" find-device
5294: new-device
5295: s" sms" device-name
5296: : open true ;
5297: : close ;
5298: finish-device
5299: device-end \ leave /packages
5300: : sms-init-nvram ( -- )
5301: nvram-partition-type-sms get-nvram-partition IF
5302: cr ." Could not find SMS partition in NVRAM - "
5303: nvram-partition-type-sms s" SMS" d# 1024 new-nvram-partition
5304: ABORT" Failed to create SMS NVRAM partition"
5305: 2dup erase-nvram-partition drop
5306: 2dup s" lang" s" 1" internal-set-env drop
5307: 2dup s" tftp-retries" s" 5" internal-set-env drop
5308: 2dup s" tftp-blocksize" s" 512" internal-set-env drop
5309: 2dup s" bootp-retries" s" 255" internal-set-env drop
5310: 2dup s" client" s" 000.000.000.000" internal-set-env drop
5311: 2dup s" server" s" 000.000.000.000" internal-set-env drop
5312: 2dup s" gateway" s" 000.000.000.000" internal-set-env drop
5313: 2dup s" netmask" s" 255.255.255.000" internal-set-env drop
5314: 2dup s" net-protocol" s" 0" internal-set-env drop
5315: 2dup s" net-flags" s" 0" internal-set-env drop
5316: 2dup s" net-device" s" 0" internal-set-env drop
5317: 2dup s" net-client-name" s" " internal-set-env drop
5318: 2dup s" scsi-spinup" s" 6" internal-set-env drop
5319: 2dup s" scsi-id-0" s" 7" internal-set-env drop
5320: 2dup s" scsi-id-1" s" 7" internal-set-env drop
5321: 2dup s" scsi-id-2" s" 7" internal-set-env drop
5322: 2dup s" scsi-id-3" s" 7" internal-set-env drop
5323: ." created" cr
5324: THEN
5325: s" sms-nvram-partition" $2constant
5326: ;
5327: sms-init-nvram
5328: : sms-add-env ( "name" "value" -- ) sms-nvram-partition 2rot 2rot internal-add-env drop ;
5329: : sms-set-env ( "name" "value" -- ) sms-nvram-partition 2rot 2rot internal-set-env drop ;
5330: : sms-get-env ( "name" -- "value" TRUE | FALSE) sms-nvram-partition 2swap internal-get-env ;
5331: : sms-get-net-device ( -- n ) s" net-device" sms-get-env IF $dnumber IF 0 THEN ELSE 0 THEN ;
5332: : sms-set-net-device ( n -- ) (.d) s" net-device" 2swap sms-set-env ;
5333: : sms-get-net-flags ( -- n ) s" net-flags" sms-get-env IF $dnumber IF 0 THEN ELSE 0 THEN ;
5334: : sms-set-net-flags ( n -- ) (.d) s" net-flags" 2swap sms-set-env ;
5335: : sms-get-net-protocol ( -- n ) s" net-protocol" sms-get-env IF $dnumber IF 0 THEN ELSE 0 THEN ;
5336: : sms-set-net-protocol ( n -- ) (.d) s" net-protocol" 2swap sms-set-env ;
5337: : sms-get-lang ( -- n ) s" lang" sms-get-env IF $dnumber IF 1 THEN ELSE 1 THEN ;
5338: : sms-set-lang ( n -- ) (.d) s" lang" 2swap sms-set-env ;
5339: : sms-get-bootp-retries ( -- n ) s" bootp-retries" sms-get-env IF $dnumber IF 255 THEN ELSE 255 THEN ;
5340: : sms-set-bootp-retries ( n -- ) (.d) s" bootp-retries" 2swap sms-set-env ;
5341: : sms-get-tftp-retries ( -- n ) s" tftp-retries" sms-get-env IF $dnumber IF 5 THEN ELSE 5 THEN ;
5342: : sms-set-tftp-retries ( n -- ) (.d) s" tftp-retries" 2swap sms-set-env ;
5343: : sms-get-tftp-blocksize ( -- n ) s" tftp-blocksize" sms-get-env IF $dnumber IF 5 THEN ELSE 5 THEN ;
5344: : sms-set-tftp-blocksize ( n -- ) (.d) s" tftp-blocksize" 2swap sms-set-env ;
5345: : sms-get-client ( -- FALSE | n1 n2 n3 n4 TRUE ) s" client" sms-get-env IF (ipaddr) ELSE false THEN ;
5346: : sms-set-client ( n1 n2 n3 n4 -- ) (ipformat) s" client" 2swap sms-set-env ;
5347: : sms-get-server ( -- FALSE | n1 n2 n3 n4 TRUE ) s" server" sms-get-env IF (ipaddr) ELSE false THEN ;
5348: : sms-set-server ( n1 n2 n3 n4 -- ) (ipformat) s" server" 2swap sms-set-env ;
5349: : sms-get-gateway ( -- FALSE | n1 n2 n3 n4 TRUE ) s" gateway" sms-get-env IF (ipaddr) ELSE false THEN ;
5350: : sms-set-gateway ( n1 n2 n3 n4 -- ) (ipformat) s" gateway" 2swap sms-set-env ;
5351: : sms-get-subnet ( -- FALSE | n1 n2 n3 n4 TRUE ) s" netmask" sms-get-env IF (ipaddr) ELSE false THEN ;
5352: : sms-set-subnet ( n1 n2 n3 n4 -- ) (ipformat) s" netmask" 2swap sms-set-env ;
5353: : sms-get-client-name ( -- FALSE | addr len TRUE ) s" net-client-name" sms-get-env ;
5354: : sms-set-client-name ( addr len -- ) s" net-client-name" 2swap sms-set-env ;
5355: : sms-get-scsi-spinup ( -- n ) s" scsi-spinup" sms-get-env IF $dnumber IF 6 THEN ELSE 6 THEN ;
5356: : sms-set-scsi-spinup ( n -- ) (.d) s" scsi-spinup" 2swap sms-set-env ;
5357: : sms-get-scsi-id ( n -- id ) s" scsi-id-" rot (.) $cat sms-get-env IF $dnumber IF 6 THEN ELSE 6 THEN ;
5358: : sms-set-scsi-id ( id n -- ) swap (.d) rot s" scsi-id-" rot (.) $cat sms-set-env ;
5359: : sms-get-net-boot-file ( -- addr len )
5360: s" net" sms-get-net-device (.) $cat
5361: s" :dhcp," $cat
5362: sms-get-server IF (ipformat) $cat THEN
5363: s" ," $cat
5364: sms-get-client-name IF $cat THEN
5365: s" ," $cat
5366: sms-get-client IF (ipformat) $cat THEN
5367: s" ," $cat
5368: sms-get-gateway IF (ipformat) $cat THEN
5369: s" ," $cat
5370: sms-get-bootp-retries dup ff <> IF (.) $cat ELSE drop THEN
5371: s" ," $cat
5372: sms-get-tftp-retries (.) $cat
5373: dup IF
5374: strdup ( s" :" 2swap $cat strdup )
5375: THEN
5376: ;
5377: ' sms-get-net-boot-file to furnish-boot-file
5378: : $sms-node s" /packages/sms" ;
5379: : (sms-init-package) ( -- true|false )
5380: (sms-loaded?) ?dup IF EXIT THEN
5381: $sms-node ['] find-device catch IF 2drop false EXIT THEN
5382: s" sms.fs" [COMPILE] included
5383: device-end
5384: true dup to (sms-loaded?)
5385: ;
5386: : (sms-evaluate) ( addr len -- )
5387: (sms-init-package) not IF
5388: cr ." SMS is not available." cr 2drop exit
5389: THEN
5390: s" Entering SMS ..." type
5391: disable-watchdog
5392: reset-dual-emit
5393: 2>r $sms-node find-device
5394: 2r> evaluate
5395: device-end
5396: vpd-boot-import
5397: ;
5398: : sms-start ( -- ) s" sms-start" (sms-evaluate) ;
5399: : sms-fru-replacement ( -- ) s" sms-fru-replacement" (sms-evaluate) ;
5400: [ELSE]
5401: : sms-start ( -- ) cr ." SMS is not available." cr ;
5402: : sms-fru-replacement ( -- ) cr ." SMS FRU replacement is not available." cr ;
5403: [THEN]
5404: TRUE VALUE use-load-watchdog?
5405: : start-it ( -- )
5406: key? IF
5407: key CASE
5408: [char] s OF (s-pressed) ENDOF
5409: 1b OF
5410: (esc-sequence) CASE
5411: 1 OF console-clean-fifo sms-start (boot) ENDOF
5412: dup OF (boot?) ENDOF
5413: ENDCASE
5414: ENDOF
5415: dup OF (boot?) ENDOF
5416: ENDCASE
5417: ELSE
5418: (boot?)
5419: THEN
5420: disable-watchdog FALSE to use-load-watchdog?
5421: .banner
5422: ;
5423: ." " \ Clear last checkpoint
5424: 0 VALUE load-size
5425: 0 VALUE go-entry
5426: VARIABLE state-valid false state-valid !
5427: CREATE go-args 2 cells allot go-args 2 cells erase
5428: : $bootargs
5429: bootargs 2@ ?dup IF
5430: ELSE s" diagnostic-mode?" evaluate and IF s" diag-file" evaluate
5431: ELSE s" boot-file" evaluate THEN THEN
5432: ;
5433: : $bootdev ( -- device-name len )
5434: bootdevice 2@ dup IF s" " $cat THEN
5435: s" diagnostic-mode?" evaluate IF
5436: s" diag-device" evaluate
5437: ELSE
5438: s" boot-device" evaluate
5439: THEN
5440: $cat \ prepend bootdevice setting from vpd-bootlist
5441: strdup
5442: ?dup 0= IF
5443: disable-watchdog
5444: drop true ABORT" No boot device!"
5445: THEN
5446: ;
5447: : set-boot-args ( str len -- ) dup IF strdup ELSE nip dup THEN bootargs 2! ;
5448: : (set-boot-device) ( str len -- )
5449: ?dup IF 1+ strdup 1- ELSE drop 0 0 THEN bootdevice 2!
5450: ;
5451: ' (set-boot-device) to set-boot-device
5452: : (add-boot-device) ( str len -- ) \ Concatenate " str" to "bootdevice"
5453: bootdevice 2@ ?dup IF $cat-space ELSE drop THEN set-boot-device
5454: ;
5455: ' (add-boot-device) to add-boot-device
5456: 0 value claim-list
5457: : no-go ( -- ) -64 boot-exception-handler ABORT ;
5458: defer go ( -- )
5459: : go-32 ( -- )
5460: state-valid @ IF
5461: 0 ciregs >r3 ! 0 ciregs >r4 !
5462: go-args 2@ go-entry start-elf client-data
5463: claim-list elf-release 0 to claim-list
5464: THEN
5465: -6d boot-exception-handler ABORT
5466: ;
5467: : go-64 ( -- )
5468: state-valid @ IF
5469: 0 ciregs >r3 ! 0 ciregs >r4 !
5470: go-args 2@ go-entry start-elf64 client-data
5471: claim-list elf-release 0 to claim-list
5472: THEN
5473: -6d boot-exception-handler ABORT
5474: ;
5475: : load-elf-init ( arg len file-addr -- success )
5476: false state-valid ! \ Not valid anymore ...
5477: claim-list IF \ Release claimed mem
5478: claim-list elf-release 0 to claim-list \ from last load
5479: THEN
5480: dup ['] elf-check-file CATCH IF
5481: ( -64 THROW ) \ Not now, let the 'go' (i.e. no-go) whine about it
5482: drop 0
5483: THEN
5484: CASE
5485: 1 OF true swap ['] load-elf32-claim CATCH IF
5486: 2drop drop -66 THROW
5487: THEN
5488: ['] go-32 ENDOF ( arg len true claim-list entry go )
5489: 2 OF true swap ['] load-elf64-claim CATCH IF
5490: 2drop drop -66 THROW
5491: THEN
5492: ['] go-64 ENDOF ( arg len true claim-list entry go )
5493: dup OF drop ['] no-go to go
5494: 2drop false EXIT ENDOF ( false )
5495: ENDCASE
5496: to go to go-entry to claim-list
5497: dup state-valid ! -rot
5498: 2 pick IF
5499: go-args 2!
5500: ELSE
5501: 2drop
5502: THEN
5503: ;
5504: : init-program ( -- )
5505: $bootargs LOAD-BASE ['] load-elf-init CATCH ?dup IF
5506: boot-exception-handler
5507: 2drop 2drop false \ Could not claim
5508: ELSE IF
5509: 0 ciregs 2dup >r3 ! >r4 ! \ Valid (ELF ) Image
5510: THEN
5511: THEN
5512: ;
5513: : do-load ( devstr len -- img-size ) \ Device method wrapper
5514: use-load-watchdog? IF
5515: 4ec set-watchdog
5516: THEN
5517: my-self >r current-node @ >r \ Save my-self
5518: ." Trying to load: " $bootargs type ." from: " 2dup type ." ... "
5519: 2dup open-dev dup IF
5520: dup to my-self
5521: dup ihandle>phandle set-node
5522: -rot ( ihandle devstr len )
5523: my-args nip 0= IF
5524: 2dup 1- + c@ [char] : <> IF \ Add : to device path if missing
5525: 1+ strdup 2dup 1- + [char] : swap c!
5526: THEN
5527: THEN
5528: encode-string s" bootpath" set-chosen
5529: $bootargs encode-string s" bootargs" set-chosen
5530: LOAD-BASE s" load" 3 pick ['] $call-method CATCH IF
5531: -67 boot-exception-handler 3drop drop false
5532: ELSE
5533: dup 0> IF
5534: init-program
5535: ELSE
5536: false state-valid !
5537: drop 0 \ Could not load
5538: THEN
5539: THEN
5540: swap close-dev device-end dup to load-size
5541: ELSE -68 boot-exception-handler 3drop false THEN
5542: r> set-node r> to my-self \ Restore my-self
5543: ;
5544: : parse-load ( "{devlist}" -- success ) \ Parse-execute boot-device list
5545: cr BEGIN parse-word dup WHILE
5546: ( de-alias ) do-load dup 0< IF drop 0 THEN IF
5547: state-valid @ IF ." Successfully loaded" cr THEN
5548: true 0d parse strdup load-list 2! EXIT
5549: THEN
5550: REPEAT 2drop 0 0 load-list 2! false
5551: ;
5552: : load ( "{params}<eol>"} -- success ) \ Client interface to load
5553: parse-word 0d parse -leading 2swap ?dup IF
5554: de-alias
5555: set-boot-device
5556: ELSE
5557: drop
5558: THEN
5559: set-boot-args s" parse-load " $bootdev $cat strdup evaluate
5560: ;
5561: : load-next ( -- success ) \ Continue after go failed
5562: load-list 2@ ?dup IF s" parse-load " 2swap $cat strdup evaluate
5563: ELSE drop false THEN
5564: ;
5565: : noload false ;
5566: ' no-go to go
5567: : (go-and-catch) ( -- )
5568: ['] go behavior CATCH IF -69 boot-exception-handler THEN
5569: ;
5570: read-bootlist
5571: : boot
5572: load 0= IF -65 boot-exception-handler EXIT THEN
5573: disable-watchdog (go-and-catch)
5574: BEGIN load-next WHILE
5575: disable-watchdog (go-and-catch)
5576: REPEAT
5577: .banner
5578: ;
5579: : load load 0= IF -65 boot-exception-handler THEN ;
5580: : yaboot ." Use 'boot disk' instead " ;
5581: : netboot ( -- rc ) ." Use 'boot net' instead " ;
5582: : netboot-arg ( arg-string -- rc )
5583: s" boot net " 2swap $cat (parse-line) $cat
5584: evaluate
5585: ;
5586: : netload ( -- rc ) (parse-line)
5587: load-base >r FLASH-LOAD-BASE to load-base
5588: s" load net:" strdup 2swap $cat strdup evaluate
5589: r> to load-base
5590: load-size
5591: ;
5592: : neteval ( -- ) FLASH-LOAD-BASE netload evaluate ;
5593: cr .( Welcome to Open Firmware)
5594: cr
5595: cr .( Copyright (c) char ) emit .( 2004, 2011 IBM Corporation All rights reserved.)
5596: cr .( This program and the accompanying materials are made available)
5597: cr .( under the terms of the BSD License available at)
5598: cr .( http://www.opensource.org/licenses/bsd-license.php)
5599: cr cr
5600: ' start-it CATCH drop
5601: cr ." Ready!"
5602: GNU ���jƤ�
M��� ��&GCC: (Debian 4.4.5-10) 4.4.5 .shstrtab .slof.loader .text .opd .got .data .comment .branch_lt .bss & & & @ & & _� & b b � # & f� f� � ( & gh gh � . & 0 a� a� & & 7 & a� a� B p a� ��9 & a� G & �������� H 0bootinfo & & �������� &0p &0@ (snk ELF& & �0 @ &.@ @ 8 & @ & &-� 2ұ & |�����8c��|�#x�& �!��|c"xc H �1` 8! �| �;���| �||c 8�& ����|�N� &�& ` |������� 8` �& �!����肀��P{� ��x��H ��` 9 �J;� U) 0W� 0��PW�����| Hl| �| O�| �L &,9) �B ��H 1` 8! ��& ����|�N� &�& ` |���������|~x|�#x�& �!��8 9` �A���a��| ���������9@ �!�A�"� ` ` ` 8 &�i �I 9) @| �B �쀢�,�<8� p;����b�0|�0Px� H 5�` /� A�& �"�@�& p8� ;@ 낀��� �"���P� {� #�x��x��H �i` ��x��x8` H �U` I�xk�x}kJ9k U) 0Uk 0}iXPUk��}i�| Hl| �| O�| �L &,9) �B ��H �` ��x��xH �` ||xH �` $�x��x8` H ��` {�;{ WZ 0W{ 0z�PW{��i�| �l| �| | �L &,;Z �B ��H �` 8! ���x�& �!���A���a��|���������������N� &� ` ` |�xi �& �!��8 ��+� &@� (+� @� x8`��8!p�& |�N� ` ` /� @� �8 & 9& p| �|�#x} Cx9@
� 8� &� | P9) &�( ���/
5603: A� p@� B ��` |�HP}Cx�"�Hx`6d}i| ./� A��xxc6d8 }) */� A��d� �A (}c[x| ��i �I N�!�A (K��D` ` �I 9) &K���8� 9& pK��� &� ` ` ` |����������& �!����&���&�|dx��&���&��&&��!&��A&�;� p8�&���xH �` ��x|~x8` &��xK���8!&���x�& ��������|�N� &� ` ` ` |��& �!��H ]` 8! p�& |�N� &� |���������8` |�#x�& �!��|�+xH
5604: �` ,# A� T�# @/� A� H� �A (��x��x| ��i �I N�!�A (8! ��& ��������|�N� ` ` �b�PK���8`��K��� &� ` |�+�
��������|x�& �A���a�����������!�QA� d�"�XyJ�| R�} J})�N� H H & &H &x 8 H H h x H H H �|�+� @�`` 8`��8! ��& �A���a�����|������������N� ` /� A�|A��/� &@���8` �� pH 5` �� p|yA���? /� A� /� A��|�;x8� P8� H ��` ` 8! �8` �& �A���a�����|������������N� ` |�+� A��8�"�H{�6d|i�| �./� A�� �# /� @�&hK��` ` ` 8! �|c��& �A���a�����|������������K���` �b�H8 |��;� }i[x| �H ` ;� &9) @��B@&4� /� @���{�6dK�뢀`;� H H� �A (C�x��xe�x| ��i �I N�!�A (/� A� �;� &;� ��/�
5605: A��@�} /� A����+ 0/� A�� /� @����+ � �A (| ��i �I N�!�A (�= �) 0K��p` ` ` |�+� A����"�H{�6d|i| ./� A����# |��/� A�&`� �A (| ��i �I N�!�A (K���` ` ` ��xK���` ` �b�h��xK��y8`��K��d` ` ` 8! �|��|�+x|��|���& �A���a�����|������������K���` ` /� A���/� @��8` �� x�� pH u` � x�� p,# A� ��# 8/� A� t� �A (|�+x|��| ��i �I N�!�A (K����"�H{�6d|i�| �./� A����# 0/� A���� �A (| ��i �I N�!�A (8`��K��h�b��K��m8`��K��X8` �� p�� xH �` � p� x,# A� ��# H/� A� t� �A (|�#x|�+x| ��i �I N�!�A (K�� � �A (| ��i �� p�I N�!�A (� �� p8`��/� A���K��<�b�xK���8`��K����b�pK���8`��K��� &� ` |��!���A��; ;@ �a������|�+x�"��������|}x|~x�& �&�������!�Q� /� H � ��x/� ;� &A� ��@@��� �P��P{ �xH �u` 8�����xx� ��x�{ H �9` � ���?��` � &/� A���<�@@� ;Z &;{ Z�/
5606: ��x@���8! �8z &|c��& �&���!���A��|��a����������������N� &� |�����|���& �!�1;� p��xK�����xH �=` 8! ��& ����|�N� &�& ` |�����|���& �!�1;� p��xK��u��xH ��` 8! ��& ����|�N� &�& ` T`�>Tc@.|cxxc N� x` xc�T D.T �>} xTiD.Tc�>}#xT � |xxc N� ` x` xc "xi x UhD.U*D.xc�x �Uk�>U)�>} [x}IKxTD.TjD.T �>Tc�>} x}CxUk� U)� }`x}#xx �xc |xN� ` ` ` |mB�| B�|�B�| @���xc�|cxN� ` }mB�| B�|�B�| @���yk�}kx}k}-B�| B�|�B�| @���y)�})x�H@@� 8 �| �` B@��B ��K���N� ` }-B�| B�|�B�| @���y)�})x�b������k }cY�}k ykt�}iZ` ` }-B�| B�|�B�| @���y)�})x�H@@� 8 �| �` B@��B ��K���N� ` }-B�| B�|�B�| @���y)�})x�b������k }cY�yk��}k yk�}iZ` }-B�| B�|�B�| @���y)�})x�H@@� 8 �| �` B@��B ��K���N� ` ��������|��†����;� �& �!�q;� PH ` ` �� ;� �� A� L�? /� A��� /� A����) � �A (| ��i �I N�!�A (�� ;� �� @���8! ��& �����������|�N� &� 8
5607: �"��| �` �i 9) /� A� � � A� B ��9` }c[xN� ` ` ��������|��†����;� �����& |}x�!�q;� PH ;� �� A� 8�? /� A��� �� @���� /� @� 4�� ;� �� @���8! ��& ����������|�����N� �) � �A (| ��i �I N�!�A (�� K��� &� ` ` ` ��������}� &뢀�||x����|������& �} �� �!�a.# A�&\;� ;� H $` ` ` � | �;� .# A�&0��xH �Y` 8 &/� @���A�&{�.�{� $� P8
5608: ����| ���x��x� ` ` �i 9) /� @� dB ��9`
5609: ;� }i��
5610: 9? &/� A� d}?�9J B ��;���8! ���x�& �� ������|���������}�� N� ` � �� @���;���K���` ` ` ��x8� pH '�` ||�/� A� h8! �;�����x�& �� ������|���������}�� N� ` 8! �;�����x�& �� ������|���������}�� N� � p|ex��xH ��` ��x�J;� U) 0W� 0��PW�����| Hl| �| O�| �L &,9) �B ��� �b���A (| �8� x�} �] N�!�A ({� $/� |~&*A� � /� @���8c PH =` K���;���K��� � ` ` ` ��������|~x�
|��& �!��� /� A� 4;� ` � �� @� K��E/� @� <� ;� /� @���8! �8` �& ��������|�N� ` ` ` 8! ��"��xc $�& ����|i*����|�N� &� |������b���& �!���"���B��������� `�K X9` }i�� 9) 8 � 9) B ���
� /� A� ;� K��q� ;� /� @���8! ��& ����|�N� &�& ` |�3x|�;x|& x|��B� ` &�< X}��( |!B�A @�� 8�� ���� �B���* K��Y� 8|���A @�! N� |��& �!��|�3x|�;xK����! �& |�N� �"���! K����b���# ��&0}���A @�a H� P� X�� `�� h�& p�! x�A �� �� ��� ��� ��& ��! ��A ��a �� �� ��� ��� ��& ��! ��A& �a&�&�&��& ��&(8!&0�& H|��& P|��& 8|��& 0�a @8! XL $� �� `N� |����������& �����!�q����xH q` ���/� � A� �肁8� 8� H �` � /� @� �x� 8�& K���` |}yA� ���xH
�` /� |dxA� L�b� ��H �` /� � @� x�� 8` 8! ��& �����������|�N� ` ` �b� H �
` 8`��K���` ` ` �b�H ��` 8`��K����b�H ��` 8`��K����b�(H ��` 8`��K��� &� ` ` |��������|dx�& �!�a� /� A� @8� p8� H �` 8 /���A� �& r8! �|x�& ����|�N� ` �� �K��]� � �K��� &�& |������& �!��K��1/� @� ��b�0K��a��8� �b�@K��Q� �b�HK��E� �b�PK��9� �b�XK��-� �b�`K��!� �b�hK��� �b�pK�� � �b�xK���� �b��K��� $�b��K��� (�b��K��ِ ,8! ��& ����|�N� &�& |���������x�d�& ����/� |�3x�!�q�⁘8 }`Z�! ��& ��� ��A �� �� �� � P9! �@� 49D��| xyJ H9J }IR` 9) �P � ��� 9k @���/� @� �;���� P8 {� ;� &{�d9=��y)��9) &})�9 ` | I.9) B ���"����x� � H #�` /� A� ,� P9 ` ` ` | H.| I.9) �� @����? P�i 8! ��& �����������|�N� �"����x� � H #}` 8` K��� &� ` ` ` �"�8|�8� 8� &�& �!��8 8` � ,8� pK��i�b��K��` �a r8! ��& |�N� &� ` ` |���������|~x�& ����8 |�#x뢁8�!�a�} */� A� $|�+x8� 8� &8� p��x��K���� *� r�b��|x��x��xK��y` �a r8! ��& �����������|�N� &� ` |��"�8|kx8`���& �!�a8 ���& ��� &/� A� D�� � |�3x8� �+ �K 8� &8� �� �� �k �� p�a x�& �K��-�a �8! ��& |�N� &� ` ` |��"�8����|x8`���& �!�A8 ���& �� "/� A� D|x8& ��& p8& �8� �& x8� 8& �8� �8� ��& �9& �9! �9A �K����a ��& �� �& �� �& �� �& �� �& �� �& �� �& �8! �� �& ����|�N� &�& ` ` |��"�8�& �!���i /� A� 8� 8� &8� pK�� �a r8! ��& |�N� &� ` |��b�8|ix�& �!�q|�#x�k /� A� (9` 8� &�! ��& �8� &8� p�a x8� xK����a r8! ��& |�N� &� ` ` |��"�8|gx�& �!���i /� A� 8� &8� &8� pK��E�a r8! ��& |�N� &� |��b�8|ix�& �!�q|�#x�k /� A� (9` 8� &�! ��& �8� &8� p�a x8� xK����a r8! ��& |�N� &� ` ` |��"�8} Cx�& �!�q|`x�i /� A� /� @� HT�@.�i
5611: |�;xT�� |�+x|�#x8� �|��}i[x8� 8� &K��Y�a �8! ��& |�N� T�@.|�;xT�� |�+xx �a p|�#x8� �|v|��8� 8� &K���a �8! ��& |�N� &� ` ` ` |��"�8�& �!��|`x�i /� A� /� @� L�i /� A� ,T�@.|�;xT�� |�+x|�#x|��8� 8� 8� pK����a v8! ��& |�N� T�@.|�;xT�� |�+xx |�#x8� p|v|��8� 8� K��E�a v8! ��& |�N� &� �"��8 &8` � N� �"��8 8` � N� |�#xN� ` ` ` |�#xN� ` ` ` 8` N� ` ` ` |���������|~x8� �& �!�18� L;� p��xH ��` �����x�� |�& p8 &�& tH �` 8! ��& ��������|�N� &� ` ` ` |���������|~x8� �& �!�18� L;� p��xH �y` �����x�� |�& p8 &�& tH Q` 8! ��& ��������|�N� &� ` ` ` |�|iy8`���& �!��A� 8 � �) 8�i K��Y8` 8! p�& |�N� &� ` |���������||x|�+x�& ����8� L|�#x�����!�!8� ;� p��xH ��` �����x�� |�& p�� �8 �& t�� �H i` 8! ��& ��������������|�N� &� ` ` ` |���������||x|�+x�& ����8� L|�#x�����!�!8� ;� p��xH ��` �����x�� |�& p�� �8 �& t�� �H �` 8! ��& ��������������|�N� &� ` ` ` |���������|}x|�#x�& ����8� 8� L�!�!;� p��xH �a` �����x�� |�& p�� �8 �& tH 5` 8! ��& �����������|�N� &� ` ` ` |���������|}x|�#x�& ����8� 8� L�!�!;� p��xH ��` �����x�� |�& p�� �8 �& tH �` 8! ��& �����������|�N� &� ` ` ` �"�� /� M� �� �i K��X ` ` |���������|~x8� �& �!�18� L;� p��xH �` 8 &��x�"��� |�& t�& x�! pH �` �a �8! ��& ��������|�N� &� ` |���������|~x8� �& �!�18� L;� p��xH ��` 8 &��x�"���� |�& t�& x�! pH m` �a �8! ��& ��������|�N� &� ` |���������|x|�#x�& �!���� K��a�"��|`x/� 8`��{�d��� A� <� �B�9) 8` �b� ���_ 0� � yd})B�? 89 &�? 8! ��& ��������|�N� &� |���������|~x8� �& �!�18� L;� p��xH �y` 8 &��x�"��� |�& t�& x�! pH M` �a �8! ��& ��������|�N� &� ` |���������|~x8� �& �!�18� L;� p��xH ��` 8 &��x�"� �� |�& t�& x�! pH �` �a �8! ��& ��������|�N� &� ` |���������|~x8� �& �!�18� L;� p��xH �y` 8 &��x�"�(�� |�& t�& x�! pH M` �a �8! ��& ��������|�N� &� ` |���������|~x8� �& �!�18� L;� p��xH ��` 8 &��x�"�0�� |�& t�& x�! pH �` �a �8! ��& ��������|�N� &� ` |�����8� 8� L�& �!�1;� p��xH ��` ��8��x�& p8 &�& xH ]` �a ~8! ��& ����|�N� &�& ` ` |��A���a��|zx|�#x�& ����8� |�+x��������8� L;� �����!�;� &;� p��xH ��` ��@��x�� t�& p�� �8 �& |H �` ��x8� 8� LH ��` ��H��x�� t�& p�� x�A |�a ��� �H �` �a �8! ��& �A���a�����|������������N� &� ` ` |���������||x|�#x�& ����8� |�+x�����!�!8� L;� p��xH � ` ��P��x�� |�& p�� �8 �& t�� �8 &�& xH �` �a �8! ��& ����������|�����N� &� |���������||x|�#x�& ����8� |�+x�����!�!8� L;� p��xH �i` ��X��x�� |�& p�� �8 �& t�� �8 &�& xH 1` �a �8! ��& ����������|�����N� &� |���������||x|�#x�& ����8� |�+x�����!�!8� L;� p��xH ��` ��`��x�� |�& p�� �8 �& t�� �8 &�& xH �` �a �8! ��& ����������|�����N� &� |���������||x|�#x�& ����8� |�+x�����!�!8� L;� p��xH �)` ��h��x�� |�& p�� �8 �& t�� �8 &�& xH �` �a �8! ��& ����������|�����N� &� |���������||x|�#x�& ����8� |�+x�����!�!8� L;� p��xH ��` ��p��x�� |�& p�� �8 �& t�� �8 &�& xH Q` �a �8! ��& ����������|�����N� &� |�|iy8`���& �!��A� �) 8|���i K��=8! p�& |�N� &� ` ` ` |���������||x|�#x�& ����8� |�+x�����!�!8� L;� p��xH ��` ��x��x�� |�& p�� �8 �& t�� �8 &�& xH a` �a �8! ��& ����������|�����N� &� |�|iy8`���& �!��A� �) 8|���i K��=8! p�& |�N� &� ` ` ` |���������||x|�#x�& ����8� |�+x�����!�!8� L;� p��xH �` �����x�� |�& p�� �8 �& t�� �8 �& xH q` �& ��a �8! �| 4T �~x ������| ���������|c 8�& |�N� &� ` ` |��a������||x|�3x�& ����|�#x8� ��������|�+x8� L�!�;� p��xH ~�` �����x�� |�& p�� �8 �& t�� �8 &�& x�a �H �` �a �8! ��& �a��������|���������N� &� |������b���& �!��K���/���A� D;� p肂�8� ��xK��!��xK���|`x8!�|x�& ����|�N� ` ` �b��K��m/���|`xA���;� p肂�8� ��xK���K��� &�& ` ` |�����|x�& �!��K��M/���A� $8! �肂���x8� �& ����|�K��t8! ��& ����|�N� &�& }� &|�. &����|�#x�& �� �!��A� �肂�8� p8� �K��!/� @� x9! �H @` ` ` � ��}c���@A� �i��| x � @@� `/� 9) @� 49c��9I��@��Ȉ ��}c�/� A���/� 9) A���` ` 8`��8!&`�& �� ����|�}�� N� �j xcG�/� @���8!&`8` �& �� ����|�}�� N� 肂�K��$ �& ` ` ` |��!���&��8�&��& ������������|�#x��������|x��x�������������A���a���!�!�"��$�x;� |��xK���� ��x8� K��u/���|~xA����x{� K���:� t:� x;& p|}x��xK���|{yA�` ` �B��~ųx8� ��xD�xK��m肂�8� ~�x��xK��YD�x�x8� c�xK��E�& t�A p��x��x肂�8�&�Z�& xZK�� {Z /� A�&�/� A�&X�� t�! x{U(��x�� p|uP~� �9 ��{Zd|�"y�x�d|�*9 z� xc }B,� / ,$ �G y@G��� A� A� d|�+x8 A� ` �i 9) x ��@ | [x@���A�&HA�&x|�;x9 |��H �K y)�}IKxB ���� | �0@A� 4|c�|��xc }�|�/� @� x|��K��l` ` ` �0@A���/� A� �/� 8 A� <9L��x�dyJ }gZ9J &}I�` ` ` �K x �9k | SxB ��})0P| � ��x8�&�$�x��xK���}�xc�x$�x��x8�&�K�����xK��|{y@���8!��& ����������|������&���!���A���a����������������N� ` �' �g y)�})[xK���8 &x d}G}g .�
5612: yk�}`xK��D9 K���� ��x8� &K���|~xK��, &� |�����|x�& �!��K��m8! �|dx��x�& ����|�K��p &�& |���������||x�& ����8 �����!�a�& x�& pK��e|yA� @뢂�;� x�& x��x��x��x8� �& pK��9/� ��x@� <K��)|y@���8! �8` �& ����������|�����N� ` ` 8a p��xK����a p8! ��& ����������|�����N� &� ` |���������|~x�& ���������!��K��A8 ��/���|xA�&@K��}낂�;� p8� @��x��xK��e肂���xH t�` /� A�&<肂�8� �8� ��x;� �K��5肃 8� �8� ��xK��!肃8� �8� ��xK��
肃8� �8� ��xK���肃8� �8� ��xK���肂���x��x8�&�K���9^ x8 ��/� @� ��& �x �"x �"� ��> �` ` � 8c��|c�T >x G"9)��/� y)�y+&�y)d}iXP}jZ9+ � � � � ;� � A�����xK���8 �~ x8!`|x�& ����������|�����N� ` ` ` 肂�8� x8� ��xK��&��x��x8� |8� @K���8!`8 |x�& ����������|�����N� &� ` |��A���a��|�3x|�+x�& ������������|~x|�#x�b���������������&���!���!�AK������8 ��/���||x� �_ @� L8! �|x�& ���������&��|��!���A���a����������������N� ` ` ` �b� �� 8 :� &���B�; |x肃(8� � 8�[ 0�� �; �� � K���8 �� @�� H8� � x�[ p|x��x� P�; X肃0K���� 肃88� &K���8 ��/� A��,��xK���/���A� t�b�HK���/���A� K���/���A� 肃P��x8� K��9K���` ��`�B�p8� �"�X�b�h� p�> h�^ (�~ � �� K��!8 � K����> �b�@� �A (| ��i �I N�!�A (K��l &�
5613: ` ` ` |���������|}x|�#x�& ����8� L8� �!�!;� p��xH s�` ��x��x�� |�& p8 &�& t8 �& xH q` �& �� �a �8! ��& �����������|�N� &� ` ` ` |���������||x�& ����|�#x�����!�H q-` ;� x8� 8� L|}x��xH r�` �����x�� ��& x�� �8 �& |8 �& �H �` �& ��! ��a �8! �x �| Kx� �& ������|���������N� &� ` ` /� A� L/� A� 4/� &8 A� |xN� ` ` ` � |xN� ` � |xN� ` � |xN� ` ` /� |ixA� 8/� A� /� &8`��L� �� 8` N� ` �� 8` N� ` �� 8` N� ` ` |�|�;x�& �!��8 T :|�+x|�|�#x8� K��)` 8! p�& |�N� &� ` |�8� |�+x�& �!��T�:|�#x|��8� K��` 8! p�& |�N� &� ` ` |��A���a���& ����||x��������|�#x|�+x�����!�a;� W�:����x��x��x8� K��5` 9 ����x��x��x|zx8� ��xK��A` ��x��x��x��x8� K���` ��x��x��xH�x|{x8� ��xW{ :K���` 8! �|{ �|c��& �A���a�����|������������N� &� 肃�|�� �!��|���& N�!�& |�8! N� |��N� ` �"��9I � /� A� 0}`=J �P@8`��M� �i |xN� ` ` ` }@Sx�I =J }`8`���P@@���N� ` 8 D N� ` ` 8 D N� ` ` 8
D N� ` ` 8 D |c�N� ` 8 D |c�N� ` 8 D |c�N� ` |�#x|�+x|�3x|dx|x}%Kx8 8` &D |c�N� ` ` |�#x|�+x|�3x|�;x} Cx|dx|x}�cx}FSx}g[x8 8` D |c�N� ` ` |�#x|�+x|�3x|dx|x}%Kx8 8` D |c�N� ` ` |�#x|�+x|�3x|dx|x}%Kx8 8` D |c�N� ` ` �"������i xc��|c xc�|c�N� ` �"���i N� ` ` |v�N� ` ` ` |v�|c�N� ` ` �b��N� ` ` ` ��������|x|�3x|�8c �& �!���� |�+x8� H l�` ��x��x8� H l�` 8! ��& ��������|�N� &� ` |�|�#x8� �& �!��|dx8` K��E` 8! p�& |�N� &� |�|dy�& �!��A� 0�b��8� H lU` 8! p�& |�N� ` ` ` �b��8� 8� H k�` 8! p�& |�N� &� |���������8� 8���& �����!�a��;� ��xH k�` 8` ��x8��8� K���` 8 ,# @� ,8! �|x�& �����������|�N� ` ` x} +�
A� 8 ��K���` ` ` 肃���x8� H k�` /� A� <肃���x8� H k�` /� A� ��x��x8� H km` /� @� P� /� A� (/�@���8���8~ |��H �` |`xK��88���8~ |��H 1` |`xK�� |$ x8 33��x8� � pH j�` /� A���8 ��K��� &� ` ` �"���i N� ` ` �"���i N� ` ` �"���i N� ` ` �"���i N� ` ` 8 9 ���� �� �
5614: �� � � 8 � &�# 8 E� �� N� ` ` �"���i N� ` ` �"��|���������;� �& ����8 ;� �����!�q��x� � ;� � �� {�>${�M�|`P8� |P;� &xcd||8� 8c ��H h�` /�
5615: ���;��@����"�����8! �������� �& ��������|�N� &� �"���i K��8 ` ` �"���i K�� ` ` �"���i K��� ` ` |�=# �& �!��< �` ��� @A� T�"���b��x`�bTj�>8! p� �I 8 ^� �i 8 � &�k 8 &� �& |�N� ` ` �"���b��8 8� �8� � H g�` 8! p�& |�N� &� ` |���������} Cx|�;x�& ����8 |�3x�����!�q|x� �� 8 |�+x� 8 8� � 8 &� 8c H ge` �� ��x8 8� H gM` 8! ��� �& ����������|�����N� &� ` |�+� �����a��||x�& �������������!�QA� 88`��8! ��& �a��������|���������N� ` ` ` � /� &@��Ġ /� @���뢃�� �= � @����# /� &A� 4/� @���K��1` 8� 8� H f�` /� A� �8` K��l/� A��� � ;� 8� 8� *�& p;� x M�x >$})XP| HPx d�;�
5616: ��xH e�` K���` 8���x|ex��xK���` K���` �� �& p��x8� |ex8~ K�����x8� *K��&` 8` K��ā| /� A���<��́= �� ��x`���y >$y%M�| (P�8@| P9I &x d�A��|�? �X A� $|
5617: 0T ��T 8T <} J})PPy) K���;� 肃�8� �;� ��xH ei` |{y@��(8� ��x8� H d�` � /� @���;�
5618: ��x8� ��xH d�` ���xK��` �8` K��� &� ` ` }� &|���������|�#x�& ����8 |x+�������&��8`���!���A���a������ �!�!A�&�� /� A�(/� &A� ��9`
5619: 8 }i��
5620: ��x��x; 8 ` ` �i 9) | ZB ��x x �| �? x �| /� | ��
5621: A�܂� z� /���A�&Ё> } H�~� 8� A�&�� �� A�\� | �x| H8, @�X�> �~ �H@A� �y*M�y >$| PP= ��| Pa��x
5622: d}^R�J �� @� H �` �J �� A��9) &| @T ��T
5623: 8T <| R} HPy) y*M�y >$| PP�H@| Px
5624: d}^R@���;� �b���"��.< y`>$yxM� �P8� �P8� *{d�;[ ;�
5625: ��xH b�` K���` �� ~�x8� &G�x|ex8x K���K��]` 8�F�x|ex��xK��e` ��x8� *K���` A� 8`��8! ��& �� �����&��|��!���A��}�� �a����������������N� ` ` ��� � K��܀ | �x| H8, @��L� �B��;� x >$x M�})XP;Z | HPx d�K���` ;�
5626: F�x{� 8� |ex��xK���` ��x��x8| ;� H a�` ��x��K���` 8! ��& �� �����&��|��!���A��}�� �a����������������N� ` ` �> �~ � �H@A��,y*M�y >$| PP<���| P`���x
5627: d}^R�J �@ @� H `` ` ` �J �@ A� H9) &| 8T ��T
5628: 8T <| R} HPy) y*M�y >$| PP�H@| Px
5629: d}^R@���K���x d;> �.< A� �b��;\ 8� C�xd�xH `�` /� @����� �~ K��l` ` ` � �B��;� x >$x M�})XP| HPx d�K��X` ` ��� � � � K���` ` 8 ;A p� C�x8� 8� H _�` �; � � �� �& y�a |/� 8 �� ��! rA� ,8 ��9 T <}k8 �< ;� �X | J@���9a �` ` �: ;Z �X | J@���x x �| x �| | �� K��|�> � =@��aJ��8 &y&M�}`PUk��Ug8Uk<}k:y'>$| P|�0Px | 8Px d�X �~ �@� $9k &}+PU)��U*8U)<})R}iXP�~ �? 8� 8� }9&.8| {� H ^�` K��y` f�x8� |ex8|
5630: K��` ��x��x8| ;� H ^�` ���8` K���b���~ K��x � ` ` ` �"��|�/� ���������& �!�|`x�i @� 8! ��& ��������|�N� ;� p9@ E�A p9@ ;� �9 9` �_ &� 9@ p8 �_ � 9@��8a ��_ � 9@ &8� *�_ �?
5631: 8� T�? �& �8 �v� �> 8 &� �~ &H ]Y` ��x9A �8 ` �i 9) �P | Z@���x x �| ��xx �| 8� p| �� K���8! ��& ��������|�N� &� |���������|�#x�& �!���A���a�����������!�Q� |? x/� A�&�/� A� �/� A� 88` 8? ��& �!���A���a��|���������������N� ` �D mK��/��vA�&�8? �8`���& �!���A���a��|���������������N� 8 2�! |: xx �9` E| �;` }!&j� 9% ;� x� %�x;� p;� ��x�> �~ 9 ���~ �> 9` 9 &�~ &�> � �� �~ ��
5632: H [�` �~ �� 9` .��x}i�8 ` ` ` �i 9) | ZB ��x x �| 8� x �| ��x| �|��� K����& 8` � A�x8? ��& �!���A���a��|���������������N� ` ` � /� A� ,/� @��\8����� &8i x� H
` 8` K��@8����� &8i x� H =` 8` K�� �$ /� &@��T�"���c �I �X @��@/� A��8� 8` K��� &� ` ` ` |�+� ��������|x�& �!��@� @���> /� A� T�_ y@ � @A� t/���A� l�> /� A� `�H@A� X8`��8! ��& ��������|�N� ` ` �_ =`��ak��y@ �X@@���= ��a)���H@A���K���` 9`
5633: 8 �
5634: }i��
5635: ��x8� 8 �i 9) | ZB ��x x �| x �| | �T >�@ @��\� x �@� 4x ��A� ��� ��x8~;�H Y}` 8` K��0` ` ` ;�;�� �~ � A� 8` K���~ � � @���~ � � @��܀ �P @��Р� y) $8i 8���|~x� H Y&` � x ��@����? T 8��x��x| J� � /� A� X/� A� 4/� &@��x8! ��� 8� 8����& ����|������|�K��t�� 8 8���|��H �` K��8�� 8 8���|��H &�` K�� &� ` ` ` 8 �� �� � �� N� ` ` ` |�+� �& �!��@� � /��A� 8! p�& |�N� |�+xH &�` 8! p�& |�N� &� ` ` |�x� +� �& �!��A� 8`��8! p�& |�N� ` � /��A� Hl
5636: ��/��&A� L/� D@��̠ /� C@���9)��8c }$�H �` K���` ` ` H -�` |ctK���� /� 5@���9)��8c }$�H &�` |ctK��h &� ` ` ` 8`��N� ` ` ` N� �"��i 8` N� ` |��a������|{x;� ��������|�+x|�+x�����& |�#x�!�a` ` ` �? | �P��x��x})tU+28� &| J/� �x� ,� �/) A� \A� lA� �H V` �? })t8 &��| �P��x��x�? })tU+28� &| J/� �x� ,� �/) @���� ;� x ���K��d/� �> A� p8! ���x�& �a��������|���������N� ` ` ` 肃���xH S ` 8! �8` �& �a��������|���������N� ;� &K��� &� ` |���������|x�& �&���!���A���a�����������!�Q� /�4A� 88` 8! ��& �&���!���A��|��a����������������N� � T (mi��/�� @���x !@� h� ;� /� A� x낄 ;� H ` ` � ;� �� @� T��x��x��x;� &K�����,# @���8`��K��\` ` �"��8 &8` � K��@` ` ` � /� A��$�b��;� ;;;� ;[&8�xH ` ` ;� &� ���� @�����x��x��xK��1|~yA��x� /� &@���D�x��xH P�` /� @� 4� /� &/ A� dA� @�> 8
5637: �K���` ` ` ��x�xH Py` /� @���K���` 8�
5638: ��x%�xK���/� @���8`��K��D�
5639: 8` �K��4 &� ` |��!���A��;@ &�& �a��|{x�����������������!�QH P�` 뢃�8� ;� ;�{� ��x;� (;=8{� {� ��xH R]` 9=,8 4� ,8 & d�x#�x� �I H P` c�xH PI` 8� 8� x� `��&8c &8� 5xc }9Y.8}$�I K���` �� 8� (��xx� 8� 8� K��` ��x��K��e` 8! ��& �!���A���a��|���������������N� &� ` |��!���A��|�#x�& �a��8 ��������||x��������� �����&���!�A�B���b��;� D�x��x��xH O ` 肄��xH P)` /� A� 肄��xH P` ;� 뢄��x��xH O�` /� A� ��x��xH O�` ;� &뢄 ��x��xH O�` /� A�&���x��xH O�` 뢄(||P��xxx ��xH O�` /� A�&���x��xH O}` �P{� ��@@� �x{�!A� +� �@� T�b�0H Y�` 8! �8` �& �����&���!��|��A���a����������������N� ` ` ` ��x��x��x;&H NQ` 8 D�x| ��x�xH M�` ��xH M�` +� �A� �;� & �xH 8` ` ` H N&` � ��P}}�/� A� ���x;� &;� &� }>�P;� &|��Py) /� .x� ��x��x/ (� ?A� @��ș+ @���~�xD�xH M` �b�8H X�` 8! �8` �& �����&���!��|��A���a����������������N� ` ` ��xH L�` 뢄(xx ��x��xH M�` /� @��4` ��xH L�` x} K��4` ` ` � �; /� A�&� �;�D�x��x��x;� ~�xH L1` ��xH Le` /� A� ���xK��qK���` K���` ` ` ` K��Q` � /� @� @�
5640: /� @� �K���` /� A���;� &��/� @����b�H8� H Wy` 8! �8` �& �����&���!��|��A���a����������������N� ` ` �xK���K��L` �b�@H W ` 8! �8` �& �����&���!��|��A���a����������������N� ` ` ` 8! �� 8` &�& �����&���!��|��A���a����������������N� &� ` ` 8 ��/� x @� T8���9# x� 8 8� &|��H ` 9) �c }#Kx| ZB ��x x �| x �| | �x |xN� ` ` ` |�|ix�b�P�& �!���� �� �� &�� H U�` 8! p�& |�N� &� ` ` |���������|}x8� �& ����8�&V�!�q�& |? x�&��;� p��xH K�` �� ��x;� 8�&H8� 8� K���` ��x;� 8� C8� D8�&4K��` 8 &9 肄X� &�= 8~ �� H II` K��a` 8� |dx8~ 8H K�` �� ��xK���` 8? �8` �& �����������|�N� &� ` ` |������&��8� 8���& �!��|yx; �A���a�������������������!�A�& |? x�&�!;� p��x;\ "H J�` ;� ;| *K��9` :� F^�xK��I` 8` ��x8��8� K�ܡ` �]
5641: �
5642: ��x8 ` ` �i 9) �� | Z@���x x �| x �| | �T >�P @� ̈ /� @� �� /� D@� �� /� C@� �� /� @� �K���` ~�x8� H Ji` /� @� |�"�`�i /� A� d�x8��H I�` � �; 8y 8� l� �9 H Gq` 8? �8` �& �����&���!��|��A���a����������������N� K��1` /� A���8? �8`���& �����&���!��|��A���a����������������N� &� ` ` ` |��a������;e &�& ����8 |}x�b�h����{~ ����� |�#x�!�aH Re` �"�`낄p�� ����x��xH RE` /� ��xA� TK�����x;���K��u{� /� @����b��H R` 8! �8` �& �a��������|���������N� �b�x{d H Q�` 8! �8`���& �a��������|���������N� &� ` ` ` |��A���a���& ����|�3x��������;� &|�#x�����!�a{� |x�� |�;d��;A pe�P`�P{{ |� Pe�x|�"C�xH G�` � �| &D�xe�x|c|{P|H G�` � �� &8� { P|�H G}` }?讈 &| | 鮈 &�> | � 8!��& �A���a�����|������������N� &� |��!���A��|�3x�& �a��|�#x��������|�+x��������|x�&���!�A� /� ;! pA� X�c 9 /� �@� H &�}ISx�H@@� 8}H�/� �A�&�9I &/� yJ 9) A���}P�})Zy) �H@A���;� ; {� ��@@� (}]���/� @� `;� &��{� ��@A���8! �Cx|c t�& �&��xcт�!���A��|��a����������������N� ` ` ` /� �A� ̀� � x� !A� t� 9 � @A� �/� �@� 4H X` ` ` }i[x�H@@� @| H�� @/ �A� �A� ,9i &/� yk 9) A���| X�})y) �H@A��Ȉ� &x� ��x|:8� H Ee` �{ �< &8 | J� � &;� ���K���` 8! �8` &�& �&���!���A��|��a����������������N� ` ` ` �; K��l` ` �9 }%Kx��xd�x��xK���K��� &� ` ` |��a���A��|�#x8� �& ����|�+x8���������|~x��x�����&���!�������!�AH D)` 肄���x8� H D�` /� @��:�; ;� ;� &; {� ��@@� X| ��}>��&�| ��/� 4A��+� 4A� x/� A�P+� A� �/� @�& ;� &��{� ��@A���` ` 8! �cx|c t�& ����xcт�&���!��|��A���a����������������N� /� BA�&�+� BA� d/� 5A� �/� 6@� d� ;� � � &���K��(` /� A� �/� 2@� 4� ;� � � &���K���` /� CA� �/� �A� � &;� ���K���` ` ` /� &@��ܘ &;� � � � &���K���` ` �i 8 ��T >+� A�&@�};� � &���K��h` ;_ &8� |�"�x;� |�ЮH By` }>Ю}=J�)| Ю���K��(` �� ;� � � � &���K��8! �8` &�& �����&���!��|��A���a����������������N� ` ` ;_ &8� |�"~�x;� |�ЮH A�` }>Ю}=J�)| Ю���K���` �� ;� � � � &���K��d� ;� � � &���K��H` 8! �8` �& �����&���!��|��A���a����������������N� &� ` ` ` |���������|�#x8� 肄��& |}x�����!�qH @�` � +� @� $8! �8` �& �����������|�N� | t9 &} 6p &�A���9} 8 5� ;� �+ &� � � /� A� 8 4� �? &� � ;�
5643: � 2/� A� 8 2� 8 � &� � ;� � 6/� @� �9`& ��x}i���x8 ` ` �i& 9) &| Zx B ��/� A� @9 7� &�? ;� 9 �j& 8 &9J &/� A� �? ;� &x /�& @��܈ B/� @� �� C/� @� L8 ��8! �� 8` &�& �����������|�N� 8 6� 8 � &� � ;� K��08 C;�� ��xH =9` ��x8� &8 x� �� &H ?=` �? &8 �K��x8 B;�� ��xH <�` ��x8� &8 x� �� &H >�` �? &8 �� C/� A��,K��p &� ` ` |��a���A��|�#x8��& ����|}x8� ���������!�������!�;� t��xH >A` � /� A� @8`��8!��& �!���A���a��|���������������N� ` ` ` �ℐ� /� A� /��A� ���x{e H >` 肄�;] �8� C�x;���H >E` /� A� � �} ;} ,�= � c�x�? � H ;�` /� A� (�� /� @� d�x8 8� @H ;�` �� X;� l��xH ;i` /� A� ��x8&8� �H ;�` 8 � &�8 8` � 8!��& �!���A���a��|���������������N� ` ��x8��H =` K��` ` ` {{ C�x8����xx� K��=/� A��x�&�/� @�\�&�/� @� �= � ;} ,�? � c�xH :�` /� A� �� /� A� �;� l��xH :m` /� @� `� � 8 � � K���` �& u/� A� �& w/� @�T�& z/� @� 8` K��Ѐa|K��` 8` K�����x8&8� �H :E` 8 � &�K���d�x8 8� @H :%` �� XK��T��/� &A� 8/� @��h/� A�&�/� @���8 9 �?� 8` � K��@/� @��d� ;� 8� � �&t8�&H��x� ;��H ;9` 9?<8 ��<� �� &K�� ` 8� |dx8XH ;I` 8� 8���xH :�` 8 8���8� 8a��&�H ;` 8� 8����8a�H ;&` ��x8(��ϛ�Λ���������K���8�&48� D8� C84K��` 8�����xx� 8�&H8� 8� K�Х` ��x8�&HK���` 8 8` � K��9;�;a�y) D�x8� c�x�! px� H :]` �&�/� A�&/� A� �/� &@���8a�8� p8� l8� �K�� /� A����� pc�x��x8� x� K��Y/� @��,K����a�K��E` �a�K��` K����a �� �= � /� �&t�? � A� �8 8��H 7Q` �� �/� A� t8&8��H 75` 8 � K��;!�;A p#�xD�x8� l8� �K��I/� A���#�xD�x8� ,8� @K��-K��$8a�8� p8� ,8� @K��K�� 肄�;�&��xH 6�` �&�/� &A���/� A��|;� l��xH 6�` /� A��d��x��x8� �H 7` ��&�K��H肄�;� ��xH 6e` �&�0 ��T >+� &@���� /� @�����x8� ,8� @H 6�` �� XK��� &� ` |��a������8�&H8� �& ����;� &���������!�A�ℐ;� ;�<��xH 7�` 8 �� &��<8�� 肄�;a pH 5�` K���` 8� |dx8XH 7�` � 8�8� � c�xH 7�` � 9 d�x�� �8(�&p�!�K���848�&48� D8� CK��a` �� �� ��x8�&H8� K�ͅ` ��x8�&HK���` 8!��& �a��������|���������N� &� ` ` ` |���������8� 8�&H�& ����;� &�����!�Q��;� ��xH 6�` 9><8 ��<;� p� �� &K�ɝ` 8� |dx8~XH 6�` 8�8� ��xH 6u` ��x8~(��&���&������&q��&v��&sK��m8~48�&48� D8� CK��9` �� 8�����xx� 8�&H8� K��Y` ��x8�&HK�ѩ` 8!��& ����������|�����N� &� ` |��A���a��;@ �& ����8 ||x��������;� ���� �!�a�ℐ� ;a p| t/� |x/ A�&,A� �H 7U` /� ��xA� �뢄���xH 4i` ��x/� ��xA� �H 4Q` ��x|P|}4{� c�xH 3�` }!����I p8� c�x8�
5644: ;� &H 8�` |c4T`>+� �A� <� �4T @.|`�| � | t/� .@��@� &| tK��4` ` 8` 8!&��& �A���a�����|������������N� ` ��xc�xH 2Y` c�xH 2�` �K��P` ` ` k� |c 4Tc�~xc K��� &� |����������& �&��8 |�+x�!���A���a������|{x|�#x��������;� &�����������!�!�ℐ��;?&;_ ��x#�x�& pW�x��xH 1�` ��xC�xH 1�` � �b��;` &H =I` ��;�����x����xH =-` H >�` /� A� �/� A�&�K��m�:� K���` K�� ` K�ǁ` � /� / A� �A���K��` /� A���:� &~��/� @���;�����x����xH <�` H >]` /� @��|` ` ` �b��H <}` 8! �8`���& �����������|��&���!���A���a����������������N� ` �b��H <-` � /� A� � � /� A� � � /� @� �~�xH 0e` /� A�&;� p��xK��]/� A� ��& p�? � 8| $�x�< H /�` 8` 8! ��& �����������|��&���!���A���a����������������N� #�x8� H /�` K��h` ` ` C�x��xK��` /� @��l� 8`��/� A����& pK��X�b���xH ;` 8! �8`���& �����������|��&���!���A���a����������������N� � 8`��/� A���& pK��� &� ` ` ` �"�� c��8 &� �i N� ` ` ` |���������|�#x�& �a��뢄����������!���
5645: } P}+�q@� ���? /� A� \낄��Vp��x|��H :` 8 &�� 9 � 8 � 8!&�? �& �a��������|���������N� 낄�| Vp;a p|�c�x��xH 8�` �& p/� A� (i�x9` ` ` ` �i � &/� @���c�xH 9}` K��P��? y+�A��09) &/� y) @�� K��X &� |���������|�#x|~x�& ����8� 8�& �a�������!�a;� p��xH /Y` �"�Ѐ /� A� �;� 8` ;` ��x8� 8��K��)` 8 �� �"����x� d�x�) � �A (| ��i �I N�!�A (8!&��& �a��������|���������N� ` �) ��x8� 8� 8� ;� �;` �� K���` 8a �K��` &� ` |��a���A��8� 8�& �& ���������������������&���!���������������!�!�"�� �) �! p�& t;a vc�xH .!` ��Ѐ /� A�&���; :� ;@ ;� p;� � ;8 8c H ,` |tx��xH +�` |ux��xH +�` |vx��xH +�` |��8� E8� 8��|��|�~�xx� K�Ս` 8 &� � ; �xH +�` �x8� &#�xx� H -�` � 8c H +i` 8 &��xx 9H +Q` ��x8� &#�xx� H -Y` ��xH +-` 8 &��xx 9H +` ��x8� &#�xx� H - ` ��xH *�` |x��xH *�` 8 &��xx 8� &|yx� H ,�` �"��c�xD�x�) � �A (| ��i �I N�!�A (8!&��& ����������|������&���!���A���a����������������N� ` ` ` � ;� p;� :� �8c H *-` |xx��xH * ` ��|zx��xH * ` X�;& �;Z "|yx��xH )�` �? Z�8� 8� Zc�xZ��� {D K���` K��� &� ` ` ��������|����9` /� �����& �!�q8 |�#x�� $�� 8� � (�_ � � � 8�� 0� � @� /��A�&`}%�肅 8 ��xH 3�` �b�H 4�` 8� 8`��K��1�� @K���` K���` K��YH ,K��` �? 0� �i � @A� ��) � @A� �� /� @� �K��}` /� A����= 0�i +� @� @�B�ب� /���A� 0� Hx� +� &|x@� K����= 0�i ` ` ` 9k &�i K���` K���` K��i` �? 0� �i � @@��\8 ��8`�ؐ H ` ` ` 8 ��8`�א 8 � @8! ��& �����������|�N� 9 �K���` ` �} 8 � @/� @���� N8`��K����b�H 3=` � R/� @� ,� N8! ��& �����������|�N� ` ` �b�H 2�` � NK��� &� |����������& �A��|�#x�������|}x�a�������!�a� @/� A� �� N8` ;} K��)K���` K���` � 낄ؠ� |�4/� �� A�&</� A�T >/� A� x/� A� ��? 08` �i 8 &� 8!&��& �A���a�����|������������N� 8!&�8` �& �A���a�����|������������N� ` � T >+� @�&�8 ��8`��� ` 8 &� 8!&��& �A���a�����|������������N� �? H�{ 9I &yc }@�� A��m*��/���A���@A�LA���? 0Uk>8`� �i 8 � K���` ` ` {[ }�;�
5646: ��@@�&��H D` ��x8� H $i` ,# A� �8c &8� H $Q` ,# A� �;� &��@@� ���xH %A` ��x8� &��xx� H '�` /� @�����xH %` 8� 8�
5647: 8c &|}H )-` xc 8��� 8T >+��A���� 8` K��%8` K��$` ` �"� x �| �} J})�N� ���h &8 &(���h & &���h �` ` �� 8 � 8;� p8� ��x8�& H &E` � /� A�&�;� 8` ;` {� 8�
8��K��` 8 �"����x� 8 d�x� 8 � �) � �A (| ��i �I N�!�A (8 ��8`��� K���` ` ` 8 8` � 8K��8` K��` ` 8 ��8`��� K��t8 ��8`��� K��d8 ��8`��� K��T8 ��8`��� K��D8 ��8`��� K��4�_ H�? N� 0�� � $9I��}J*� 8 � @� 88 ��8`��� K���` �_ (/� A��@+� &A��8� HK���` � @8���8� x� |cJH %
` �{ �� K��-�? L� 8� 9)��9k � | � L@� ��? Hm ��/���@��(� (/� @�� 8 ��8`��� K��\K����? 0� P8` 8 &�i � P8 &� K����? ��x8� !8� 8� ;� �;` !�� K��a` 8a �K���8 &8` � K��|�� K��� &� ` ` ` }� &|���������|vx8� �& �&���!���A���a������|�#x8� �� ������������;� �a�����������!���{ H '1` 8� 8� ;A�;� t|xx�{ H '` 8� 8� |yx�{ H &�` 8 8� 8�
5648: |wx�{ �& pH &�` 8� 8�
5649: |}x�{ (H &�` |~x�b�(H ,�` �b�0H ,�` 8� 8�&C�xH "�` 8` 8� 8� ��xK��)` /���@� l` ` H .!` /� A� �;� &��/�XA� �K��1` K��I` K��a` /� A���8` 8� 8� ��xK���` /���A���/���A�
��� t�� u�� v�� w�& x�! y�b�@H +�` ��xK���` /� @���� 0~óxH I` .# |ux@�L8 �&&��b�h;�&�� /� A��@��8 X�&&�8 �&&̀&&�| P| �/�WA��8 X�&&�C�x��x8� H !�` � /� A���&&�/� &A� /� A�&t;� � /� A�(����b��x� x�Fxņ"x��"H *�` ;� +� &@�
5650: x�&&T;��/� @�����b����x �x� x��"x��"x�FH *�` �[ ��&���C�x$�x��x��8� |K��a` �&&�/� |~xA��/� A�D/���A��/���A� �/���A� D/���A��/���A�
5651: t/���A�
5652: �/���A�
5653: �/���A� @/���A� �8 +� @��/���A� �/���A� �/���A� @8!P��x�& �� �a�����|��������}�� �����&���!���A���a����������������N� �b�xH )�` ��&�~�xD�xK��` |x/� @��l/���A�Ȁ���b��x� x�Fxņ"x��"H )i` /���@��h���肅�;�&�;�����xx� x�Fx�"x��"H (u` 8�&�8`0K���` ��xH �` 8� �|dx��xK��%` K���` ` 8� 8� |8a&T;�&�H 1` �b�h8 C�x�&&�8 X��x�&&�8� 8 �&&�H A` � /� @��h;� p��x��x8� H m` /� A��H:�&���x~óx8� H M` /� A��(�&&T/� A�� ~ijx8a�8� H �` 8 �&&�K���Vp�b����x|��H (!` K���b�p;�&�H (
` ��x8� p8� H �` /� @�L8 ���&Ԁ�&�~�xD�xK��5` |xK��8��x8�&T8� �H y` 8 �&�K��А&&�K��HA��:� �8� ~��x8� d~óx;�&�H �` ~��x��xH !` /� @� $�& �/� @� ��x8� 8� H �` ~óx8� &;���H E` {� /� |vx@� 8 �&&T;�&�8� ��x8� H U` 8a&�8� 8� H A` A��d:� �~óx8� ~��x8� dH A` �& �/� @�&�8 X�&&�~óx8� &H �` /� &|vxA�� 8� ~��x8� dH �` �& �/� @�&`8 �&&�~óx8� &H y` K���;� �8� ��x8� d~óxH �` 肅P��xH �` /� @� �~óx8� &8 &�&&�:���H %` z� |vx.5 K��dK�� ` K��|:� p��x~�x8� H �` /� @�&h;�&�~�x��x8� H �` /� @�&�a�K���` K�����x8a�8� H %` K���肅X��xH �` /� A� �肅`��xH �` /� @���8 ~óx8� &�&&�:���H U` �b�hz� 8 .5 ;�&�|vx� K���~��x8� 8�
5654: H ` |c�/� �a&�@���K���~óx8� &8 K���8a&�8� 8� H )` K���~��x8� 8�
5655: H �` |c�/� �a&�@���K���:����x~�x8� H u` /� A���~�x��x8� H ` K�����xD�x8� H A` /� A�����xC�x8� H �` K��l��x8� 8� ~��xH y` :a&T~óx8� ~e�x8� dH }` �&&T/� A� (9 /H � &/� A� /� \@���3 K���~óx8� &H �` ;���{� !|vxA���8� ~��x8� d;�&�H ` ~��x��xH E` /� @� $�& �/� @�&�8� 8� ��xH �` ~óx8� &H m` 8��x /� |vxA��H8� ~��x8� d~óx:a&�H �` ~��x~d�xH �` /� @� <�& �/� A� ~c�x8� 8� H E` K��d~c�x8� 8� H -` ~óx8� &H �` |vxK��8肅�;�&���xH �` 8�&�8`0&K��a` ��x;���H &` 8� �|dx��xK���` K��p肅H;�&���xH �` 8�&�8`0K���肅�;�&�;� ��xH !�` +� @� ���xH �` 肆0|H !]` ��x;���H }` 肆8|H !=` 8�&�8`0K���` ��xH Q` 8� �|dx��xK���` K�����x8� 8� H ` K��l肅�8`0;���K��]` K���;�&�肅�;�����xH �` 8�&�8`0K��1` ��xH �` 8� �|dx��xK��q` K��D�"� {��| �} J})�N� � � @;�&�肅���x��xH I` 8�&�8`0 K���` ��xH ]` 8� �|dx��xK���` ;���K��Ȁ� ��� �;�&�;���肆P��xH �` 8�&�8`0K��a` ��xH ` 8� �|dx��xK���` K��t;�&�肅�;�����xH �` 8�&�8`0K��` ��xH �` 8� �|dx��xK��U` K��(�� �肆H;�&�;�����xH U` 8�&�8`0K���` ��xH i` 8� �|dx��xK��` K���;�&�肅�;�����xH �` 8�&�8`0K��y` ��xH ` 8� �|dx��xK���` K���;�&�肅�;�����xH �` 8�&�8`0K��-` ��xH �` 8� �|dx��xK��m` K��@;�&�肅�;�����xH a` 8�&�8`0K���` ��xH �` 8� �|dx��xK��!` K���;�&�肅�;�����xH ` 8�&�8`0K���` ��xH 9` 8� �|dx��xK���` K���;�&�肅�;�����xH �` 8�&�8`0K��I` ��xH �` 8� �|dx��xK���` K��\�� |肆@;�&�;�����xH �` 8�&�8`0K���` ��xH �` 8� �|dx��xK��9` K�� ;�&�肅8;�����xH -` 8�&�8`0 K���` ��xH Q` 8� �|dx��xK���` K���;�&�肅���x��x��xH �` 8�&�8`0K��]` ��xH &` 8� �|dx��xK���` ;���K��l��xH �` 肆|H �` K��<��xH �` 肆 |H y` K�� ��xH �` 肆(|H Y` K�����xH y` 肆|H 9` K�����xH Y` 肆|H ` K��� �
|���������|�#x�& ����|x�b�X�����!�Q;�&�H �` 8� ��x8�&H �` /� A�&�/� @�&��> � /� -@�&� &/� f@�&�� /� @�&��~ 8� 8� H 5` /���|xA�X�b�H;� pH ` 8` 8� 8� ��xK���` /���A�/���A�Ȉ� p�� q�� r�� s�& t�! u�b��H �` ��xK���` �b��H �` 8` ��x8� K���` |c4/� A�&��a&�K���` ��&��b��x�Fx� xņ"x��"H i` � � /� A� <9 /H ` ` � &/� A� /� \@���$ � &/� @���� �b��H ` � ;�&���xH 1` ��x��x<� �8� 8� x9 9 9@ K��` |}xK���` /� A�&@/���A��/���A��8 +� @�&�/� A� x�b�@��x;� H �` H `�> � /� -A� ��b�h;���H i` �b�pH ]` �b�xH Q` �b��H E` �b��H 9` �b��H -` 8!���x�& ����������|�����N� /���A�&</���@��t��&�肆�8a �;� &x� x�Fx�"x��"H ` K���` � &/� cA�& /� r@��@� /� @��48` K��` |}xK��l` ` ` �Vp�b����x|��H q` �b��H e` ��x��xK�%` 8!�|}x�& �����x�������|�����N� �b��;���H ` K����b��;� H ` +� @� p�b�0H �` ` ` ` �b�8;� &H �` K���` ` ` �b��;� &H �` K���� /� @��48` &K�~�` |}xK��l�"� {��| �} J})�N� 4 $ D T�b�H ]` K��t�b� H M` K��d�b�(H =` K��T�b�H -` K��D�b�H ` K��4�b����x;� &H ` K����b����x;� &H �` K����b��;���H �` K����b�`;���H �` K��� &� ` ` ` |���������|�#x|~x�����& 8� 8� �����!�;� x��xH
�` /� @� ��� ��xH �` 8
5656: �& �||yA� p/� &A� �;� �8� @��x8� ��xH �` ��x��xH �` /� A����x8� @8� ��xH a` ��x��xH �` /� @���b�PH �` 8`��8!&��& ����������|�����N� ;� �8� @��x8� ��xH �` ��x��xH -` /� A���;� �8� 8�&��xH �` �b��;� pH M` 8` 8� 8� ��xK���` /���A��/���A���� p�� q�� r�� s�& t�! u�b�hH &` ��xK��` �& |/� @�&4�b�pH �` ��x8` 8� K���` |c4/���A���a �K���` �� ��b��x� x��"x�Fx��"H �` ��x8� 8a �H
` �� ��b��x� x�Fxņ"x��"H ]` �a �K���` K��9` < ff` fg| �|c�p| p|c P�& �|c&�|c�K��-` ` K��A` /� @� �K���` K���` /� @����b��H �` 8!&�8` �& ����������|�����N� ` ` ��x8� |8� H 5` �b��H �` K���` ` ` �b��H }` 8!&�8`���& ����������|�����N� ��x8� &H &Y` ;���{� !|~xA���8� ��x8� @H �` ��x8� |H �` /� A��8��x8� &H &
` ;���{� !|~xA��|8� ��x8� @H I` ��x8� �H y` /� A�����x8� &H �` /� &|~xA��4��x8� 8� @H &` ��x8� 8�
5657: H
}` �a �K��` ` ` ��x8� &H i` ;���{� |~xK��D�b�`H =` 8`��K��p�b�XH )` 8`��K��\�b�xH ` 8`��K��H &� ` ` ,$ M� 9 ` � /� ,A� ,/� @� H <` ` A� 0� &/� ,/ @���9) &8c &y) �H@A���N� ` 8` N� ` ` ` |ix8` &` ` � /� ,A� ,/� @� H @` ` A� 0� &/� ,/ @���5) &A� 8c &xc K���` ` N� N� N� ` ` � |kx/� ,A� 8/� A� 0|ix` 9) &| HPx � /� ,/ M� @���N� 8` N� ` ` |���������|�+x�& �!��|�#yA� \9` ` ` ` �# /� ,A� ,/� @� H �` ` A� ��# &/� ,/) @���9k &8c &yk �X@A���/� A� �� /� ,A� �/� A� �|ixH ` A� 9) &�HP{� � /� ,/ @���|dx|�3x��xH �` /� A� (8 8! �| ���x�& ��������|�N� 8! �;� ��x�& ��������|�N� ;� K��� &� ` ` ` |��A���a��;@ ��������|�#x;� ��������|x�& �!���!�A�c ;a p/� A� �/� A� �H 1` /� A� ��"����x$�xH E` |~yA� �$�x��xH -` �P�4{� +� A� t��xc�x��x��H a` }!��I pc�x8� 8�
5658: H �` |c�+� �A� 4�| � /� .A� T;� &/� {� ;� &@��H/� 8`��A� 8` 8! ��& �!���A���a��|���������������N� � &K���` ` ��x8� c�xH �` c�x�� yH U` �K��H &� ` ` |���������|}x|�#x�b���& ���������!�qH �` �b��H �` /� @� 8낇�;� ` � ��x;� &��x��H ]` �� ;� A���8! �8`���& ����������|�����N� &� ` ` |���������|�#x�& ����|x�b�������!�qK�z�` 肇��} H &�` /� @� /� A� �肇��} H &i` /� A� L肇��} H &Q` /� @� ���x��xK���` 8! ��& ����������|�����N� ��x��xK��` 8! ��& ����������|�����N� ��x��xK�ߙ` 8! ��& ����������|�����N� �b��H �` /� @� 8낇�;� ` � ��x;� &��x��H �` �� ;� A���8`��K��4 &� ` � /� A� ,x� � @@� N� ` M� � &/� @@���8` N� ` ` �c /� A� \� }i[x/� A� @� @A� $H 4` ` � /� @A� @� �# &8� &/� @���� } HP}#�N� � 9 K��� ` |ix` ` ` � � 9) &� 8� &/� @���N� ` |ix9` 8` � /� M� ` ` � &9k &}k�/� @���yc N� ` ` � |ix/� A� 4/� M� |��H B@ p� 8���9) &x� � &/� @���/� M� 8���9i &x� 8 8� &|��H ` ` ` 9k &� }i[xB ��N� ` ` ` N� |���������|y|�#x�& ���������!�q@� ,8! ���x�& ����������|�����N� ` /� A� dK���` ||x��xK���` /� |}x@���������@@� 0` ��x��x��xH ` /� A���;� &��@A���8! �;� ��x�& ����������|�����N� &� ` ,% M� 8���x� x� |ix8� &|���� 9) &B ��N� ` ,% M� 8���|ixx� 8� &|��` � 8� &� 9) &B ��N� ` ` ` ,% A� L�# � 8���x� � @A� (H @` ` ` �# &� &ye � @@� /� 9e��@���8` N� ` ` |`HPN� ` ` ` |���������|x|�#x�& �����!�q�c /� @� 8H hH �` |}x�~ H �` �� @� D� &;� &/� A� 8� /� @���8! �8 |`P�& �����������|�N� � 8! �� |`P�& �����������|�N� &� ` ` ` 8��+� 8 A� 8c���"��|c�xcd| �|xN� ` ` 8��+� M� 8c��|c�N� ` ` ` ,$ |ixA�&@+� $�$ @� H &` 9) &�$ �i /� / ,�
5659: A���/�
A���A���A���/� @� �/� 0A� �8�
5660: /� A� �8` ` 8 ��9K��T>UJ>+� +
5661: 9) &9K��| 4@� $8 ��T >+� }@4@� M� 9k��}`4�( L� �$ |c)҉i /� |`@���N� ` /� @��|/� 08� @��p� &9I &/� x@��h9* &�$ �j &K��P` ` ` 8` N� � &9I &/� x@��(9* &�$ �j &K���8���K��� ` ,$ |ixA�&X+� $�$ 8` @� N� 9) &�$ �i /� / ,�
5662: A���/�
A���A���A���/� -8� A� �/� @� �/� 08�
5663: A�&/� 8` A� t8` H �$ |c)҉i /� |`A� T8 ��9K��T>UJ>+� +
5664: 9) &9K��| 4@� $8 ��T >+� }@4@� A� 9k��}`4�( A���/� M� |c �N� ` ` /� A� ,�$ �i K��\9) &/� �$ 8� &�i @���K��4�$ /� 08� @��0� &9i &/� x@� <9+ &�$ �k &K��8���+� $8` �$ @���N� � &9i &/� xA� 9` 0K���9+ &�$ �k &K��� ` |��!���A���a��������������;� �����& {� |x�&���!�Q;] � WZ &��Y���x� ` ` ` /� A���> |�8h �H@@�&��~ }i[x` ` ` � )@@T
5665: 6x�(/� |�3x@� ,�I &�� yJ��}F3xx�E�I |�3x}F3x��@@� @@� D� &�I x ��|;xyJE� }G;x|;x8� }):K���` ` ` �@@A�&��@@@�& 8� 9 H @` 9 �� &�K x �(�� xƃ�|�xyJE�}Jx|�Sx8
5666: }k�X@@� Ј /) T
5667: 6x�(/� @���A� ��� &�I � &�� � �� yC�(y���{�䈉 }�;xxx E�x�E�|�;x| x|�3x|�x|�:UJ 68 8� &xG"x�}J;xx��I �� &�� � � �� &�K �� x �(xƃ�|�xyJE�}Jx|�Sx8
5668: }k�X@A��8/� @��(c�xK���` � � @�& |c��| K���}i[xK���{�G"{�a) {���� �H �h &�( � 8! ��& �&���!���A��|��a����������������N� �0@@� P8i |�0P�� }c�{�G"`� {�{��x�G"x��x���� �� &�� }���� �K � &K���T >8i ` � K��l#�xK���` /���|hx�~ A� }#��| �< K�� 8` K��8 &� ` ` ` ���T >���N� ` |�/� �& �!���� ��� ��� ��& ��! ��A �@� 8! p8`���& |�N� /� A���8� �H %` 8! p�& |�N� &� |�|�+x�& �!��|�#x8���|xx� `H ` 8! p�& |�N� &� ` ` ` |��& �!��|`x�b��� ��� �|x�� ��� ��& ��! ��A �8� �H �` 8! p�& |�N� &� ` |�����|x�& �!�q� /� A�&� /� A� ��#
5669: /� A� /� O@� d� 8� PK��i` 8 |c�/� A� x/� O@� �8 � 9 &� � �? 8! �|x�& ����|�N� ` ` |H�9) &})�/� @���� 8� PK���` 8 |c�/� @����? 9` }i&�8 � 9 &� � K���` ` �? |`x9` }i&�K���` ` ` � 8� p8� &K���` 8 ��/� &@��D�& pK��< &�& ` ` ` �b�K��� ` ` ` K��� }� &|��a������|�+x;� &��������|}x�& �&���!���A�������� �!�Q�$ &/� A�&�;@ ;� ;� ;! pH 08 ��T >+� A� ;Z��}:J}:�` �< &/� A�&�8 ��T >+� )A����b�x �| �}`Z}i�N� ��������������������������������� &����������������������������������������� � ���������������� �������������������� ������������� ���������������� &�` ��xK��
x` /� A���/� A���/�
5670: A���/�
A���/� A����; ��x9i �{ �) � K���xc /� A���/� A���/�
5671: A���/�
A���/� A���� /� A����=
5672: /� @���9)���= �< &/� @���8!&�8` &�& �� �&���!��|��A���a��}�& ������}�� ��������N� ` ` ��xK�� /� xx A��. A� -� A� �/�
5673: A� �/�
A� �/� A� x�� @� p` ` ` �xH
5674: ` /� A��}!���x;� &��� pK���xx . A��-� A� $/�
5675: A� /�
A� /� A� �� A���}!��� pA� H/�
5676: A� @/�
A� 8/� A� 0� /� A� $�=
5677: /� @� 9)���= ` ` ` #�xK��-` /� A���; #�x8� 8� 8 � � K���` �x K�����xK���/� xi A��/� A� /� A�/�
5678: A� �/
A� �/) A� x� @� p` ` ` 8 ��T >+ A� T}a���x;� &���+ pK��mxi /� A��/� A��/�
5679: A� /
A� /) A� � A���` }a��� pA� 4/�
A� ,/� A� $� /� A� �=
5680: /� @� 9)���= #�xK��&` /� A�T�; #�x8� 8� 8 � � K��e` �x K���` ��xK���/� x` A�P/� | xA�T/� A�L/�
5681: A� t/�
A� l/� A� d�� @� \` ` }!���x;� &��� pK��Mx` /� | xA�&�/� A�&�/�
5682: A� /�
A� /� A� �� A���}!�/�
5683: �� pA� 4/�
A� ,/� A� $� /� A� �=
5684: /� @� 9)���= �; $�x8 � �i K��` K�����xK���/� xx A��. A�0-� A� �/�
5685: A� �/�
A� �/� A� x�� @� p` ` ` �xK��-` /� A�h}!���x;� &��� pK��9xx . A��-� A� $/�
5686: A� /�
A� /� A� �� A���}!��� pA� H/�
5687: A� @/�
A� 8/� A� 0� /� A� $�=
5688: /� @� 9)���= ` ` ` #�xK��` /� A�&�; #�x8� 8�
5689: 8 � � K��!` �x K���}!���x;� &��� pK��]x` /� @�` ` ` }!�$�x�� p�; 8 � �i K���` K��,` ` /� A� `` ` /� A� P/�
5690: A���/
A���/) A���8 ��T >+ A���}a���x;� &���+ pK���xi /� @���}!�#�x�� pK��` /� @���8!&�8` �& �� �&���!��|��A���a��}�& ������}�� ��������N� . A� d` ` -� A���/�
5691: A���/�
A���/� A����xH m` /� A�&}!���x;� &��� pK���xx . @���}!��� pK���` ` ` . A� d` ` -� A���/�
5692: A���/�
A���/� A����xK��m` /� A� �}!���x;� &��� pK��yxx . @���}!��� pK���` ` ` /� A�� ` ` /� A���/�
5693: A� $/�
A� ,/� @���9` K�� ` ` 9`
5694: K���` ` 9`
K���}!��� pA���K���}!��� pA��0K��� � ` ` ` }� &|��a���A��|{x��������;� �& ���������� �!�1��&� x !A�&`;� p;� ;A&H ` ` ` � &8� &x !A�&4/� %|�#x@���x ��x� ;� &9) &|�P|
5695: �� - s/� d} &U@- %/ i,� x, X. p-� c�& �} &U@- O�& �} &U@- o�& �A� �A�&A�&A�& A�&(A�&4�& �U >} U�>A�&0�& �U >} U�>A� �& �U >} U�>A�&@��H9` o9* &}AR})�}!J�j p�� p� /� %A���c�x��xE�xK���/� @� $� &;� &8� &��x !@���` ` 8! ���x�& �� �A���a��|�������}�& ��������}�& }�� N� ` 9` dK��`` ` 9` iK��P` ` 9` xK��@` ` 9` XK��0` ` 9` pK�� ` ` 9` cK��` ` 9` sK�� ` ` 9` OK��� � ` ` ` ,% |ix8` M� �I /� A� p� }KSx/� A� T8���x� !A� H� @@� @|��H $` ` � /� @A� B@ @� �i &8� &/� @��܈ }`XP}c�N� � 9` K��� xc 9#��8��(� + 8c��L�(BOY�B+� O��B} &U#?�U)��| &T ��|cKx|cx|c�N� ` ` |���������|�+x|~x�& ����|�#x8�&@�!�1;� p��xH �` ��x|}x�~ {� K�w�` 8!&���x�& �����������|�N� &� ` |��"� ����|�#x�& ����8��|�+x��������T >|x�!�a+�
�I �) 8 �! p�A xA� X� @@� |�"�(� /� A� ��c 8 -� 8 �c 9k &�c � ��8 &�= p�+ �? 9) &�? 8! �|x�& ����������|�����N� ` ` �+������x��PK��!���? 8! �8 &|x�} p�i �& �? ������|�9) &�����? ����N� ` ` �c K��T &� ` ` ` |��a������}Cx|�;x�& ����|�3x��������|~x|�+x�!�a|�#x8�
5696: 8� K��` /� 9 8 &|c�A� ` ��9) &/� })�@���y | �| �� @� @| P| �/� @� 0x �> | �` ` ` �� �> 9) &�> B ��8! �8` �& �a��������|���������N� &� ` ` |����p���x9� x9� 0�& �&��: &��������:� �����&��|�#x|xx�!���A��; �a�������!���A���a�������������������!��;a&P;A p:� ��{ 1�% /� A� 8|P�� @� ,/� %A� ��# 8� &�a&�8c &�a&��% /� @���8 � �a&�8!&P|xP�& ���p|c����x�&��|��!���A���a�����������������&���!���A���a����������������N� ` K�x|�+x8 %� ;� &|�P|
5697: �� /� dA��/� iA��/� uA��/� xA��/� XA��/� pA��/� cA��/� sA��/� %A� /� OA��/� o9k &@���9 o9j &}AR}k�}aZ�* p�+ p� /� %@� 9# &� �!&�8� &�a&�K���` �& q�� :& /� 0A�/� .:` ;� qA� �< /� A� P| �:� �& �;� 8 ��T >+� )@� D8 ��T >+� A� }z�;� &{� �+ �< &/� @���~&�xK��p` ` ` �b�0x �| �}`Z}i�N� X�������������������������������� ���������������������������������������� &� ������������� � ��������� X�������� X &h�������� ����� ��������� ��8� 8�
5698: ~��x�? K��m` x ��xK��-` �@@� D|c�Pxc !A� 8/� �!&�|i�A��A��` ` ` �� �!&�9) &�!&�B ��;� H (` �!&�| ��;� &{� � �!&�8 &�&&���xK�ޭ` ��@A���K��l` ` }:�~��x��x8� 8� 9 �) c�xK����!&�c�x��x8� �� �!&�8 &�&&��� &�!&�8 &�&&�K��]�< &K��}:�c�x~��x8� &8�
5699: 8� �) 9 K����!&��� �a&��< &8c &�a&�K���}:��b� z� $8� ~g�x}k9 �) ~��xc�x�K Ґ8~E�xK��-c�x~D�x8� K��͍< &K��x}:��b� z� $8� ~g�x}k9 �) ~��xc�x�K Ґ8~E�xK���c�x~D�x8� K��}�< &K��(�< &:� /� h@���< &:� &K�� ` V�88 ��}:�~ 6��x�) � 9A� 4�a&��"� z� $})8 -� �I �!&��a �8 &}r�8�&&�~E�x8�
5700: ~g�x9 ~��xc�xK��9c�x~D�x8�
5701: K��ٍ< &K���` ` ` �< &:� /� l@��hK��`` ` ` :` 0;� rK���` 9 dK���` ` 9 iK��|` ` 9 uK��l9 xK��d9 XK��\9 pK��T9 cK��L9 sK��D9 OK��<8 &| �K�� &� �x � ш � ѐ � Ѡ � Ѱ � �� � No net_xmit function available Can not open "%s" because file descriptor list is full
5702: No net_ioctl function available No net_init function available No net_receive function available net_e1000 net_bcm net_nx203x net_mcmal net_spider net_veth ` ` /rtas Could not open /rtas
5703: rtas-size Size of rtas (%x) too small to make sense
5704: Failed to allocated memory for RTAS
5705: instantiate-rtas instantiate-rtas failed
5706: read-pci-config ibm,read-pci-config write-pci-config ibm,write-pci-config ibm,update-flash-64-and-reboot ibm,update-flash-64 ibm,manage-flash-image system-reboot get-time-of-day set-time-of-day start-cpu stop-self TOK
5707: start-cpu called %d %x %x %x
5708: bootmsg-cp close bootmsg-debugcp bootmsg-warning bootmsg-error release set-callback open finddevice parent child peer yield set-led write-mm-log rtas-write-vpd rtas-read-vpd claim seek read write call-method getprop /chosen /aliases net bootpath local-mac-address reg assigned-addresses name #address-cells #size-cells ranges compatible IBM,vdevice vendor-id device-id revision-id class-code interrupts stdin stdout No net device found
5709: /cpus timebase-frequency interpret ibm,romfs-lookup ` ` ������ ������` :// // @ / :
5710: ERROR: Bad URL!
5711:
5712: ERROR: Bad host name!
5713:
5714: ERROR: Can't resolve domain name (DNS server is not presented)!
5715:
5716: Giving up after %d DNS requests
5717: %d.%d.%d.%d
5718: bla %02d
5719: Giving up after %d bootp requests
5720: . %03d
5721: Aborted
5722:
5723: Giving up after %d DHCP requests
5724: %d KBytes blksize octet %d Receiving data: Lost ACK packets: %d
5725: Bootloader 1.6
5726: E3000: (net) Could not read MAC address Reading MAC address from device: %02x:%02x:%02x:%02x:%02x:%02x
5727: E3006: (net) Could not initialize network device bootp dhcp ipv6 Requesting IP address via BOOTP: Requesting IP address via DHCP: E3001: (net) Could not get IP address E3002: (net) ARP request to TFTP server (%d.%d.%d.%d) failed E3008: (net) Can't obtain TFTP server IP address Requesting file "%s" via TFTP from %d.%d.%d.%d
5728: TFTP: Received %s (%d KBytes)
5729: (net) unknown TFTP error E3004: (net) TFTP buffer of %d bytes is too small for %s E3009: (net) file not found: %s E3010: (net) TFTP access violation E3011: (net) illegal TFTP operation E3012: (net) unknown TFTP transfer ID E3013: (net) no such TFTP user E3017: (net) TFTP blocksize negotiation failed E3018: (net) file exceeds maximum TFTP transfer size E3005: (net) ICMP ERROR " net unreachable host unreachable protocol unreachable port unreachable fragmentation needed and DF set source route failed E3014: (net) TFTP error occurred after %d bad packets received E3015: (net) TFTP error occurred after missing %d responses E3016: (net) TFTP error missing block %d, expected block was %d
5730: Flasher 1.4
5731: Bad buffer address. Exiting...
5732: Usage: netflash [options] [<filename>]
5733: Options:
5734: -f <filename> flash temporary image
5735: -c commit temporary image
5736: -r reject temporary image
5737: Bad arguments. Exiting...
5738:
5739:
5740: E3000: Could not read MAC address
5741:
5742: E3006: Could not initialize network device
5743: %02x:%02x:%02x:%02x:%02x:%02x
5744:
5745: DHCP: Could not get ip address
5746:
5747: ARP request to TFTP server (%d.%d.%d.%d) failed Requesting file "%s" via TFTP
5748: Now flashing:
5749: Tftp: Could not load file %s
5750: Tftp: Buffer to small for %s
5751:
5752: ICMP ERROR: Destination unreachable: UNKNOWN: rc = %d! Reading MAC address from device:
5753: ping device-path:[device-args,]server-ip,[client-ip],[gateway-ip][,timeout]
5754: Own IP address: Ping to %d.%d.%d.%d success
5755: failed
5756:
5757: Reading MAC address from device: No such callback function
5758: argv[%d] %s
5759: netboot netflash ping Unknown client application called
5760: & & & & & & & & & &0123456789ABCDEF � �� ��� ���� ����� ������ ��������������� & &�� &` &�� &�� � &�� &�� � &�� � &�� ` &�� ` &�� � &�� � &��
&��
@ &��
� &�� &�� 0 &�� � &�� 0 &�� � &�� p &�� � &�� � &�� &�� � &�� X &�� � &�� � &�� &�� � &�� P &�� � &�� &�� � &�� P &�� &�� p &�� � &�� 0 &�� � &�� p &�� 0 &�� P &�� p &�� � &�� � &�� � &�� !P &�� !� &�� " &�� "� &�� #` &�� #� &�� $� &�� $� &�� %0 &�� %� &�� &P &�� &� &�� 'P &�� '� &�� (P &�� (� &�� )� &�� *P &�� *� &�� +� &�� ,0 &�� ,� &�� - &�� -� &�� . &�� .� &�� /� &�� 0 &�� 0� &�� 1� &�� 5 &�� 5@ &�� 6 &�� 8 &�� : &�� :� &�� ;� &�� ;� &�� <P &�� <� &�� <� &�� > &�� >� &�� >� &�� >� &�� >� &�� ? &�� ?0 &�� ?P &�� ?� &�� ?� &�� @ &�� @` &�� @� &�� @� &�� @� &�� @� &�� A &�� A� &�� A� &�� B0 &�� C� &�� C� &�� C� &�� D &�� D0 &�� D� &�� D� &�� E` &�� E� &�� E� &�� E� &�� Fp &�� G &�� I� &�� O� &�� Q &�� S� &�� U� &�� V &�� V� &�� WP &�� Wp &�� W� &�� W� &�� Y &�� [0 &�� \p &�� a &�� a� &�� a� &�� b� &�� e &�� f &�� g &�� i� &�� m &�� op &�� u� &�� w &�� x &�� y� &�� } &�� }0 &�� ~` &�� p &�� �p &�� �� &�� � &�� �� &�� � &�� �� &�� �0 &�� �� &�� � &�� �P &�� �� &�� �� &�� � &�� �P &�� �� &�� � &�� �` &�� � &�� �� &�� �0 &�� �� &�� � &�� �� &�� � &�� �@ &�� �� &�� �P &�� �� &�� �� &�� �P &�� �� &�� � &�� �` &�� �� &�� �� &�� �@ &�� Ű &�� �P &�� ư &�� �0 &�� Ȁ &�� ɀ &�� ` ` ` ` ` ` ` ` ` ` ` ` ` ` ` ` ` ` ` ` ` ` ` ` ` ` ` ` ` ` ` ` ` ` ` ` ` ` ` ` ` ` ` ` ` ` ` ` ` ` ` ` ` ` ` ` & �P �p � � �� � �h �8 �x � �H �0 � �� � & & & & � �� � �� �� � & ^ ������ c�Sc &������ ` & 2� P & & 2�` P �!���& 0|��& 8|��& H|��& P�a @8 �``H -A�& H|��& P|��& 8|��& 0�a @8! XL $` ` &`N� �!���& 0|��& 8|��& H|��& P�a @8 �``H ,A�& H|��& P|��& 8|��& 0�a @8! XL $` ` &`N� �!���& 0|��& 8|��& H|��& P�a @8 ��`�H +��& H|��& P|��& 8|��& 0�a @8! XL $` ` &`N� �!���& 0|��& 8|��& H|��& P�a @8 �``H +A�& H|��& P|��& 8|��& 0�a @8! XL $` ` &`N� �!���& 0|��& 8|��& H|��& P�a @8 ��`�H *��& H|��& P|��& 8|��& 0�a @8! XL $` ` &`N� �!���& 0|��& 8|��& H|��& P�a @8 �``H *A�& H|��& P|��& 8|��& 0�a @8! XL $` ` &`N� �!���& 0|��& 8|��& H|��& P�a @8 �``H )A�& H|��& P|��& 8|��& 0�a @8! XL $` ` &`N� �!���& 0|��& 8|��& H|��& P�a @8 �``H (A�& H|��& P|��& 8|��& 0�a @8! XL $` ` &`N� �!���& 0|��& 8|��& H|��& P�a @8 �``H 'A�& H|��& P|��& 8|��& 0�a @8! XL $` ` &`N� �!���& 0|��& 8|��& H|��& P�a @8 �` `H &A�& H|��& P|��& 8|��& 0�a @8! XL $` ` &`N� �!���& 0|��& 8|��& H|��& P�a @8
5761: �`
5762: `H %A�& H|��& P|��& 8|��& 0�a @8! XL $` ` &`N� �!���& 0|��& 8|��& H|��& P�a @8 �` `H $A�& H|��& P|��& 8|��& 0�a @8! XL $` ` &`N� �!��}h��a 0}z��a @}{��a H�b���k }i�|
5763: xN�!�a 0}h��a @}z��a H}{�8! PL $ �!���& 0|��& 8|��& H|��& P�a @8
�`
`H "A�& H|��& P|��& 8|��& 0�a @8! XL $` ` &`N� �!���& 0|��& 8|��& H|��& P�a @8 �``H !A�& H|��& P|��& 8|��& 0�a @8! XL $` ` &`N� �!���& 0|��& 8|��& H|��& P�a @8 �``H A�& H|��& P|��& 8|��& 0�a @8! XL $` ` &`N� �!���& 0|��& 8|��& H|��& P�a @8 �``H A�& H|��& P|��& 8|��& 0�a @8! XL $` ` &`N� �!���& 0|��& 8|��& H|��& P�a @8 �``H A�& H|��& P|��& 8|��& 0�a @8! XL $` ` &`N� �!���& 0|��& 8|��& H|��& P�a @8 �``H A�& H|��& P|��& 8|��& 0�a @8! XL $` ` &`N� �!���& 0|��& 8|��& H|��& P�a @8 �``H A�& H|��& P|��& 8|��& 0�a @8! XL $` ` &`N� �!���& 0|��& 8|��& H|��& P�a @8 �``H A�& H|��& P|��& 8|��& 0�a @8! XL $` ` &`N� �!���& 0|��& 8|��& H|��& P�a @8 �``H A�& H|��& P|��& 8|��& 0�a @8! XL $` ` &`N� �!���& 0|��& 8|��& H|��& P�a @8 �``H A�& H|��& P|��& 8|��& 0�a @8! XL $` ` &`N� �!���& 0|��& 8|��& H|��& P�a @8 �``H A�& H|��& P|��& 8|��& 0�a @8! XL $` ` &`N� �!���& 0|��& 8|��& H|��& P�a @8 �``H A�& H|��& P|��& 8|��& 0�a @8! XL $` ` &`N� �!���& 0|��& 8|��& H|��& P�a @8 �``H A�& H|��& P|��& 8|��& 0�a @8! XL $` ` &`N� �!���& 0|��& 8|��& H|��& P�a @8 �``H A�& H|��& P|��& 8|��& 0�a @8! XL $` ` &`N� �!���& 0|��& 8|��& H|��& P�a @8 �``H A�& H|��& P|��& 8|��& 0�a @8! XL $` ` &`N� �!���& 0|��& 8|��& H|��& P�a @8 �` `H A�& H|��& P|��& 8|��& 0�a @8! XL $` ` &`N� �!���& 0|��& 8|��& H|��& P�a @8 �` `H A�& H|��& P|��& 8|��& 0�a @8! XL $` ` &`N� �!���& 0|��& 8|��& H|��& P�a @8 �` `H A�& H|��& P|��& 8|��& 0�a @8! XL $` ` &`N� �!���& 0|��& 8|��& H|��& P�a @8 �` `H A�& H|��& P|��& 8|��& 0�a @8! XL $` ` &`N� �!���& 0|��& 8|��& H|��& P�a @8 �` `H A�& H|��& P|��& 8|��& 0�a @8! XL $` ` &`N� �!���& 0|��& 8|��& H|��& P�a @8 ! �`!`H A�& H|��& P|��& 8|��& 0�a @8! XL $` ` &`N� �!���& 0|��& 8|��& H|��& P�a @8 " �`"`H
A�& H|��& P|��& 8|��& 0�a @8! XL $` ` &`N� �!���& 0|��& 8|��& H|��& P�a @8 # �`#`H A�& H|��& P|��& 8|��& 0�a @8! XL $` ` &`N� �!���& 0|��& 8|��& H|��& P�a @8 $ �`$`H A�& H|��& P|��& 8|��& 0�a @8! XL $` ` &`N� �!���& 0|��& 8|��& H|��& P�a @8 % �`%`H
5764: A�& H|��& P|��& 8|��& 0�a @8! XL $` ` &`N� �!���& 0|��& 8|��& H|��& P�a @8 & �`&`H A�& H|��& P|��& 8|��& 0�a @8! XL $` ` &`N� �!���& 0|��& 8|��& H|��& P�a @8 ' �`'`H A�& H|��& P|��& 8|��& 0�a @8! XL $` ` &`N� �!���& 0|��& 8|��& H|��& P�a @8 ( �`(`H A�& H|��& P|��& 8|��& 0�a @8! XL $` ` &`N� �!���& 0|��& 8|��& H|��& P�a @8 ) �`)`H A�& H|��& P|��& 8|��& 0�a @8! XL $` ` &`N� �!���& 0|��& 8|��& H|��& P�a @8 * �`*`H A�& H|��& P|��& 8|��& 0�a @8! XL $` ` &`N� �!���& 0|��& 8|��& H|��& P�a @8 + �`+`H A�& H|��& P|��& 8|��& 0�a @8! XL $` ` &`N� �!���& 0|��& 8|��& H|��& P�a @8 , �`,`H A�& H|��& P|��& 8|��& 0�a @8! XL $` ` &`N� �!���& 0|��& 8|��& H|��& P�a @8 - �`-`H A�& H|��& P|��& 8|��& 0�a @8! XL $` ` &`N� �!���& 0|��& 8|��& H|��& P�a @8 . �`.`H &A�& H|��& P|��& 8|��& 0�a @8! XL $` ` &`N� �!���& 0|��& 8|��& H|��& P�a @8 / �`/`H A�& H|��& P|��& 8|��& 0�a @8! XL $` ` &`N� �!���A @�a H�� P�� X�� `�� h�& p�! x�A ��a ��� ��� ��� ��� ��& ��! ��A ��a ��� ��� ��� ��� ��& ��! ��A& �a&��&��&��& ��&(}����&0}i�<` `c xc�dc `c�0�C �b���# }��N�!}����&0}���A @�a H� P� X�� `�� h�& p�! x�A �� �� ��� ��� ��& ��! ��A ��a �� �� ��� ��� ��& ��! ��A& �a&�&�&��& ��&(8!&0N� &�� &%� � &. n & � 2ұ vP n и � v �� � �0 �P vPCނ4� ě��S�� v � � � � � � � � vX �� w( �� �� � �0 �X �p Ґ v` Ҡ Ҹ �� �� � � �8 �H �X �h �x w@ ӈ Ӑ � Ӱ �� �� �� �� �� v� � � �8 �h �X � �( �0 �8 �@ �H �P �` �p Ԁ Ԉ Ԑ Ԙ Ԡ Ը �� �� �� �� � � � �( �8 �H �P �` �p Հ Ր ՠ հ n �� �� �� �� �� �� � � � � � � � w� vP ě��S�� 1w� �8 �x 1}� 2�� �0 �� �@ 1}� 2�� �H 2�� �P �X �` �h �p �x ְ �� � �0 2ɀ �8 �@ �H �p �� 2Ɉ �H �x ׀ א נ �� 2ј �� �� 2�� �� �� �� �� �8 � �h �8 �( �@ �h ذ �� �� �� �� � �( �P � �x ٸ �� �( �P �p ڰ �� �� � �H �h ۘ �� �t �� � � �0 �H �h �� ܀ �� � �@ �P �x ݨ ݸ �� � �P �p ޘ �� �( �� � � �H �( �p ߈ ߨ �� �, �� � � �0 �H �h �8 �� � �8 �p ޘ �� �( �� �� � � � �� �� �x �8 �� � �H �( �0 �@ �H �p 2�� �� �� �D � 2Ұ �GCC: (Debian 4.4.5-10) 4.4.5 .shstrtab .client .lowmem .got .comment .branch_lt .bss & & & � & � � .� & & &%� &%� 8 & 0 &-� &-� & & ) & &. &. 4 &. &-� 1�� & &. 9 & �������� ( � 0net_veth � ��� |��"� �b��& �!��< �` ��}IZ� @@� @�# �b�}d[x� �A (| ��i �I N�!�A (8` 8! p�& |�N� 8 ��x &�� @A���yk 8 9k &}i�B@ � 9) &K���H =` K��� &� 8` N� ` ` ` |��"� ����|kx�& ����|�#x���!��� �? �C � 8` � A� $8! ��& ��������|�N� ` ` �+ H肀(8~ � �A (| ��i �I N�!�A (/� @� � �> ��8�? � K����? �b�0�) � �A (| ��i �I N�!�A (8` K��l &� ` ` ` |���������|�#x8� �& �!��g�� �xd ,x 8� 8� 8� 9 9 �~ H Q` |dy@� 8! ���x�& ��������|�N� �> �b�@;����) � �A (| ��i �I N�!�A (K��� &� ` |��!���A��|yx|�#x�& �a��?`� ��������c{ ���������!�A����x� ` ` ` �? �_ x &�} }i .U` �P @�&y`�;� A� \�� ��@A� �/� � |��A� @8���yk x� }}Z8� &)�x|��` ` ` � 9k &� 9) &B �� t�a p8`& �� � pH A` �? 8 &x /� � @� �< =)� �< /� A��88! ���x�& �!���A���a��|���������������N� ` �< �b�H�) � �A (| ��i �I N�!�A (K��\` 8! �;� ��x�& �!���A���a��|���������������N� &� |��������& �!���? � /� @� 8! �8` �& ����|�N� ` �� 8`&H !` � (/� A� (�? �) @� �A (| ��i �I N�!�A (� 0/� A� (�? �) @� �A (| ��i �I N�!�A (� /� A� (�? �) @� �A (| ��i �I N�!�A (� 8/� A� (�? �) @� �A (| ��i �I N�!�A (�? 8! �8 8` ����� �& |�N� &�& |���������8` �& �a�������������!�Q�� � /� A� ,8! ��& �a��������|���������N� ` = � � 8� �? �? 8` �) 8� �A (| ��i �I N�!�A (�? 8� 8 � 08`& � (�) 8� �A (| ��i �I N�!�A (�? � 8` `c��) 0� �A (| ��i �I N�!�A (� 0/� � 8A� ��� (/� A� ��? /� A� �/� A� �8� < � � P�� y& ,` & `c x 8 &y�� @8`&;� H &�` |dy@�&�;� ?�� c� c�� ��x` ` �? @�� 8`& | �| �*�& t;� �� p� pH &u` �� @����; 8! �8 &8` �a������ �& �������|�����N� �? �b�P�) � �A (| ��i �I N�!�A (� (/� A� (�? �) @� �A (| ��i �I N�!�A (� 0/� A� (�? �) @� �A (| ��i �I N�!�A (� /� A� (�? �) @� �A (| ��i �I N�!�A (� 88`��/� A��|�? |x�) @� �A (| ��i �I N�!�A (8`��K��L�? �b�X�) � �A (| ��i �I N�!�A (K�� &� D "N� xf��8` X8� 8� &D "N� }H�H -}H�, M� = �a) 8�� |dH�8� &�� N� 8`��= �a) 8�� �� |0@L� 8` T8� D "= �a) 8�� 8` �i ( M� 8`���� �� N� � �� |dx8`&D "N� 9` }*Kx} Cx|�;x|�3x|�+x|�#x|dx8`& D "N� BSS size (%llu bytes) is too big!
5765: IBM,l-lan veth: netdevice not supported
5766: veth: Error %ld sending packet !
5767: veth: Dropping too big packet [%d bytes]
5768: veth: Failed to allocate memory !
5769: veth: Error %ld registering interface !
5770: & � x � ` � H � 0 � � � ��� � � ��� �&� ��� �� ��� �P ��� �� ��� � � ` � � � � �
5771: � � � � � � � � �
5772: �
5773: P �
5774: x�������� <� <] (ide.fs 1 encode-int s" #address-cells" property
5775: 0 encode-int s" #size-cells" property
5776: : decode-unit 1 hex-decode-unit ;
5777: : encode-unit 1 hex-encode-unit ;
5778: 0 VALUE >ata \ base address for command-block
5779: 0 VALUE >ata1 \ base address for control block
5780: true VALUE no-timeout \ flag that no timeout occured
5781: 0c CONSTANT #cdb-bytes \ command descriptor block (12 bytes)
5782: 800 CONSTANT atapi-size
5783: 200 CONSTANT ata-size
5784: : ata-ctrl! 2 >ata1 + io-c! ; \ device control reg
5785: : ata-astat@ 2 >ata1 + io-c@ ; \ read alternate status
5786: : ata-data@ 0 >ata + io-w@ ; \ data reg
5787: : ata-data! 0 >ata + io-w! ; \ data reg
5788: : ata-err@ 1 >ata + io-c@ ; \ error reg
5789: : ata-feat! 1 >ata + io-c! ; \ feature reg
5790: : ata-cnt@ 2 >ata + io-c@ ; \ sector count reg
5791: : ata-cnt! 2 >ata + io-c! ; \ sector count reg
5792: : ata-lbal! 3 >ata + io-c! ; \ lba low reg
5793: : ata-lbal@ 3 >ata + io-c@ ; \ lba low reg
5794: : ata-lbam! 4 >ata + io-c! ; \ lba mid reg
5795: : ata-lbam@ 4 >ata + io-c@ ; \ lba mid reg
5796: : ata-lbah! 5 >ata + io-c! ; \ lba high reg
5797: : ata-lbah@ 5 >ata + io-c@ ; \ lba high reg
5798: : ata-dev! 6 >ata + io-c! ; \ device reg
5799: : ata-dev@ 6 >ata + io-c@ ; \ device reg
5800: : ata-cmd! 7 >ata + io-c! ; \ command reg
5801: : ata-stat@ 7 >ata + io-c@ ; \ status reg
5802: 00 CONSTANT cmd#nop \ ATA and ATAPI
5803: 08 CONSTANT cmd#device-reset \ ATAPI only (mandatory)
5804: 20 CONSTANT cmd#read-sector \ ATA and ATAPI
5805: 90 CONSTANT cmd#execute-device-diagnostic \ ATA and ATAPI
5806: a0 CONSTANT cmd#packet \ ATAPI only (mandatory)
5807: a1 CONSTANT cmd#identify-packet-device \ ATAPI only (mandatory)
5808: ec CONSTANT cmd#identify-device \ ATA and ATAPI
5809: : set-regs ( n -- )
5810: dup
5811: 01 and \ only Chan 0 or Chan 1 allowed
5812: 3 lshift dup 10 + config-l@ -4 and to >ata
5813: 14 + config-l@ -4 and to >ata1
5814: 02 ata-ctrl! \ disable interrupts
5815: 02 and
5816: IF
5817: 10
5818: ELSE
5819: 00
5820: THEN
5821: ata-dev!
5822: ;
5823: ata-size VALUE block-size
5824: 80000 VALUE max-transfer \ Arbitrary, really
5825: CREATE sector d# 512 allot
5826: CREATE packet-cdb #cdb-bytes allot
5827: CREATE return-buffer atapi-size allot
5828: scsi-open \ add scsi functions
5829: : show-regs
5830: cr
5831: cr ." alt. Status: " ata-astat@ .
5832: cr ." Status : " ata-stat@ .
5833: cr ." Device : " ata-dev@ .
5834: cr ." Error-Reg : " ata-err@ .
5835: cr ." Sect-Count : " ata-cnt@ .
5836: cr ." LBA-Low : " ata-lbal@ .
5837: cr ." LBA-Med : " ata-lbam@ .
5838: cr ." LBA-High : " ata-lbah@ .
5839: ;
5840: : status-check ( -- )
5841: ata-stat@
5842: dup
5843: 01 and \ is 'check' flag set ?
5844: IF
5845: cr
5846: ." - ATAPI-Status: " .
5847: ata-err@ \ retrieve sense code
5848: dup
5849: 60 = \ sense code = 6 ?
5850: IF
5851: ." ( media changed or reset )" \ 'unit attention'
5852: drop \ drop err-reg content
5853: ELSE
5854: dup
5855: ." (Err : " . \ show err-reg content
5856: space
5857: rshift 4 .sense-text \ show text string
5858: 29 emit
5859: THEN
5860: cr
5861: ELSE
5862: drop \ remove unused status
5863: THEN
5864: ;
5865: : wait-for-ready
5866: get-msecs \ start timer
5867: BEGIN
5868: ata-stat@ 80 and 0<> \ busy flag still set ?
5869: no-timeout and
5870: WHILE \ yes
5871: dup get-msecs swap
5872: - \ calculate timer difference
5873: FFFF AND \ reduce to 65.5 seconds
5874: d# 5000 > \ difference > 5 seconds ?
5875: IF
5876: false to no-timeout
5877: THEN
5878: REPEAT
5879: drop
5880: ;
5881: : wait-for-status ( val mask -- )
5882: get-msecs \ initial timer value (start)
5883: >r
5884: BEGIN
5885: 2dup \ val mask
5886: ata-stat@ and <> \ expected status ?
5887: no-timeout and \ and no timeout ?
5888: WHILE
5889: get-msecs r@ - \ calculate timer difference
5890: FFFF AND \ mask-off overflow bits
5891: d# 5000 > \ 5 seconds exceeded ?
5892: IF
5893: false to no-timeout \ set global flag
5894: THEN
5895: REPEAT
5896: r> \ clean return stack
5897: 3drop
5898: ;
5899: : cut-string ( saddr nul -- )
5900: swap
5901: over +
5902: swap
5903: 1 rshift \ bytecount -> wordcount
5904: 0 do
5905: /w -
5906: dup ( addr -- addr addr )
5907: w@ ( addr addr -- addr nuw )
5908: dup ( addr nuw -- addr nuw nuw )
5909: 2020 =
5910: IF
5911: drop
5912: 0
5913: ELSE
5914: LEAVE
5915: THEN
5916: over
5917: w!
5918: LOOP
5919: drop
5920: drop
5921: ;
5922: : show-model ( dev# chan# -- )
5923: 2dup
5924: ." CH " . \ channel 0 / 1
5925: 0= IF ." / MA" \ Master / Slave
5926: ELSE ." / SL"
5927: THEN
5928: swap
5929: 2 * + ." (@" . ." ) : " \ device number
5930: sector 1 +
5931: c@
5932: 80 AND 0=
5933: IF
5934: ." ATA-Drive "
5935: ELSE
5936: ." ATAPI-Drive "
5937: THEN
5938: 22 emit \ start string display with "
5939: sector d# 54 + \ string starts 54 bytes from buffer start
5940: dup
5941: d# 40 \ and is 40 chars long
5942: cut-string \ remove all trailing spaces
5943: BEGIN
5944: dup
5945: w@
5946: wbflip
5947: wbsplit
5948: dup 0<> \ first char
5949: IF
5950: emit
5951: dup 0<> \ second char
5952: IF
5953: emit
5954: wa1+ \ increment address for next
5955: false
5956: ELSE \ second char = EndOfString
5957: drop
5958: true
5959: THEN
5960: ELSE \ first char = EndOfString
5961: drop
5962: drop
5963: true
5964: THEN
5965: UNTIL \ end of string detected
5966: drop
5967: 22 emit \ end string display
5968: sector c@ \ get lower byte of first doublet
5969: 80 AND \ check bit 7
5970: IF
5971: ." (removable media)"
5972: THEN
5973: sector 1 +
5974: c@
5975: 80 AND 0= IF \ is this an ATA drive ?
5976: sector d# 120 + \ get word 60 + 61
5977: rl@-le \ read 32-bit as little endian value
5978: d# 512 \ standard ATA block-size
5979: swap
5980: .capacity-text ( block-size #blocks -- )
5981: THEN
5982: sector d# 98 + \ goto word 49
5983: w@
5984: wbflip
5985: 200 and 0= IF cr ." ** LBA is not supported " THEN
5986: sector c@ \ get lower byte of first doublet
5987: 03 AND 01 = \ we use 12-byte packet commands (=00b)
5988: IF
5989: cr ." packet size = 16 ** not supported ! **"
5990: THEN
5991: no-timeout not \ any timeout occured so far ?
5992: IF
5993: cr ." ** timeout **"
5994: THEN
5995: ;
5996: : pio-sector ( addr -- ) 100 0 DO ata-data@
5997: over w! wa1+ LOOP drop ;
5998: : pio-sector ( addr -- )
5999: wait-for-ready pio-sector ;
6000: : pio-sectors ( n addr -- ) swap 0 ?DO dup pio-sector 200 + LOOP drop ;
6001: : lba! lbsplit
6002: 0f and 40 or \ always set LBA-mode + LBA (27..24)
6003: ata-dev@ 10 and or \ add current device-bit (DEV)
6004: ata-dev! \ set LBA (27..24)
6005: ata-lbah! \ set LBA (23..16)
6006: ata-lbam! \ set LBA (15..8)
6007: ata-lbal! \ set LBA (7..0)
6008: ;
6009: : read-sectors ( lba count addr -- )
6010: >r dup >r ata-cnt! lba! 20 ata-cmd! r> r> pio-sectors ;
6011: : read-sectors ( lba count addr dev-nr -- )
6012: set-regs ( lba count addr ) \ Set ata regs
6013: BEGIN >r dup 100 > WHILE
6014: over 100 r@ read-sectors
6015: >r 100 + r> 100 - r> 20000 + REPEAT
6016: r> read-sectors
6017: ;
6018: : ata-read-blocks ( addr block# #blocks dev# -- #read )
6019: swap dup >r swap >r rot r> ( addr block# #blocks dev # R: #blocks )
6020: read-sectors r> ( R: #read )
6021: ;
6022: : set-lba ( block-length -- )
6023: lbsplit ( quad -- b1.lo b2 b3 b4.hi )
6024: drop \ skip upper two bytes
6025: drop
6026: ata-lbah!
6027: ata-lbam!
6028: ;
6029: : read-pio-block ( buff-addr -- buff-addr-new )
6030: ata-lbah@ 8 lshift \ get block length High
6031: ata-lbam@ or \ get block length Low
6032: 1 rshift \ bcount -> wcount
6033: dup
6034: 0> IF \ any data to transfer?
6035: 0 DO \ words to read
6036: dup \ buffer-address
6037: ata-data@ swap w! \ write 16-bits
6038: wa1+ \ address of next entry
6039: LOOP
6040: ELSE
6041: drop ( buff-addr wcount -- buff-addr )
6042: THEN
6043: wait-for-ready
6044: ;
6045: : send-atapi-packet ( req-buffer -- )
6046: >r ( R: req-buffer )
6047: atapi-size set-lba \ set regs to length limit
6048: 00 ata-feat!
6049: cmd#packet ata-cmd! \ A0 = ATAPI packet command
6050: 48 C8 wait-for-status ( val mask -- ) \ BSY:0 DRDY:1 DRQ:1
6051: 6 0 do
6052: packet-cdb i 2 * + \ transfer command block (12 bytes)
6053: w@
6054: ata-data! \ 6 doublets PIO transfer to device
6055: loop \ copy packet to data-reg
6056: status-check ( -- ) \ status err bit set ? -> display
6057: wait-for-ready ( -- ) \ busy released ?
6058: BEGIN
6059: ata-stat@ 08 and 08 = WHILE \ Data-Request-Bit set ?
6060: r> \ get last target buffer address
6061: read-pio-block \ only if from device requested
6062: >r \ start of next block
6063: REPEAT
6064: r> \ original value
6065: drop \ return clean
6066: ;
6067: : atapi-packet-io ( -- )
6068: return-buffer atapi-size erase \ clear return buffer
6069: return-buffer send-atapi-packet \ send 'packet-cdb' , get 'return-buffer'
6070: ;
6071: : atapi-test ( -- true|false )
6072: packet-cdb scsi-build-test-unit-ready \ command-code: 00
6073: atapi-packet-io ( ) \ send CDB, get return-buffer
6074: ata-stat@ 1 and IF false ELSE true THEN
6075: ;
6076: : atapi-sense ( -- ascq asc sense-key )
6077: d# 252 packet-cdb scsi-build-request-sense ( alloc-len cdb -- )
6078: atapi-packet-io ( ) \ send CDB, get return-buffer
6079: return-buffer scsi-get-sense-data ( cdb-addr -- ascq asc sense-key )
6080: ;
6081: : atapi-read-blocks ( address block# #blocks dev# -- #read-blocks )
6082: set-regs ( address block# #blocks )
6083: dup >r ( address block# #blocks )
6084: packet-cdb scsi-build-read-10 ( address block# #blocks cdb -- )
6085: send-atapi-packet ( address -- )
6086: r> \ return requested number of blocks
6087: ;
6088: : atapi-read-capacity ( -- )
6089: packet-cdb scsi-build-read-cap-10 \ fill block with command
6090: atapi-packet-io ( ) \ send CDB, get return-buffer
6091: return-buffer scsi-get-capacity-10 ( cdb -- block-size #blocks )
6092: .capacity-text ( block-size #blocks -- )
6093: status-check ( -- )
6094: ;
6095: : atapi-read-capacity-ext ( -- )
6096: packet-cdb scsi-build-read-cap-16 \ fill block with command
6097: atapi-packet-io ( ) \ send CDB, get return-buffer
6098: return-buffer scsi-get-capacity-16 ( cdb -- block-size #blocks )
6099: .capacity-text ( block-size #blocks -- )
6100: status-check ( -- )
6101: ;
6102: : wait-for-media-ready ( -- true|false )
6103: get-msecs \ initial timer value (start)
6104: >r
6105: BEGIN
6106: atapi-test \ unit ready? false if not
6107: not
6108: no-timeout and
6109: WHILE
6110: atapi-sense ( -- ascq asc sense-key )
6111: 02 = \ sense key 2 = media error
6112: IF \ check add. sense code
6113: 3A = \ asc: device not ready ?
6114: IF
6115: false to no-timeout
6116: ." empty (" . 29 emit \ show asc qualifier
6117: ELSE
6118: drop \ discard asc qualifier
6119: THEN \ medium not present, abort waiting
6120: ELSE
6121: drop \ discard asc
6122: drop \ discard ascq
6123: THEN
6124: get-msecs r@ - \ calculate timer difference
6125: FFFF AND \ mask-off overflow bits
6126: d# 5000 > \ 5 seconds exceeded ?
6127: IF
6128: false to no-timeout \ set global flag
6129: THEN
6130: REPEAT
6131: r>
6132: drop
6133: no-timeout
6134: ;
6135: 2 CONSTANT #chan
6136: 2 CONSTANT #dev
6137: : #totaldev #dev #chan * ;
6138: CREATE read-blocks-xt #totaldev cells allot read-blocks-xt #totaldev cells erase
6139: : dev-read-blocks ( address block# #blocks dev# -- #read-blocks )
6140: dup cells read-blocks-xt + @ execute
6141: ;
6142: : read-ident ( -- true|false )
6143: false
6144: 00 ata-lbal! \ clear previous signature
6145: 00 ata-lbam!
6146: 00 ata-lbah!
6147: cmd#identify-device ata-cmd! wait-for-ready \ first try ATA, ATAPI aborts command
6148: ata-stat@ CF and 48 =
6149: IF
6150: drop true \ cmd accepted, this is a ATA
6151: d# 512 set-lba \ set LBA to sector-length
6152: ELSE \ ATAPI sends signature instead
6153: ata-lbam@ 14 = IF \ cylinder low = 14 ?
6154: ata-lbah@ EB = IF \ cylinder high = EB ?
6155: cmd#device-reset ata-cmd! wait-for-ready \ only supported by ATAPI
6156: cmd#identify-packet-device ata-cmd! wait-for-ready \ first try ata
6157: ata-stat@ CF and 48 = IF
6158: drop true \ replace flag
6159: THEN
6160: THEN
6161: THEN
6162: THEN
6163: dup IF
6164: ata-stat@ 8 AND IF \ data requested (as expected) ?
6165: sector read-pio-block
6166: drop \ discard address end
6167: ELSE
6168: drop false
6169: THEN
6170: THEN
6171: no-timeout not IF \ check without any timeout ?
6172: drop
6173: false \ no, detection discarded
6174: THEN
6175: ;
6176: scsi-close \ remove scsi commands from word list
6177: : find-disks ( -- )
6178: #chan 0 DO \ check 2 channels (primary & secondary)
6179: #dev 0 DO \ check 2 devices per channel (master / slave)
6180: i 2 * j +
6181: set-regs \ set base address and dev-register for register access
6182: ata-stat@ 7f and 7f <> \ Check, if device is connected
6183: IF
6184: true to no-timeout \ preset timeout-flag
6185: read-ident ( -- true|false )
6186: IF
6187: i j show-model \ print manufacturer + device string
6188: sector 1+ c@ C0 and 80 = \ Check for ata or atapi
6189: IF
6190: wait-for-media-ready \ wait up to 5 sec if not ready
6191: no-timeout and
6192: IF
6193: atapi-read-capacity
6194: atapi-size to block-size \ ATAPI: 2048 bytes
6195: 80000 to max-transfer
6196: ['] atapi-read-blocks i 2 * j + cells read-blocks-xt + !
6197: s" cdrom" strdup i 2 * j + s" generic-disk.fs" included
6198: ELSE
6199: ." -" \ show hint for not registered
6200: THEN
6201: ELSE
6202: ata-size to block-size \ ATA: 512 bytes
6203: 80000 to max-transfer
6204: ['] ata-read-blocks i 2 * j + cells read-blocks-xt + !
6205: s" disk" strdup i 2 * j + s" generic-disk.fs" included
6206: THEN
6207: cr
6208: THEN
6209: THEN
6210: i 2 * j + 200 + cp
6211: LOOP
6212: LOOP
6213: ;
6214: find-disks
6215: �������� )` )% 0fbuffer.fs 0 VALUE line#
6216: 0 VALUE column#
6217: false VALUE inverse?
6218: false VALUE inverse-screen?
6219: 18 VALUE #lines
6220: 50 VALUE #columns
6221: false VALUE cursor
6222: false VALUE saved-cursor
6223: defer draw-character \ 2B inited by display driver
6224: defer reset-screen \ 2B inited by display driver
6225: defer toggle-cursor \ 2B inited by display driver
6226: defer erase-screen \ 2B inited by display driver
6227: defer blink-screen \ 2B inited by display driver
6228: defer invert-screen \ 2B inited by display driver
6229: defer insert-characters \ 2B inited by display driver
6230: defer delete-characters \ 2B inited by display driver
6231: defer insert-lines \ 2B inited by display driver
6232: defer delete-lines \ 2B inited by display driver
6233: defer draw-logo \ 2B inited by display driver
6234: : nop-toggle-cursor ( nop ) ;
6235: ' nop-toggle-cursor to toggle-cursor
6236: : (cursor-off) ( -- ) cursor dup to saved-cursor
6237: IF toggle-cursor false to cursor THEN ;
6238: : (cursor-on) ( -- ) cursor dup to saved-cursor
6239: 0= IF toggle-cursor true to cursor THEN ;
6240: : restore-cursor ( -- ) saved-cursor dup cursor
6241: <> IF toggle-cursor to cursor ELSE drop THEN ;
6242: ' (cursor-off) to cursor-off
6243: ' (cursor-on) to cursor-on
6244: false VALUE esc-on
6245: false VALUE csi-on
6246: defer esc-process
6247: 0 VALUE esc-num-parm
6248: 0 VALUE esc-num-parm2
6249: 0 VALUE saved-line#
6250: 0 VALUE saved-column#
6251: : get-esc-parm ( default -- value )
6252: esc-num-parm dup 0> IF nip ELSE drop THEN 0 to esc-num-parm ;
6253: : get-esc-parm2 ( default -- value )
6254: esc-num-parm2 dup 0> IF nip ELSE drop THEN 0 to esc-num-parm2 ;
6255: : set-esc-parm ( newdigit -- ) [char] 0 - esc-num-parm a * + to esc-num-parm ;
6256: : reverse-cursor ( oldpos -- newpos) dup IF 1 get-esc-parm - THEN ;
6257: : advance-cursor ( bound oldpos -- newpos) tuck > IF 1 get-esc-parm + THEN ;
6258: : erase-in-line #columns column# - dup 0> IF delete-characters ELSE drop THEN ;
6259: : terminal-line++ ( -- )
6260: line# 1+ dup #lines = IF 1- 0 to line# 1 delete-lines THEN
6261: to line#
6262: ;
6263: 0 VALUE dang
6264: 0 VALUE blipp
6265: : ansi-esc ( char -- )
6266: csi-on IF
6267: dup [char] 0 [char] 9 between IF set-esc-parm
6268: ELSE CASE
6269: [char] A OF line# reverse-cursor to line# ENDOF
6270: [char] B OF #lines line# advance-cursor to line# ENDOF
6271: [char] C OF #columns column# advance-cursor to column# ENDOF
6272: [char] D OF column# reverse-cursor to column# ENDOF
6273: [char] E OF ( FIXME: Cursor Next Line - No idea what does it mean )
6274: #lines line# advance-cursor to line#
6275: ENDOF
6276: [char] f OF
6277: 1 get-esc-parm2 to line# column# get-esc-parm to column#
6278: ENDOF
6279: [char] H OF
6280: 1 get-esc-parm2 to line# column# get-esc-parm to column#
6281: ENDOF
6282: [char] ; OF 0 get-esc-parm to esc-num-parm2 ENDOF
6283: [char] J OF
6284: #lines line# - dup 0> IF
6285: line# 1+ to line# delete-lines line# 1- to line#
6286: ELSE drop THEN
6287: erase-in-line
6288: ENDOF
6289: [char] K OF erase-in-line ENDOF
6290: [char] L OF 1 get-esc-parm insert-lines ENDOF
6291: [char] M OF 1 get-esc-parm delete-lines ENDOF
6292: [char] @ OF 1 get-esc-parm insert-characters ENDOF
6293: [char] P OF 1 get-esc-parm delete-characters ENDOF
6294: [char] m OF 0 get-esc-parm 0<> to inverse? ENDOF
6295: [char] p OF inverse-screen? IF false to inverse-screen?
6296: inverse? 0= to inverse? invert-screen
6297: THEN
6298: ENDOF
6299: [char] q OF inverse-screen? 0= IF true to inverse-screen?
6300: inverse? 0= to inverse? invert-screen
6301: THEN
6302: ENDOF
6303: [char] u OF saved-line# to line# saved-column# to column# ENDOF
6304: dup dup to dang OF blink-screen ENDOF
6305: ENDCASE false to csi-on
6306: false to esc-on 0 to esc-num-parm 0 to esc-num-parm2
6307: THEN
6308: ELSE CASE
6309: [char] 7 OF line# to saved-line# column# to saved-column# ENDOF
6310: [char] 8 OF saved-line# to line# saved-column# to column# ENDOF
6311: [char] [ OF true to csi-on ENDOF
6312: dup dup OF false to esc-on to blipp ENDOF
6313: ENDCASE
6314: csi-on 0= IF false to esc-on THEN 0 to esc-num-parm 0 to esc-num-parm2
6315: THEN
6316: ;
6317: ' ansi-esc to esc-process
6318: CREATE twtracebuf 4000 allot twtracebuf 4000 erase
6319: twtracebuf VALUE twbp
6320: 0 VALUE twbc
6321: : twtrace
6322: twbc 4000 = IF 0 to twbc twtracebuf to twbp THEN
6323: dup twbp c! twbp 1+ to twbp twbc 1+ to twbc
6324: ;
6325: : terminal-write ( addr len -- actual-len )
6326: cursor-off
6327: tuck bounds ?DO i c@
6328: twtrace
6329: esc-on IF esc-process
6330: ELSE CASE
6331: 1B OF true to esc-on ENDOF
6332: carret OF 0 to column# ENDOF
6333: linefeed OF terminal-line++ ENDOF
6334: bell OF blink-screen ENDOF
6335: 9 ( TAB ) OF column# 7 + -8 and dup #columns < IF
6336: to column#
6337: ELSE drop THEN
6338: ENDOF
6339: B ( VT ) OF line# ?dup IF 1- to line# THEN ENDOF
6340: C ( FF ) OF 0 to line# 0 to column# erase-screen ENDOF
6341: bs OF column# 1- dup 0< IF
6342: line# IF
6343: line# 1- to line#
6344: drop #columns 1-
6345: ELSE drop column#
6346: THEN
6347: THEN
6348: to column# ( bl draw-character )
6349: ENDOF
6350: dup OF
6351: i c@ draw-character
6352: column# 1+ dup #columns >= IF
6353: drop 0 terminal-line++
6354: THEN
6355: to column#
6356: ENDOF
6357: ENDCASE
6358: THEN
6359: LOOP
6360: restore-cursor
6361: ;
6362: 0 VALUE char-height
6363: 0 VALUE char-width
6364: 0 VALUE fontbytes
6365: CREATE display-emit-buffer 20 allot
6366: defer dis-old-emit
6367: ' emit behavior to dis-old-emit
6368: : display-write terminal-write ;
6369: : display-emit dup dis-old-emit display-emit-buffer tuck c! 1 terminal-write drop ;
6370: : is-install ( 'open -- )
6371: s" defer vendor-open to vendor-open" eval
6372: s" : open deadbeef vendor-open dup deadbeef = IF drop true ELSE nip THEN ;" eval
6373: s" defer write ' display-write to write" eval
6374: s" : draw-logo ['] draw-logo CATCH IF 2drop 2drop THEN ;" eval
6375: s" : reset-screen ['] reset-screen CATCH drop ;" eval
6376: ;
6377: : is-remove ( 'close -- )
6378: s" defer close to close" eval
6379: ;
6380: : is-selftest ( 'selftest -- )
6381: s" defer selftest to selftest" eval
6382: ;
6383: STRUCT
6384: cell FIELD font>addr
6385: cell FIELD font>width
6386: cell FIELD font>height
6387: cell FIELD font>advance
6388: cell FIELD font>min-char
6389: cell FIELD font>#glyphs
6390: CONSTANT /font
6391: CREATE default-font-ctrblk /font allot default-font-ctrblk
6392: dup font>addr 0 swap !
6393: dup font>width 8 swap !
6394: dup font>height -10 swap !
6395: dup font>advance 1 swap !
6396: dup font>min-char 20 swap !
6397: font>#glyphs 7f swap !
6398: : display-default-font ( str len -- )
6399: romfs-lookup dup 0= IF drop EXIT THEN
6400: 600 <> IF ." Only support 60x8x16 fonts ! " drop EXIT THEN
6401: default-font-ctrblk font>addr !
6402: ;
6403: s" default-font.bin" display-default-font
6404: : .scan-lines ( height -- scanlines ) dup 0>= IF 1- ELSE negate THEN ;
6405: : set-font ( addr width height advance min-char #glyphs -- )
6406: default-font-ctrblk /font + /font 0
6407: DO
6408: 1 cells - dup >r ! r> 1 cells
6409: +LOOP drop
6410: default-font-ctrblk dup font>height @ abs to char-height
6411: dup font>width @ to char-width font>advance @ to fontbytes
6412: ;
6413: : >font ( char -- addr )
6414: dup default-font-ctrblk dup >r font>min-char @ dup r@ font>#glyphs + within
6415: IF
6416: r@ font>min-char @ -
6417: r@ font>advance @ * r@ font>height @ .scan-lines *
6418: r> font>addr @ +
6419: ELSE
6420: drop r> font>addr @
6421: THEN
6422: ;
6423: : default-font ( -- addr width height advance min-char #glyphs )
6424: default-font-ctrblk /font 0 DO dup cell+ >r @ r> 1 cells +LOOP drop
6425: ;
6426: 0 VALUE frame-buffer-adr
6427: 0 VALUE screen-height
6428: 0 VALUE screen-width
6429: 0 VALUE window-top
6430: 0 VALUE window-left
6431: 0 VALUE .sc
6432: : screen-#rows .sc IF 18 ELSE true to .sc s" screen-#rows" eval false to .sc THEN ;
6433: : screen-#columns .sc IF 50 ELSE true to .sc s" screen-#columns" eval false to .sc THEN ;
6434: : fb8-background inverse-screen? ;
6435: : fb8-foreground inverse? invert ;
6436: : fb8-lines2bytes ( #lines -- #bytes ) char-height * screen-width * ;
6437: : fb8-columns2bytes ( #columns -- #bytes ) char-width * ;
6438: : fb8-line2addr ( line# -- addr )
6439: char-height * window-top + screen-width *
6440: frame-buffer-adr + window-left +
6441: ;
6442: : fb8-erase-block ( addr len ) fb8-background rfill ;
6443: 0 VALUE .ab
6444: CREATE bitmap-buffer 400 allot
6445: : active-bits ( -- new ) .ab dup 8 > IF 8 - to .ab 8 ELSE
6446: char-width to .ab ?dup 0= IF recurse THEN
6447: THEN ;
6448: : fb8-char2bitmap ( font-height font-addr -- bitmap-buffer )
6449: bitmap-buffer >r
6450: char-height rot 0> IF r> char-width 2dup fb8-erase-block + >r 1- THEN
6451: r> -rot char-width to .ab
6452: fontbytes * bounds ?DO
6453: i c@ active-bits 0 ?DO
6454: dup 80 and IF fb8-foreground ELSE fb8-background THEN
6455: ( fb-addr fbyte colr ) 2 pick ! 1 lshift swap 1+ swap
6456: LOOP drop
6457: LOOP drop
6458: bitmap-buffer
6459: ;
6460: : fb8-draw-logo ( line# addr width height -- ) ." fb8-draw-logo ( " .s ." )" cr
6461: 2drop 2drop
6462: ;
6463: : fb8-toggle-cursor ( -- )
6464: line# fb8-line2addr column# fb8-columns2bytes +
6465: char-height 0 ?DO
6466: char-width 0 ?DO dup dup rb@ -1 xor swap rb! 1+ LOOP
6467: screen-width + char-width -
6468: LOOP drop
6469: ;
6470: : fb8-draw-character ( char -- )
6471: >r default-font over + r@ -rot between IF
6472: 2swap 3drop r> >font fb8-char2bitmap ( bitmap-buf )
6473: line# fb8-line2addr column# fb8-columns2bytes + ( bitmap-buf fb-addr )
6474: char-height 0 ?DO
6475: 2dup char-width mrmove
6476: screen-width + >r char-width + r>
6477: LOOP 2drop
6478: ELSE 2drop r> 3drop THEN
6479: ;
6480: : fb8-insert-lines ( n -- )
6481: fb8-lines2bytes >r line# fb8-line2addr dup dup r@ +
6482: #lines line# - fb8-lines2bytes r@ - rmove
6483: r> fb8-erase-block
6484: ;
6485: : fb8-delete-lines ( n -- )
6486: fb8-lines2bytes >r line# fb8-line2addr dup dup r@ + swap
6487: #lines fb8-lines2bytes r@ - dup >r rmove
6488: r> + r> fb8-erase-block
6489: ;
6490: : fb8-insert-characters ( n -- )
6491: line# fb8-line2addr column# fb8-columns2bytes + >r
6492: #columns column# - 2dup >= IF
6493: nip dup 0> IF fb8-columns2bytes r> ELSE r> 2drop EXIT THEN
6494: ELSE
6495: fb8-columns2bytes swap fb8-columns2bytes tuck -
6496: over r@ tuck + rot char-height 0 ?DO
6497: 3dup rmove
6498: -rot screen-width tuck + -rot + swap rot
6499: LOOP
6500: 3drop r>
6501: THEN
6502: char-height 0 ?DO dup 2 pick fb8-erase-block screen-width + LOOP 2drop
6503: ;
6504: : fb8-delete-characters ( n -- )
6505: line# fb8-line2addr column# fb8-columns2bytes + >r
6506: #columns column# - 2dup >= IF
6507: nip dup 0> IF fb8-columns2bytes r> ELSE r> 2drop EXIT THEN
6508: ELSE
6509: fb8-columns2bytes swap fb8-columns2bytes tuck -
6510: over r@ + 2dup + r> swap >r rot char-height 0 ?DO
6511: 3dup rmove
6512: -rot screen-width tuck + -rot + swap rot
6513: LOOP
6514: 3drop r> over -
6515: THEN
6516: char-height 0 ?DO dup 2 pick fb8-erase-block screen-width + LOOP 2drop
6517: ;
6518: : fb8-reset-screen ( -- ) ( Left as no-op by design ) ;
6519: : fb8-erase-screen ( -- )
6520: frame-buffer-adr screen-height screen-width * fb8-erase-block
6521: ;
6522: : fb8-invert-screen ( -- )
6523: frame-buffer-adr screen-height screen-width * 2dup /x / 0 ?DO
6524: dup rx@ -1 xor over rx! xa1+
6525: LOOP 3drop
6526: ;
6527: : fb8-blink-screen ( -- ) fb8-invert-screen fb8-invert-screen ;
6528: : fb8-install ( width height #columns #lines -- )
6529: screen-#rows min to #lines
6530: screen-#columns min to #columns
6531: dup to screen-height char-height #lines * - 2/ to window-top
6532: dup to screen-width char-width #columns * - 2/ to window-left
6533: ['] fb8-toggle-cursor to toggle-cursor
6534: ['] fb8-draw-character to draw-character
6535: ['] fb8-insert-lines to insert-lines
6536: ['] fb8-delete-lines to delete-lines
6537: ['] fb8-insert-characters to insert-characters
6538: ['] fb8-delete-characters to delete-characters
6539: ['] fb8-erase-screen to erase-screen
6540: ['] fb8-blink-screen to blink-screen
6541: ['] fb8-invert-screen to invert-screen
6542: ['] fb8-reset-screen to reset-screen
6543: ['] fb8-draw-logo to draw-logo
6544: ;
6545: : fb8-dump-bitmap cr char-height 0 ?do char-width 0 ?do dup c@ if ." @" else ." ." then 1+ loop cr loop drop ;
6546: : fb8-dump-char >font -b swap fb8-char2bitmap fb8-dump-bitmap ;
6547: �������� � 0generic-disk.fs new-device set-unit ( str len )
6548: 2dup device-name
6549: s" 0 pci-alias-" 2swap $cat evaluate
6550: s" block" device-type
6551: s" block-size" $call-parent CONSTANT block-size
6552: s" max-transfer" $call-parent CONSTANT max-transfer
6553: : read-blocks ( addr block# #blocks -- #read )
6554: my-unit s" dev-read-blocks" $call-parent
6555: ;
6556: INSTANCE VARIABLE deblocker
6557: : open ( -- okay? )
6558: 0 0 s" deblocker" $open-package dup deblocker ! dup IF
6559: s" disk-label" find-package IF
6560: my-args rot interpose
6561: THEN
6562: THEN 0<> ;
6563: : close ( -- )
6564: deblocker @ close-package ;
6565: : seek ( pos.lo pos.hi -- status )
6566: s" seek" deblocker @ $call-method ;
6567: : read ( addr len -- actual )
6568: s" read" deblocker @ $call-method ;
6569: finish-device
6570: �������� X 0pci-device.fs s" my-puid" $call-parent CONSTANT my-puid
6571: : config-b@ puid >r my-puid TO puid my-space + rtas-config-b@ r> TO puid ;
6572: : config-w@ puid >r my-puid TO puid my-space + rtas-config-w@ r> TO puid ;
6573: : config-l@ puid >r my-puid TO puid my-space + rtas-config-l@ r> TO puid ;
6574: : config-b! puid >r my-puid TO puid my-space + rtas-config-b! r> TO puid ;
6575: : config-w! puid >r my-puid TO puid my-space + rtas-config-w! r> TO puid ;
6576: : config-l! puid >r my-puid TO puid my-space + rtas-config-l! r> TO puid ;
6577: : config-dump puid >r my-puid TO puid my-space pci-dump r> TO puid ;
6578: : open
6579: puid >r \ save the old puid
6580: my-puid TO puid \ set up the puid to the devices Hostbridge
6581: pci-master-enable \ And enable Bus Master, IO and MEM access again.
6582: pci-mem-enable \ enable mem access
6583: pci-io-enable \ enable io access
6584: r> TO puid \ restore puid
6585: true
6586: ;
6587: : close
6588: puid >r \ save the old puid
6589: my-puid TO puid \ set up the puid
6590: pci-device-disable \ and disable the device
6591: r> TO puid \ restore puid
6592: ;
6593: : devicefile ( -- str len )
6594: s" pci-device_"
6595: my-space pci-vendor@ 4 int2str $cat
6596: s" _" $cat
6597: my-space pci-device@ 4 int2str $cat
6598: s" .fs" $cat
6599: ;
6600: : classfile ( -- str len )
6601: s" pci-class_"
6602: my-space pci-class@ 10 rshift 2 int2str $cat
6603: s" .fs" $cat
6604: ;
6605: : setup ( -- )
6606: devicefile romfs-lookup ?dup
6607: IF
6608: evaluate
6609: ELSE
6610: classfile romfs-lookup ?dup
6611: IF
6612: evaluate
6613: ELSE
6614: my-space pci-class-name type 2a emit cr
6615: my-space pci-device-generic-setup
6616: THEN
6617: THEN
6618: ;
6619: pci-device-disable
6620: pci-error-enable
6621: my-space 44 pci-out \ config-addr ascii('D')
6622: setup
6623: �������� ` ' 0pci-bridge.fs s" my-puid" $call-parent CONSTANT my-puid
6624: pci-bus-number 1+ CONSTANT my-bus
6625: s" pci-config-bridge.fs" included
6626: : filename ( -- str len )
6627: s" pci-bridge_"
6628: my-space pci-vendor@ 4 int2str $cat
6629: s" _" $cat
6630: my-space pci-device@ 4 int2str $cat
6631: s" .fs" $cat
6632: ;
6633: : setup ( -- )
6634: filename romfs-lookup ?dup
6635: IF
6636: evaluate
6637: ELSE
6638: my-space pci-class-name type 2a emit cr
6639: my-space pci-bridge-generic-setup
6640: my-space pci-reset-2nd
6641: THEN
6642: ;
6643: pci-device-disable
6644: pci-error-enable
6645: my-space 42 pci-out \ config-addr ascii('B')
6646: setup
6647: pci-master-enable
6648: pci-mem-enable
6649: pci-io-enable
6650: �������� �X � 8pci-properties.fs : pci-class-name-00 ( addr -- str len )
6651: pci-class@ 8 rshift FF and CASE
6652: 01 OF s" display" ENDOF
6653: dup OF s" unknown-legacy-device" ENDOF
6654: ENDCASE
6655: ;
6656: : pci-class-name-01 ( addr -- str len )
6657: pci-class@ 8 rshift FF and CASE
6658: 00 OF s" scsi" ENDOF
6659: 01 OF s" ide" ENDOF
6660: 02 OF s" fdc" ENDOF
6661: 03 OF s" ipi" ENDOF
6662: 04 OF s" raid" ENDOF
6663: 05 OF s" ata" ENDOF
6664: 06 OF s" sata" ENDOF
6665: 07 OF s" sas" ENDOF
6666: dup OF s" mass-storage" ENDOF
6667: ENDCASE
6668: ;
6669: : pci-class-name-02 ( addr -- str len )
6670: pci-class@ 8 rshift FF and CASE
6671: 00 OF s" ethernet" ENDOF
6672: 01 OF s" token-ring" ENDOF
6673: 02 OF s" fddi" ENDOF
6674: 03 OF s" atm" ENDOF
6675: 04 OF s" isdn" ENDOF
6676: 05 OF s" worldfip" ENDOF
6677: 05 OF s" picmg" ENDOF
6678: dup OF s" network" ENDOF
6679: ENDCASE
6680: ;
6681: : pci-class-name-03 ( addr -- str len )
6682: pci-class@ FFFF and CASE
6683: 0000 OF s" vga" ENDOF
6684: 0001 OF s" 8514-compatible" ENDOF
6685: 0100 OF s" xga" ENDOF
6686: 0200 OF s" 3d-controller" ENDOF
6687: dup OF s" display" ENDOF
6688: ENDCASE
6689: ;
6690: : pci-class-name-04 ( addr -- str len )
6691: pci-class@ 8 rshift FF and CASE
6692: 00 OF s" video" ENDOF
6693: 01 OF s" sound" ENDOF
6694: 02 OF s" telephony" ENDOF
6695: dup OF s" multimedia-device" ENDOF
6696: ENDCASE
6697: ;
6698: : pci-class-name-05 ( addr -- str len )
6699: pci-class@ 8 rshift FF and CASE
6700: 00 OF s" memory" ENDOF
6701: 01 OF s" flash" ENDOF
6702: dup OF s" memory-controller" ENDOF
6703: ENDCASE
6704: ;
6705: : pci-class-name-06 ( addr -- str len )
6706: pci-class@ 8 rshift FF and CASE
6707: 00 OF s" host" ENDOF
6708: 01 OF s" isa" ENDOF
6709: 02 OF s" eisa" ENDOF
6710: 03 OF s" mca" ENDOF
6711: 04 OF s" pci" ENDOF
6712: 05 OF s" pcmcia" ENDOF
6713: 06 OF s" nubus" ENDOF
6714: 07 OF s" cardbus" ENDOF
6715: 08 OF s" raceway" ENDOF
6716: 09 OF s" semi-transparent-pci" ENDOF
6717: 0A OF s" infiniband" ENDOF
6718: dup OF s" unkown-bridge" ENDOF
6719: ENDCASE
6720: ;
6721: : pci-class-name-07 ( addr -- str len )
6722: pci-class@ FFFF and CASE
6723: 0000 OF s" serial" ENDOF
6724: 0001 OF s" 16450-serial" ENDOF
6725: 0002 OF s" 16550-serial" ENDOF
6726: 0003 OF s" 16650-serial" ENDOF
6727: 0004 OF s" 16750-serial" ENDOF
6728: 0005 OF s" 16850-serial" ENDOF
6729: 0006 OF s" 16950-serial" ENDOF
6730: 0100 OF s" parallel" ENDOF
6731: 0101 OF s" bi-directional-parallel" ENDOF
6732: 0102 OF s" ecp-1.x-parallel" ENDOF
6733: 0103 OF s" ieee1284-controller" ENDOF
6734: 01FE OF s" ieee1284-device" ENDOF
6735: 0200 OF s" multiport-serial" ENDOF
6736: 0300 OF s" modem" ENDOF
6737: 0301 OF s" 16450-modem" ENDOF
6738: 0302 OF s" 16550-modem" ENDOF
6739: 0303 OF s" 16650-modem" ENDOF
6740: 0304 OF s" 16750-modem" ENDOF
6741: 0400 OF s" gpib" ENDOF
6742: 0500 OF s" smart-card" ENDOF
6743: dup OF s" communication-controller" ENDOF
6744: ENDCASE
6745: ;
6746: : pci-class-name-08 ( addr -- str len )
6747: pci-class@ FFFF and CASE
6748: 0000 OF s" interrupt-controller" ENDOF
6749: 0001 OF s" isa-pic" ENDOF
6750: 0002 OF s" eisa-pic" ENDOF
6751: 0010 OF s" io-apic" ENDOF
6752: 0020 OF s" iox-apic" ENDOF
6753: 0100 OF s" dma-controller" ENDOF
6754: 0101 OF s" isa-dma" ENDOF
6755: 0102 OF s" eisa-dma" ENDOF
6756: 0200 OF s" timer" ENDOF
6757: 0201 OF s" isa-system-timer" ENDOF
6758: 0202 OF s" eisa-system-timer" ENDOF
6759: 0300 OF s" rtc" ENDOF
6760: 0301 OF s" isa-rtc" ENDOF
6761: 0400 OF s" hot-plug-controller" ENDOF
6762: 0500 OF s" sd-host-conrtoller" ENDOF
6763: dup OF s" system-periphal" ENDOF
6764: ENDCASE
6765: ;
6766: : pci-class-name-09 ( addr -- str len )
6767: pci-class@ 8 rshift FF and CASE
6768: 00 OF s" keyboard" ENDOF
6769: 01 OF s" pen" ENDOF
6770: 02 OF s" mouse" ENDOF
6771: 03 OF s" scanner" ENDOF
6772: 04 OF s" gameport" ENDOF
6773: dup OF s" input-controller" ENDOF
6774: ENDCASE
6775: ;
6776: : pci-class-name-0A ( addr -- str len )
6777: pci-class@ 8 rshift FF and CASE
6778: 00 OF s" dock" ENDOF
6779: dup OF s" docking-station" ENDOF
6780: ENDCASE
6781: ;
6782: : pci-class-name-0B ( addr -- str len )
6783: pci-class@ 8 rshift FF and CASE
6784: 00 OF s" 386" ENDOF
6785: 01 OF s" 486" ENDOF
6786: 02 OF s" pentium" ENDOF
6787: 10 OF s" alpha" ENDOF
6788: 20 OF s" powerpc" ENDOF
6789: 30 OF s" mips" ENDOF
6790: 40 OF s" co-processor" ENDOF
6791: dup OF s" cpu" ENDOF
6792: ENDCASE
6793: ;
6794: : pci-class-name-0C ( addr -- str len )
6795: pci-class@ FFFF and CASE
6796: 0000 OF s" firewire" ENDOF
6797: 0100 OF s" access-bus" ENDOF
6798: 0200 OF s" ssa" ENDOF
6799: 0300 OF s" usb-uhci" ENDOF
6800: 0310 OF s" usb-ohci" ENDOF
6801: 0320 OF s" usb-ehci" ENDOF
6802: 0380 OF s" usb" ENDOF
6803: 03FE OF s" usb-device" ENDOF
6804: 0400 OF s" fibre-channel" ENDOF
6805: 0500 OF s" smb" ENDOF
6806: 0600 OF s" infiniband" ENDOF
6807: 0700 OF s" ipmi-smic" ENDOF
6808: 0701 OF s" ipmi-kbrd" ENDOF
6809: 0702 OF s" ipmi-bltr" ENDOF
6810: 0800 OF s" sercos" ENDOF
6811: 0900 OF s" canbus" ENDOF
6812: dup OF s" serial-bus" ENDOF
6813: ENDCASE
6814: ;
6815: : pci-class-name-0D ( addr -- str len )
6816: pci-class@ 8 rshift FF and CASE
6817: 00 OF s" irda" ENDOF
6818: 01 OF s" consumer-ir" ENDOF
6819: 10 OF s" rf-controller" ENDOF
6820: 11 OF s" bluetooth" ENDOF
6821: 12 OF s" broadband" ENDOF
6822: 20 OF s" enet-802.11a" ENDOF
6823: 21 OF s" enet-802.11b" ENDOF
6824: dup OF s" wireless-controller" ENDOF
6825: ENDCASE
6826: ;
6827: : pci-class-name-0E ( addr -- str len )
6828: pci-class@ 8 rshift FF and CASE
6829: dup OF s" intelligent-io" ENDOF
6830: ENDCASE
6831: ;
6832: : pci-class-name-0F ( addr -- str len )
6833: pci-class@ 8 rshift FF and CASE
6834: 01 OF s" satelite-tv" ENDOF
6835: 02 OF s" satelite-audio" ENDOF
6836: 03 OF s" satelite-voice" ENDOF
6837: 04 OF s" satelite-data" ENDOF
6838: dup OF s" satelite-devoce" ENDOF
6839: ENDCASE
6840: ;
6841: : pci-class-name-10 ( addr -- str len )
6842: pci-class@ 8 rshift FF and CASE
6843: 00 OF s" network-encryption" ENDOF
6844: 01 OF s" entertainment-encryption" ENDOF
6845: dup OF s" encryption" ENDOF
6846: ENDCASE
6847: ;
6848: : pci-class-name-11 ( addr -- str len )
6849: pci-class@ 8 rshift FF and CASE
6850: 00 OF s" dpio" ENDOF
6851: 01 OF s" counter" ENDOF
6852: 10 OF s" measurement" ENDOF
6853: 20 OF s" managment-card" ENDOF
6854: dup OF s" data-processing-controller" ENDOF
6855: ENDCASE
6856: ;
6857: : pci-class-name ( addr -- str len )
6858: dup pci-class@ 10 rshift CASE
6859: 00 OF pci-class-name-00 ENDOF
6860: 01 OF pci-class-name-01 ENDOF
6861: 02 OF pci-class-name-02 ENDOF
6862: 03 OF pci-class-name-03 ENDOF
6863: 04 OF pci-class-name-04 ENDOF
6864: 05 OF pci-class-name-05 ENDOF
6865: 06 OF pci-class-name-06 ENDOF
6866: 07 OF pci-class-name-07 ENDOF
6867: 08 OF pci-class-name-08 ENDOF
6868: 09 OF pci-class-name-09 ENDOF
6869: 0A OF pci-class-name-0A ENDOF
6870: 0B OF pci-class-name-0B ENDOF
6871: 0C OF pci-class-name-0C ENDOF
6872: 0C OF pci-class-name-0D ENDOF
6873: 0C OF pci-class-name-0E ENDOF
6874: 0C OF pci-class-name-0F ENDOF
6875: 0C OF pci-class-name-10 ENDOF
6876: 0C OF pci-class-name-11 ENDOF
6877: dup OF drop s" unknown" ENDOF
6878: ENDCASE
6879: ;
6880: : pci-bar-size@ ( bar-addr -- bar-size ) -1 over rtas-config-l! rtas-config-l@ ;
6881: : pci-bar-size-mem@ ( bar-addr -- mem-size ) pci-bar-size@ -10 and invert 1+ FFFFFFFF and ;
6882: : pci-bar-size-io@ ( bar-addr -- io-size ) pci-bar-size@ -4 and invert 1+ FFFFFFFF and ;
6883: : pci-bar-size ( bar-addr -- bar-size-raw )
6884: dup rtas-config-l@ swap \ fetch original Value ( bval baddr )
6885: -1 over rtas-config-l! \ make BAR show size ( bval baddr )
6886: dup rtas-config-l@ \ and fetch the size ( bval baddr bsize )
6887: -rot rtas-config-l! \ restore Value
6888: ;
6889: : pci-bar-size-mem32 ( bar-addr -- bar-size )
6890: pci-bar-size \ fetch raw size
6891: -10 and invert 1+ \ calc size
6892: FFFFFFFF and \ keep lower 32 bits
6893: ;
6894: : pci-bar-size-rom ( bar-addr -- bar-size )
6895: pci-bar-size \ fetch raw size
6896: FFFFF800 and invert 1+ \ calc size
6897: FFFFFFFF and \ keep lower 32 bits
6898: ;
6899: : pci-bar-size-mem64 ( bar-addr -- bar-size )
6900: dup pci-bar-size \ fetch raw size lower 32 bits
6901: swap 4 + pci-bar-size \ fetch raw size upper 32 bits
6902: 20 lshift + \ and put them together
6903: -10 and invert 1+ \ calc size
6904: ;
6905: : pci-bar-size-io ( bar-addr -- bar-size )
6906: pci-bar-size \ fetch raw size
6907: -4 and invert 1+ \ calc size
6908: FFFFFFFF and \ keep lower 32 bits
6909: ;
6910: : pci-bar-code@ ( bar-addr -- 0|1..4|5 )
6911: rtas-config-l@ dup \ fetch the BaseAddressRegister
6912: 1 and IF \ IO BAR ?
6913: 2 and IF 0 ELSE 1 THEN \ only '01' is valid
6914: ELSE \ Memory BAR ?
6915: F and CASE
6916: 0 OF 2 ENDOF \ Memory 32 Bit Non-Prefetchable
6917: 8 OF 3 ENDOF \ Memory 32 Bit Prefetchable
6918: 4 OF 4 ENDOF \ Memory 64 Bit Non-Prefetchable
6919: C OF 5 ENDOF \ Memory 64 Bit Prefechtable
6920: dup OF 0 ENDOF \ Not a valid BarType
6921: ENDCASE
6922: THEN
6923: ;
6924: : assign-var ( size var -- al-mem )
6925: 2dup @ \ ( size var size cur-mem ) read current free mem
6926: swap #aligned \ ( size var al-mem ) align the mem to the size
6927: dup 2swap -rot + \ ( al-mem var new-mem ) add size to aligned mem
6928: swap ! \ ( al-mem ) set variable to new mem
6929: ;
6930: : assign-bar-value32 ( bar size var -- 4 )
6931: over IF \ IF size > 0
6932: assign-var \ | ( bar al-mem ) set variable to next mem
6933: swap rtas-config-l! \ | ( -- ) set the bar to al-mem
6934: ELSE \ ELSE
6935: 2drop drop \ | clear stack
6936: THEN \ FI
6937: 4 \ size of the base-address-register
6938: ;
6939: : assign-bar-value64 ( bar size var -- 8 )
6940: over IF \ IF size > 0
6941: assign-var \ | ( bar al-mem ) set variable to next mem
6942: swap \ | ( al-mem addr ) calc config-addr of this bar
6943: 2dup rtas-config-l! \ | ( al-mem addr ) set the Lower part of the bar to al-mem
6944: 4 + swap 20 rshift \ | ( al-mem>>32 addr ) prepare the upper part of the al-mem
6945: swap rtas-config-l! \ | ( -- ) and set the upper part of the bar
6946: ELSE \ ELSE
6947: 2drop drop \ | clear stack
6948: THEN \ FI
6949: 8 \ size of the base-address-register
6950: ;
6951: : assign-mem64-bar ( bar-addr -- 8 )
6952: dup pci-bar-size-mem64 \ fetch size
6953: pci-next-mem \ var to change
6954: assign-bar-value64 \ and set it all
6955: ;
6956: : assign-mem32-bar ( bar-addr -- 4 )
6957: dup pci-bar-size-mem32 \ fetch size
6958: pci-next-mem \ var to change
6959: assign-bar-value32 \ and set it all
6960: ;
6961: : assign-mmio64-bar ( bar-addr -- 8 )
6962: dup pci-bar-size-mem64 \ fetch size
6963: pci-next-mmio \ var to change
6964: assign-bar-value64 \ and set it all
6965: ;
6966: : assign-mmio32-bar ( bar-addr -- 4 )
6967: dup pci-bar-size-mem32 \ fetch size
6968: pci-next-mmio \ var to change
6969: assign-bar-value32 \ and set it all
6970: ;
6971: : assign-io-bar ( bar-addr -- 4 )
6972: dup pci-bar-size-io \ fetch size
6973: pci-next-io \ var to change
6974: assign-bar-value32 \ and set it all
6975: ;
6976: : assign-rom-bar ( bar-addr -- )
6977: dup pci-bar-size-rom \ fetch size
6978: dup IF \ IF size > 0
6979: over >r \ | save bar addr for enable
6980: pci-next-mmio \ | var to change
6981: assign-bar-value32 \ | and set it
6982: drop \ | forget the BAR length
6983: r@ rtas-config-l@ \ | fetch BAR
6984: 1 or r> rtas-config-l! \ | and enable the ROM
6985: ELSE \ ELSE
6986: 2drop \ | clear stack
6987: THEN
6988: ;
6989: : assign-bar ( bar-addr -- reg-size )
6990: dup pci-bar-code@ \ calc BAR type
6991: dup IF \ IF >0
6992: CASE \ | CASE Setup the right type
6993: 1 OF assign-io-bar ENDOF \ | - set up an IO-Bar
6994: 2 OF assign-mmio32-bar ENDOF \ | - set up an 32bit MMIO-Bar
6995: 3 OF assign-mem32-bar ENDOF \ | - set up an 32bit MEM-Bar (prefetchable)
6996: 4 OF assign-mmio64-bar ENDOF \ | - set up an 64bit MMIO-Bar
6997: 5 OF assign-mem64-bar ENDOF \ | - set up an 64bit MEM-Bar (prefetchable)
6998: ENDCASE \ | ESAC
6999: ELSE \ ELSE
7000: ABORT \ | Throw an exception
7001: THEN \ FI
7002: ;
7003: : assign-all-device-bars ( configaddr -- )
7004: 28 10 DO \ BARs start at 10 and end at 27
7005: dup i + \ calc config-addr of the BAR
7006: assign-bar \ and set it up
7007: +LOOP \ add 4 or 8 to the index and loop
7008: 30 + assign-rom-bar \ set up the ROM if available
7009: ;
7010: : assign-all-bridge-bars ( configaddr -- )
7011: 18 10 DO \ BARs start at 10 and end at 17
7012: dup i + \ calc config-addr of the BAR
7013: assign-bar \ and set it up
7014: +LOOP \ add 4 or 8 to the index and loop
7015: 38 + assign-rom-bar \ set up the ROM if available
7016: ;
7017: : gen-mem64-bar-prop ( prop-addr prop-len bar-addr -- prop-addr prop-len 8 )
7018: dup pci-bar-size-mem64 \ fetch BAR Size ( paddr plen baddr bsize )
7019: dup IF \ IF Size > 0
7020: >r dup rtas-config-l@ \ | save size and fetch lower 32 bits ( paddr plen baddr val.lo R: size)
7021: over 4 + rtas-config-l@ \ | fetch upper 32 bits ( paddr plen baddr val.lo val.hi R: size)
7022: 20 lshift + -10 and >r \ | calc 64 bit value and save it ( paddr plen baddr R: size val )
7023: 83000000 or encode-int+ \ | Encode config addr ( paddr plen R: size val )
7024: r> encode-64+ \ | Encode assigned addr ( paddr plen R: size )
7025: r> encode-64+ \ | Encode size ( paddr plen )
7026: ELSE \ ELSE
7027: 2drop \ | don't do anything
7028: THEN \ FI
7029: 8 \ sizeof(BAR) = 8 Bytes
7030: ;
7031: : gen-pmem64-bar-prop ( prop-addr prop-len bar-addr -- prop-addr prop-len 8 )
7032: dup pci-bar-size-mem64 \ fetch BAR Size ( paddr plen baddr bsize )
7033: dup IF \ IF Size > 0
7034: >r dup rtas-config-l@ \ | save size and fetch lower 32 bits ( paddr plen baddr val.lo R: size)
7035: over 4 + rtas-config-l@ \ | fetch upper 32 bits ( paddr plen baddr val.lo val.hi R: size)
7036: 20 lshift + -10 and >r \ | calc 64 bit value and save it ( paddr plen baddr R: size val )
7037: C3000000 or encode-int+ \ | Encode config addr ( paddr plen R: size val )
7038: r> encode-64+ \ | Encode assigned addr ( paddr plen R: size )
7039: r> encode-64+ \ | Encode size ( paddr plen )
7040: ELSE \ ELSE
7041: 2drop \ | don't do anything
7042: THEN \ FI
7043: 8 \ sizeof(BAR) = 8 Bytes
7044: ;
7045: : gen-mem32-bar-prop ( prop-addr prop-len bar-addr -- prop-addr prop-len 4 )
7046: dup pci-bar-size-mem32 \ fetch BAR Size ( paddr plen baddr bsize )
7047: dup IF \ IF Size > 0
7048: >r dup rtas-config-l@ \ | save size and fetch value ( paddr plen baddr val R: size)
7049: -10 and >r \ | calc 32 bit value and save it ( paddr plen baddr R: size val )
7050: 82000000 or encode-int+ \ | Encode config addr ( paddr plen R: size val )
7051: r> encode-64+ \ | Encode assigned addr ( paddr plen R: size )
7052: r> encode-64+ \ | Encode size ( paddr plen )
7053: ELSE \ ELSE
7054: 2drop \ | don't do anything
7055: THEN \ FI
7056: 4 \ sizeof(BAR) = 4 Bytes
7057: ;
7058: : gen-pmem32-bar-prop ( prop-addr prop-len bar-addr -- prop-addr prop-len 4 )
7059: dup pci-bar-size-mem32 \ fetch BAR Size ( paddr plen baddr bsize )
7060: dup IF \ IF Size > 0
7061: >r dup rtas-config-l@ \ | save size and fetch value ( paddr plen baddr val R: size)
7062: -10 and >r \ | calc 32 bit value and save it ( paddr plen baddr R: size val )
7063: C2000000 or encode-int+ \ | Encode config addr ( paddr plen R: size val )
7064: r> encode-64+ \ | Encode assigned addr ( paddr plen R: size )
7065: r> encode-64+ \ | Encode size ( paddr plen )
7066: ELSE \ ELSE
7067: 2drop \ | don't do anything
7068: THEN \ FI
7069: 4 \ sizeof(BAR) = 4 Bytes
7070: ;
7071: : gen-io-bar-prop ( prop-addr prop-len bar-addr -- prop-addr prop-len 4 )
7072: dup pci-bar-size-io \ fetch BAR Size ( paddr plen baddr bsize )
7073: dup IF \ IF Size > 0
7074: >r dup rtas-config-l@ \ | save size and fetch value ( paddr plen baddr val R: size)
7075: -4 and >r \ | calc 32 bit value and save it ( paddr plen baddr R: size val )
7076: 81000000 or encode-int+ \ | Encode config addr ( paddr plen R: size val )
7077: r> encode-64+ \ | Encode assigned addr ( paddr plen R: size )
7078: r> encode-64+ \ | Encode size ( paddr plen )
7079: ELSE \ ELSE
7080: 2drop \ | don't do anything
7081: THEN \ FI
7082: 4 \ sizeof(BAR) = 4 Bytes
7083: ;
7084: : gen-rom-bar-prop ( prop-addr prop-len bar-addr -- prop-addr prop-len )
7085: dup pci-bar-size-rom \ fetch BAR Size ( paddr plen baddr bsize )
7086: dup IF \ IF Size > 0
7087: >r dup rtas-config-l@ \ | save size and fetch value ( paddr plen baddr val R: size)
7088: FFFFF800 and >r \ | calc 32 bit value and save it ( paddr plen baddr R: size val )
7089: 82000000 or encode-int+ \ | Encode config addr ( paddr plen R: size val )
7090: r> encode-64+ \ | Encode assigned addr ( paddr plen R: size )
7091: r> encode-64+ \ | Encode size ( paddr plen )
7092: ELSE \ ELSE
7093: 2drop \ | don't do anything
7094: THEN \ FI
7095: ;
7096: : pci-add-assigned-address ( prop-addr prop-len bar-addr -- prop-addr prop-len bsize )
7097: dup pci-bar-code@ \ calc BAR type ( paddr plen baddr btype)
7098: CASE \ CASE for the BAR types ( paddr plen baddr )
7099: 0 OF drop 4 ENDOF \ - not a valid type so do nothing
7100: 1 OF gen-io-bar-prop ENDOF \ - IO-BAR
7101: 2 OF gen-mem32-bar-prop ENDOF \ - MEM32
7102: 3 OF gen-pmem32-bar-prop ENDOF \ - MEM32 prefetchable
7103: 4 OF gen-mem64-bar-prop ENDOF \ - MEM64
7104: 5 OF gen-pmem64-bar-prop ENDOF \ - MEM64 prefetchable
7105: ENDCASE \ ESAC ( paddr plen bsize )
7106: ;
7107: : pci-device-assigned-addresses-prop ( addr -- )
7108: encode-start \ provide mem for property ( addr paddr plen )
7109: 2 pick 30 + gen-rom-bar-prop \ assign the rom bar
7110: 28 10 DO \ we have 6 possible BARs
7111: 2 pick i + \ calc BAR address ( addr paddr plen bar-addr )
7112: pci-add-assigned-address \ and generate the props for the BAR
7113: +LOOP \ increase Index by returned len
7114: s" assigned-addresses" property drop \ and write it into the device tree
7115: ;
7116: : pci-bridge-assigned-addresses-prop ( addr -- )
7117: encode-start \ provide mem for property
7118: 2 pick 38 + gen-rom-bar-prop \ assign the rom bar
7119: 18 10 DO \ we have 2 possible BARs
7120: 2 pick i + \ ( addr paddr plen current-addr )
7121: pci-add-assigned-address \ and generate the props for the BAR
7122: +LOOP \ increase Index by returned len
7123: s" assigned-addresses" property drop \ and write it into the device tree
7124: ;
7125: : pci-bridge-gen-range ( paddr plen base limit type -- paddr plen )
7126: >r over - \ calc size ( paddr plen base size R:type )
7127: dup 0< IF \ IF Size < 0 ( paddr plen base size R:type )
7128: 2drop r> drop \ | forget values ( paddr plen )
7129: ELSE \ ELSE
7130: 1+ swap 2swap \ | adjust stack ( size base paddr plen R:type )
7131: r@ encode-int+ \ | Child type ( size base paddr plen R:type )
7132: 2 pick encode-64+ \ | Child address ( size base paddr plen R:type )
7133: r> encode-int+ \ | Parent type ( size base paddr plen )
7134: rot encode-64+ \ | Parent address ( size paddr plen )
7135: rot encode-64+ \ | Encode size ( paddr plen )
7136: THEN \ FI
7137: ;
7138: : pci-bridge-gen-mmio-range ( addr prop-addr prop-len -- addr prop-addr prop-len )
7139: 2 pick 20 + rtas-config-l@ \ fetch Value ( addr paddr plen val )
7140: dup 0000FFF0 and 10 lshift \ calc base-address ( addr paddr plen val base )
7141: swap 000FFFFF or \ calc limit-address ( addr paddr plen base limit )
7142: 02000000 pci-bridge-gen-range \ and generate it ( addr paddr plen )
7143: ;
7144: : pci-bridge-gen-mem-range ( addr prop-addr prop-len -- addr prop-addr prop-len )
7145: 2 pick 24 + rtas-config-l@ \ fetch Value ( addr paddr plen val )
7146: dup 000FFFFF or \ calc limit Bits 31:0 ( addr paddr plen val limit.31:0 )
7147: swap 0000FFF0 and 10 lshift \ calc base Bits 31:0 ( addr paddr plen limit.31:0 base.31:0 )
7148: 4 pick 28 + rtas-config-l@ \ fetch upper Basebits ( addr paddr plen limit.31:0 base.31:0 base.63:32 )
7149: 20 lshift or swap \ and calc Base ( addr paddr plen base.63:0 limit.31:0 )
7150: 4 pick 2C + rtas-config-l@ \ fetch upper Limitbits ( addr paddr plen base.63:0 limit.31:0 limit.63:32 )
7151: 20 lshift or \ and calc Limit ( addr paddr plen base.63:0 limit.63:0 )
7152: 42000000 pci-bridge-gen-range \ and generate it ( addr paddr plen )
7153: ;
7154: : pci-bridge-gen-io-range ( addr prop-addr prop-len -- addr prop-addr prop-len )
7155: 2 pick 1C + rtas-config-l@ \ fetch Value ( addr paddr plen val )
7156: dup 0000F000 and 00000FFF or \ calc Limit Bits 15:0 ( addr paddr plen val limit.15:0 )
7157: swap 000000F0 and 8 lshift \ calc Base Bits 15:0 ( addr paddr plen limit.15:0 base.15:0 )
7158: 4 pick 30 + rtas-config-l@ \ fetch upper Bits ( addr paddr plen limit.15:0 base.15:0 val )
7159: dup FFFF and 10 lshift rot or \ calc Base ( addr paddr plen limit.15:0 val base.31:0 )
7160: -rot FFFF0000 and or \ calc Limit ( addr paddr plen base.31:0 limit.31:0 )
7161: 01000000 pci-bridge-gen-range \ and generate it ( addr paddr plen )
7162: ;
7163: : pci-bridge-range-props ( addr -- )
7164: encode-start \ provide mem for property
7165: pci-bridge-gen-mmio-range \ generate the non prefetchable Memory Entry
7166: pci-bridge-gen-mem-range \ generate the prefetchable Memory Entry
7167: pci-bridge-gen-io-range \ generate the IO Entry
7168: dup IF \ IF any space present (propsize>0)
7169: s" ranges" property \ | write it into the device tree
7170: ELSE \ ELSE
7171: 2drop \ | forget the properties
7172: THEN \ FI
7173: drop \ forget the address
7174: ;
7175: : pci-bridge-interrupt-map ( -- )
7176: encode-start \ create the property ( paddr plen )
7177: get-node child \ find the first child ( paddr plen handle )
7178: BEGIN dup WHILE \ Loop as long as the handle is non-zero ( paddr plen handle )
7179: dup >r >space \ Get the my-space ( paddr plen addr R: handle )
7180: pci-gen-irq-entry \ and Encode the interrupt settings ( paddr plen R: handle)
7181: r> peer \ Get neighbour ( paddr plen handle )
7182: REPEAT \ process next childe node ( paddr plen handle )
7183: drop \ forget the null ( paddr plen )
7184: s" interrupt-map" property \ and set it ( -- )
7185: 1 encode-int s" #interrupt-cells" property \ encode the cell#
7186: f800 encode-int 0 encode-int+ 0 encode-int+ \ encode the bit mask for config addr (Dev only)
7187: 7 encode-int+ s" interrupt-map-mask" property \ encode IRQ#=7 and generate property
7188: ;
7189: : encode-mem32-bar ( prop-addr prop-len BAR-addr -- prop-addr prop-len 4 )
7190: dup pci-bar-size-mem32 \ calc BAR-size ( not changing the BAR )
7191: dup IF \ IF BAR-size > 0 ( paddr plen baddr bsize )
7192: >r 02000000 or encode-int+ \ | save size and encode BAR addr
7193: 0 encode-64+ \ | make mid and lo zero
7194: r> encode-64+ \ | encode size
7195: ELSE \ ELSE
7196: 2drop \ | don't do anything
7197: THEN \ FI
7198: 4 \ BAR-Len = 4 (32Bit)
7199: ;
7200: : encode-pmem32-bar ( prop-addr prop-len BAR-addr -- prop-addr prop-len 4 )
7201: dup pci-bar-size-mem32 \ calc BAR-size ( not changing the BAR )
7202: dup IF \ IF BAR-size > 0 ( paddr plen baddr bsize )
7203: >r 42000000 or encode-int+ \ | save size and encode BAR addr
7204: 0 encode-64+ \ | make mid and lo zero
7205: r> encode-64+ \ | encode size
7206: ELSE \ ELSE
7207: 2drop \ | don't do anything
7208: THEN \ FI
7209: 4 \ BAR-Len = 4 (32Bit)
7210: ;
7211: : encode-mem64-bar ( prop-addr prop-len BAR-addr -- prop-addr prop-len 8 )
7212: dup pci-bar-size-mem64 \ calc BAR-size ( not changing the BAR )
7213: dup IF \ IF BAR-size > 0 ( paddr plen baddr bsize )
7214: >r 03000000 or encode-int+ \ | save size and encode BAR addr
7215: 0 encode-64+ \ | make mid and lo zero
7216: r> encode-64+ \ | encode size
7217: ELSE \ ELSE
7218: 2drop \ | don't do anything
7219: THEN \ FI
7220: 8 \ BAR-Len = 8 (64Bit)
7221: ;
7222: : encode-pmem64-bar ( prop-addr prop-len BAR-addr -- prop-addr prop-len 8 )
7223: dup pci-bar-size-mem64 \ calc BAR-size ( not changing the BAR )
7224: dup IF \ IF BAR-size > 0 ( paddr plen baddr bsize )
7225: >r 43000000 or encode-int+ \ | save size and encode BAR addr
7226: 0 encode-64+ \ | make mid and lo zero
7227: r> encode-64+ \ | encode size
7228: ELSE \ ELSE
7229: 2drop \ | don't do anything
7230: THEN \ FI
7231: 8 \ BAR-Len = 8 (64Bit)
7232: ;
7233: : encode-rom-bar ( prop-addr prop-len configaddr -- prop-addr prop-len )
7234: dup pci-bar-size-rom \ fetch raw BAR-size
7235: dup IF \ IF BAR is used
7236: >r 02000000 or encode-int+ \ | save size and encode BAR addr
7237: 0 encode-64+ \ | make mid and lo zero
7238: r> encode-64+ \ | calc and encode the size
7239: ELSE \ ELSE
7240: 2drop \ | don't do anything
7241: THEN \ FI
7242: ;
7243: : encode-io-bar ( prop-addr prop-len BAR-addr BAR-value -- prop-addr prop-len 4 )
7244: dup pci-bar-size-io \ calc BAR-size ( not changing the BAR )
7245: dup IF \ IF BAR-size > 0 ( paddr plen baddr bsize )
7246: >r 01000000 or encode-int+ \ | save size and encode BAR addr
7247: 0 encode-64+ \ | make mid and lo zero
7248: r> encode-64+ \ | encode size
7249: ELSE \ ELSE
7250: 2drop \ | don't do anything
7251: THEN \ FI
7252: 4 \ BAR-Len = 4 (32Bit)
7253: ;
7254: : encode-bar ( prop-addr prop-len bar-addr -- prop-addr prop-len bar-len )
7255: dup pci-bar-code@ \ calc BAR type
7256: CASE \ CASE for the BAR types ( paddr plen baddr val )
7257: 0 OF drop 4 ENDOF \ - not a valid type so do nothing
7258: 1 OF encode-io-bar ENDOF \ - IO-BAR
7259: 2 OF encode-mem32-bar ENDOF \ - MEM32
7260: 3 OF encode-pmem32-bar ENDOF \ - MEM32 prefetchable
7261: 4 OF encode-mem64-bar ENDOF \ - MEM64
7262: 5 OF encode-pmem64-bar ENDOF \ - MEM64 prefetchable
7263: ENDCASE \ ESAC ( paddr plen blen )
7264: ;
7265: : pci-reg-props ( configaddr -- )
7266: dup encode-int \ configuration space ( caddr paddr plen )
7267: 0 encode-64+ \ make the rest 0
7268: 0 encode-64+ \ encode the size as 0
7269: 2 pick pci-htype@ \ fetch Header Type ( caddr paddr plen type )
7270: 1 and IF \ IF Bridge ( caddr paddr plen )
7271: 18 10 DO \ | loop over all BARs
7272: 2 pick i + \ | calc bar-addr ( caddr paddr plen baddr )
7273: encode-bar \ | encode this BAR ( caddr paddr plen blen )
7274: +LOOP \ | increase LoopIndex by the BARlen
7275: 2 pick 38 + \ | calc ROM-BAR for a bridge ( caddr paddr plen baddr )
7276: encode-rom-bar \ | encode the ROM-BAR ( caddr paddr plen )
7277: ELSE \ ELSE ordinary device ( caddr paddr plen )
7278: 28 10 DO \ | loop over all BARs
7279: 2 pick i + \ | calc bar-addr ( caddr paddr plen baddr )
7280: encode-bar \ | encode this BAR ( caddr paddr plen blen )
7281: +LOOP \ | increase LoopIndex by the BARlen
7282: 2 pick 30 + \ | calc ROM-BAR for a device ( caddr paddr plen baddr )
7283: encode-rom-bar \ | encode the ROM-BAR ( caddr paddr plen )
7284: THEN \ FI ( caddr paddr plen )
7285: s" reg" property \ and store it into the property
7286: drop
7287: ;
7288: : pci-common-props ( addr -- )
7289: dup pci-class-name 2dup device-name device-type
7290: dup pci-vendor@ encode-int s" vendor-id" property
7291: dup pci-device@ encode-int s" device-id" property
7292: dup pci-revision@ encode-int s" revision-id" property
7293: dup pci-class@ encode-int s" class-code" property
7294: 3 encode-int s" #address-cells" property
7295: 2 encode-int s" #size-cells" property
7296: dup pci-config-ext? IF 1 encode-int s" ibm,pci-config-space-type" property THEN
7297: dup pci-status@
7298: dup 9 rshift 3 and encode-int s" devsel-speed" property
7299: dup 7 rshift 1 and IF 0 0 s" fast-back-to-back" property THEN
7300: dup 6 rshift 1 and IF 0 0 s" 66mhz-capable" property THEN
7301: 5 rshift 1 and IF 0 0 s" udf-supported" property THEN
7302: dup pci-cache@ ?dup IF encode-int s" cache-line-size" property THEN
7303: pci-interrupt@ ?dup IF encode-int s" interrupts" property THEN
7304: ;
7305: : pci-device-props ( addr -- )
7306: dup pci-common-props
7307: dup pci-min-grant@ encode-int s" min-grant" property
7308: dup pci-max-lat@ encode-int s" max-latency" property
7309: dup pci-sub-device@ ?dup IF encode-int s" subsystem-id" property THEN
7310: dup pci-sub-vendor@ ?dup IF encode-int s" subsystem-vendor-id" property THEN
7311: dup pci-device-assigned-addresses-prop
7312: pci-reg-props
7313: ;
7314: : pci-bridge-props ( addr -- )
7315: dup pci-bus@
7316: encode-int s" primary-bus" property
7317: encode-int s" secondary-bus" property
7318: encode-int s" subordinate-bus" property
7319: dup pci-bus@ drop encode-int rot encode-int+ s" bus-range" property
7320: pci-device-slots encode-int s" slot-names" property
7321: dup pci-bridge-range-props
7322: dup pci-bridge-assigned-addresses-prop
7323: pci-bridge-interrupt-map
7324: pci-reg-props
7325: ;
7326: : assign-bar-mapping ( bar-offset size var -- )
7327: rot my-unit-64 + -rot
7328: assign-bar-value32 drop
7329: ;
7330: : assigned-addresses-property ( -- )
7331: my-unit-64
7332: dup pci-common-props
7333: pci-device-assigned-addresses-prop
7334: ;
7335: : pci-bridge-generic-setup ( addr -- )
7336: pci-device-slots >r \ save the slot array on return stack
7337: dup pci-common-props \ set the common properties before scanning the bus
7338: s" pci" device-type \ the type is allways "pci"
7339: dup pci-bridge-probe \ find all device connected to it
7340: dup assign-all-bridge-bars \ set up all memory access BARs
7341: dup pci-set-irq-line \ set the interrupt pin
7342: dup pci-set-capabilities \ set up the capabilities
7343: pci-bridge-props \ and generate all properties
7344: r> TO pci-device-slots \ and reset the slot array
7345: ;
7346: : pci-device-generic-setup ( config-addr -- )
7347: dup assign-all-device-bars \ calc all BARs
7348: dup pci-set-irq-line \ set the interrupt pin
7349: dup pci-set-capabilities \ set up the capabilities
7350: dup pci-device-props \ and generate all properties
7351: drop \ forget the config-addr
7352: ;
7353: �������� � 8pci-config-bridge.fs : config-b@ puid >r my-puid TO puid my-space + rtas-config-b@ r> TO puid ;
7354: : config-w@ puid >r my-puid TO puid my-space + rtas-config-w@ r> TO puid ;
7355: : config-l@ puid >r my-puid TO puid my-space + rtas-config-l@ r> TO puid ;
7356: : config-b! puid >r my-puid TO puid my-space + rtas-config-b! r> TO puid ;
7357: : config-w! puid >r my-puid TO puid my-space + rtas-config-w! r> TO puid ;
7358: : config-l! puid >r my-puid TO puid my-space + rtas-config-l! r> TO puid ;
7359: : config-dump puid >r my-puid TO puid my-space pci-dump r> TO puid ;
7360: : decode-unit ( addr len -- phys.lo ... phys.hi )
7361: 2 hex-decode-unit \ decode string
7362: B lshift swap \ shift the devicenumber to the right spot
7363: 8 lshift or \ add the functionnumber
7364: my-bus 10 lshift or \ add the busnumber
7365: 0 0 rot \ make phys.lo = 0 = phys.mid
7366: ;
7367: : encode-unit ( phys.lo ... phys.hi -- unit-str unit-len )
7368: nip nip \ forget the both zeros
7369: dup 8 rshift 7 and swap \ calc Functionnumber
7370: B rshift 1F and \ calc Devicenumber
7371: over IF \ IF Function!=0
7372: 2 hex-encode-unit \ | create string with DevNum,FnNum
7373: ELSE \ ELSE
7374: nip 1 hex-encode-unit \ | create string with only DevNum
7375: THEN \ FI
7376: ;
7377: : map-in ( phys.lo ... phys.hi size -- virt )
7378: 2drop drop
7379: ;
7380: : map-out ( virt size -- )
7381: 2drop
7382: ;
7383: : dma-alloc ( ... size -- virt )
7384: alloc-mem
7385: ;
7386: : dma-free ( virt size -- )
7387: free-mem
7388: ;
7389: : dma-map-in ( ... virt size cacheable? -- devaddr )
7390: 2drop
7391: ;
7392: : dma-map-out ( virt devaddr size -- )
7393: 2drop drop
7394: ;
7395: : dma-sync ( virt devaddr size -- )
7396: 2drop drop
7397: ;
7398: : open true ;
7399: : close ;
7400: �������� � � 0update_flash.fs false value flash-new
7401: : update-flash-help ( -- )
7402: cr ." update-flash tool to flash host FW " cr
7403: ." -f <filename> : Flash from file (e.g. net:\boot_rom.bin)" cr
7404: ." -l : Flash from load-base" cr
7405: ." -d : Flash from old load base (used by drone)" cr
7406: ." -c : Flash from temp to perm" cr
7407: ." -r : Flash from perm to temp" cr
7408: ;
7409: : flash-read-temp ( -- success? )
7410: get-flashside 1 = IF flash-addr load-base over flash-image-size rmove true
7411: ELSE
7412: false
7413: THEN
7414: ;
7415: : flash-read-perm ( -- success? )
7416: get-flashside 0= IF
7417: flash-addr load-base over flash-image-size rmove true
7418: ELSE
7419: false
7420: THEN
7421: ;
7422: : flash-switch-side ( side -- success? )
7423: set-flashside 0<> IF
7424: s" Cannot change flashside" type cr false
7425: ELSE
7426: true
7427: THEN
7428: ;
7429: : flash-ensure-temp ( -- success? )
7430: get-flashside 0= IF
7431: cr ." Cannot flash perm! Switching to temp side!"
7432: 1 flash-switch-side
7433: ELSE
7434: true
7435: THEN
7436: ;
7437: : update-flash ( "text" )
7438: get-flashside >r \ Save old flashside
7439: parse-word ( str len ) \ Parse first string
7440: drop dup c@ ( str first-char )
7441: [char] - <> IF
7442: update-flash-help r> 2drop EXIT
7443: THEN
7444: 1+ c@ ( second-char )
7445: CASE
7446: [char] f OF
7447: parse-word cr s" do-load" evaluate
7448: flash-ensure-temp TO flash-new
7449: ENDOF
7450: [char] l OF
7451: flash-ensure-temp
7452: ENDOF
7453: [char] d OF
7454: flash-load-base load-base 200000 move
7455: flash-ensure-temp
7456: ENDOF
7457: [char] c OF
7458: flash-read-temp 0= flash-new or IF
7459: ." Cannot commit temp, need to boot on temp first " cr false
7460: ELSE
7461: 0 flash-switch-side
7462: THEN
7463: ENDOF
7464: [char] r OF
7465: flash-read-perm 0= IF
7466: ." Cannot commit perm, need to boot on perm first " cr false
7467: ELSE
7468: 1 flash-switch-side
7469: THEN
7470: ENDOF
7471: dup OF
7472: false
7473: ENDOF
7474: ENDCASE
7475: 0= IF
7476: update-flash-help r> drop EXIT
7477: THEN
7478: load-base flash-write 0= IF ." Flash write failed !! " cr THEN
7479: r> set-flashside drop \ Restore old flashside
7480: ;
7481: �������� 0 � 0xmodem.fs 01 CONSTANT XM-SOH \ Start of header
7482: 04 CONSTANT XM-EOT \ End-of-transmission
7483: 06 CONSTANT XM-ACK \ Acknowledge
7484: 15 CONSTANT XM-NAK \ Neg. acknowledge
7485: 0 VALUE xm-retries \ Retry count
7486: 0 VALUE xm-block#
7487: : xmodem-get-byte ( timeout -- byte|-1 )
7488: d# 1000 *
7489: 0 DO
7490: key? IF key UNLOOP EXIT THEN
7491: 1 ms
7492: LOOP
7493: -1
7494: ;
7495: : xmodem-rx-packet ( address -- success? )
7496: 1 xmodem-get-byte \ Get block number
7497: dup 0 < IF
7498: 2drop false EXIT \ Timeout
7499: THEN
7500: 1 xmodem-get-byte \ Get neg. block number
7501: dup 0 < IF
7502: 3drop false EXIT \ Timeout
7503: THEN
7504: rot 0 ( blk# ~blk# address chksum )
7505: 80 0 DO
7506: 1 xmodem-get-byte dup 0 < IF ( blk# ~blk# address chksum byte )
7507: 3drop 2drop UNLOOP FALSE EXIT
7508: THEN
7509: dup 3 pick c! ( blk# ~blk# address chksum byte )
7510: + swap 1+ swap ( blk# ~blk# address+1 chksum' )
7511: LOOP
7512: 0ff and
7513: 1 xmodem-get-byte <> IF
7514: 3drop FALSE EXIT
7515: THEN
7516: drop ( blk# ~blk# )
7517: over xm-block# <> IF
7518: 2drop FALSE EXIT
7519: THEN ( blk# ~blk# )
7520: ff xor =
7521: ;
7522: : (xmodem-load) ( address -- bytes )
7523: 1 to xm-block#
7524: 0 to xm-retries
7525: dup
7526: BEGIN
7527: d# 10 xmodem-get-byte dup >r
7528: CASE
7529: XM-SOH OF
7530: dup xmodem-rx-packet IF
7531: XM-ACK emit
7532: 80 + ( start-addr next-addr R: rx-byte )
7533: 0 to xm-retries \ Reset retry count
7534: xm-block# 1+ ff and to xm-block# \ Increase current block#
7535: ELSE
7536: XM-NAK emit
7537: xm-retries 1+ to xm-retries \ Increase retry count
7538: THEN
7539: ENDOF
7540: XM-EOT OF
7541: XM-ACK emit
7542: ENDOF
7543: dup OF
7544: XM-NAK emit
7545: xm-retries 1+ to xm-retries \ Increase retry count
7546: ENDOF
7547: ENDCASE
7548: r> XM-EOT =
7549: xm-retries d# 10 >= OR
7550: UNTIL ( start-address end-address )
7551: swap - ( bytes received )
7552: ;
7553: : xmodem-load ( -- bytes )
7554: cr ." Waiting for start of XMODEM upload..." cr
7555: load-base (xmodem-load)
7556: ;
7557: �������� @ 8default-font.bin (( $$~$$~$$ *((
7558:
7559: * 0H0 0@ 8DD@"THT" |( | | 00 @ 8DDDDDDDD8 8DD @x 8DD8 @@@HH~ ~@@@xx @@@xDDD8 ~B 8DDD8DDDD8 8DDD<D8 00 00 00 00 @ @@ ~ ~ " $BNRN@@$ $$$~BBBB |BBB||BBB| <"`@@@@`"< xDBBBBBBDx ~@@@~~@@@~ ~@@@~~@@@@ <B@@@@NBB< BBBB~~BBBB << $ BDHP``PHDB @@@@@@@@@~ Bf~ZBBBBBB BbbRRJJFFB $BBBBBB$ pHDDHp@@@@ $BBBBBJ$ pHDDHpPHDB @@ ~ ~ BBBBBBBBB< BBBBB$$$$ BBBBBBBZfB BB$$$$BB BB$$ ~B B~ 0 0 @ <fB ~ 8D<D: @@@@XdDDdX 8D@@D8 <LDDL< 8Dx@D8 8 4LDL4D8 @@@XdDDDDD H0 @@@DHPpHDB 08 T****j X$$$$v """" XdDdX@@@ 4LDL4 xD@@@@ $$ 8 $$$$$ DDD(( ***** DD((D "" < < $TH DDD(( �������� h 3 (core.fs : ?offset16 ( -- true|false )
7560: fcode-offset 16 =
7561: ;
7562: : ?arch64 ( -- true|false )
7563: cell 8 =
7564: ;
7565: : ?bigendian ( -- true|false )
7566: deadbeef fcode-num !
7567: fcode-num ?arch64 IF 4 + THEN
7568: c@ de =
7569: ;
7570: : reset-fcode-end ( -- )
7571: false fcode-end !
7572: ;
7573: : get-ip ( -- n )
7574: ip @
7575: ;
7576: : set-ip ( n -- )
7577: ip !
7578: ;
7579: : next-ip ( -- )
7580: get-ip 1+ set-ip
7581: ;
7582: : jump-n-ip ( n -- )
7583: get-ip + set-ip
7584: ;
7585: : read-byte ( -- n )
7586: get-ip fcode-rb@
7587: ;
7588: : ?compile-mode ( -- on|off )
7589: state @
7590: ;
7591: : save-evaluator-state
7592: get-ip eva-debug? IF ." saved ip " dup . cr THEN
7593: fcode-end @ eva-debug? IF ." saved fcode-end " dup . cr THEN
7594: fcode-offset eva-debug? IF ." saved fcode-offset " dup . cr THEN
7595: fcode-spread eva-debug? IF ." saved fcode-spread " dup . cr THEN
7596: ['] fcode@ behavior eva-debug? IF ." saved fcode@ " dup . cr THEN
7597: ;
7598: : restore-evaluator-state
7599: eva-debug? IF ." restored fcode@ " dup . cr THEN to fcode@
7600: eva-debug? IF ." restored fcode-spread " dup . cr THEN to fcode-spread
7601: eva-debug? IF ." restored fcode-offset " dup . cr THEN to fcode-offset
7602: eva-debug? IF ." restored fcode-end " dup . cr THEN fcode-end !
7603: eva-debug? IF ." restored ip " dup . cr THEN set-ip
7604: ;
7605: : token-table-index ( fcode# -- addr )
7606: cells token-table +
7607: ;
7608: : join-immediate ( xt immediate? addr -- xt+immediate? addr )
7609: -rot + swap
7610: ;
7611: : split-immediate ( xt+immediate? -- xt immediate? )
7612: dup 1 and 2dup - rot drop swap
7613: ;
7614: : literal, ( n -- )
7615: postpone literal
7616: ;
7617: : fc-string,
7618: postpone sliteral
7619: dup c, bounds ?do i c@ c, loop
7620: ;
7621: : set-token ( xt immediate? fcode# -- )
7622: token-table-index join-immediate !
7623: ;
7624: : get-token ( fcode# -- xt immediate? )
7625: token-table-index @ split-immediate
7626: ;
7627: -1 VALUE break-fcode-addr
7628: : exec ( FCode# -- )
7629: eva-debug? IF
7630: dup
7631: get-ip 8 u.r ." : "
7632: ." [" 3 u.r ." ] "
7633: THEN
7634: get-ip break-fcode-addr = IF
7635: TRUE fcode-end ! drop EXIT
7636: THEN
7637: get-token 0= IF \ imm == 0 == false
7638: ?compile-mode IF
7639: compile,
7640: ELSE
7641: eva-debug? IF dup xt>name type space THEN
7642: execute
7643: THEN
7644: ELSE \ immediate
7645: eva-debug? IF dup xt>name type space THEN
7646: execute
7647: THEN
7648: eva-debug? IF .s cr THEN
7649: ;
7650: 0 ?bigendian INCLUDE? big.fs
7651: 0 ?bigendian NOT INCLUDE? little.fs
7652: : read-fcode# ( -- FCode# )
7653: read-byte
7654: dup 01 0F between IF drop read-fcode-num16 THEN
7655: ;
7656: : read-header ( adr -- )
7657: next-ip read-byte drop
7658: next-ip read-fcode-num16 drop
7659: next-ip read-fcode-num32 drop
7660: ;
7661: : read-fcode-string ( -- str len )
7662: read-byte \ get string length ( -- len )
7663: next-ip get-ip \ get string addr ( -- len str )
7664: swap \ type needs the parameters swapped ( -- str len )
7665: dup 1- jump-n-ip \ jump to the end of the string in FCode
7666: ;
7667: : evaluate-fcode ( -- )
7668: fcode@ exec \ read start code
7669: BEGIN
7670: next-ip fcode@ exec
7671: fcode-end @
7672: UNTIL
7673: ;
7674: : step-fcode ( -- )
7675: break-fcode-addr >r -1 to break-fcode-addr
7676: fcode@ exec next-ip
7677: r> to break-fcode-addr
7678: ;
7679: �������� � 0evaluator.fs hex
7680: -1 constant true
7681: 0 constant false
7682: variable ip
7683: variable fcode-end
7684: variable fcode-num
7685: 1 value fcode-spread
7686: 16 value fcode-offset
7687: false value eva-debug?
7688: false value fcode-debug?
7689: defer fcode-rb@
7690: defer fcode@
7691: ' c@ to fcode-rb@
7692: create token-table 2000 cells allot \ 1000h = 4096d
7693: include core.fs
7694: include 1275.fs
7695: include tokens.fs
7696: 0 value buff
7697: 0 value buff-size
7698: ' read-fcode# to fcode@
7699: : step next-ip fcode@ exec ; immediate
7700: : rom-code-ignored ( image# name len -- )
7701: diagnostic-mode? IF type ." code found in image " . ." , ignoring ..." cr
7702: ELSE 3drop THEN
7703: ;
7704: : pci-find-rom ( baseaddr -- addr )
7705: -8 and dup IF
7706: dup rw@ 55aa = IF
7707: diagnostic-mode? IF ." Device ROM found at " dup . cr THEN
7708: ELSE drop 0 THEN
7709: THEN
7710: ;
7711: : pci-find-fcode ( baseaddr -- addr len | false )
7712: pci-find-rom ?dup IF
7713: dup 18 + rw@ wbflip +
7714: 0 swap BEGIN
7715: dup rl@ 50434952 ( 'PCIR') <> IF
7716: diagnostic-mode? IF
7717: ." Invalid PCI Data structure, ignoring ROM contents" cr
7718: THEN
7719: 2drop false EXIT
7720: THEN
7721: dup 14 + rb@ CASE
7722: 0 OF over . s" Intel x86 BIOS" rom-code-ignored ENDOF
7723: 1 OF swap diagnostic-mode? IF
7724: ." Open Firmware FCode found at image " . cr
7725: ELSE drop THEN
7726: dup a + rw@ wbflip over + \ This code start
7727: swap 10 + rw@ wbflip 200 * \ This code length
7728: EXIT
7729: ENDOF
7730: 2 OF over . s" HP PA RISC" rom-code-ignored ENDOF
7731: 3 OF over . s" EFI" rom-code-ignored ENDOF
7732: dup OF over . s" Unknown type" rom-code-ignored ENDOF
7733: ENDCASE
7734: dup 15 + rb@ 80 and IF 2drop EXIT THEN \ End of last image
7735: dup 10 + rw@ wbflip 200 * + \ Next image start
7736: swap 1+ swap \ Next image #
7737: 0 UNTIL
7738: THEN false
7739: ;
7740: : execute-rom-fcode ( addr len | false -- )
7741: ?dup IF
7742: diagnostic-mode? IF ." , executing ..." cr THEN
7743: dup >r r@ alloc-mem dup >r swap rmove
7744: r@ set-ip evaluate-fcode
7745: diagnostic-mode? IF ." Done." cr THEN
7746: r> r> free-mem
7747: THEN
7748: ;
7749: �������� P (big.fs : read-fcode-num16 ( -- n )
7750: 0 fcode-num !
7751: ?arch64 IF
7752: read-byte fcode-num 6 + C!
7753: next-ip read-byte fcode-num 7 + C!
7754: ELSE
7755: read-byte fcode-num 2 + C!
7756: next-ip read-byte fcode-num 3 + C!
7757: THEN
7758: fcode-num @
7759: ;
7760: : read-fcode-num32 ( -- n )
7761: 0 fcode-num !
7762: ?arch64 IF
7763: read-byte fcode-num 4 + C!
7764: next-ip read-byte fcode-num 5 + C!
7765: next-ip read-byte fcode-num 6 + C!
7766: next-ip read-byte fcode-num 7 + C!
7767: ELSE
7768: read-byte fcode-num 0 + C!
7769: next-ip read-byte fcode-num 1 + C!
7770: next-ip read-byte fcode-num 2 + C!
7771: next-ip read-byte fcode-num 3 + C!
7772: THEN
7773: fcode-num @
7774: ;
7775: �������� +` +! 0tokens.fs : fc-abort ." FCode called abort: IP " get-ip . ( ." STACK: " .s ) depth dup 0< IF abort THEN . rdepth . cr abort ;
7776: : fc-0 ." 0(lit): STACK ( S: " depth . ." R: " rdepth . ." ): " depth 0> IF .s THEN 0 ;
7777: : fc-1 ." 1(lit): STACK ( S: " depth . ." R: " rdepth . ." ): " depth 0> IF .s THEN 1 ;
7778: : parse-1hex 1 hex-decode-unit ;
7779: : reset-token-table
7780: FFF 0 DO ['] ferror 0 i set-token LOOP
7781: ;
7782: reset-token-table
7783: ' end0 0 00 set-token
7784: ' b(lit) 1 10 set-token
7785: ' b(') 1 11 set-token
7786: ' b(") 1 12 set-token
7787: ' bbranch 1 13 set-token
7788: ' b?branch 1 14 set-token
7789: ' b(loop) 1 15 set-token
7790: ' b(+loop) 1 16 set-token
7791: ' b(do) 1 17 set-token
7792: ' b(?do) 1 18 set-token
7793: ' i 0 19 set-token
7794: ' j 0 1A set-token
7795: ' b(leave) 1 1B set-token
7796: ' b(of) 1 1C set-token
7797: ' execute 0 1D set-token
7798: ' + 0 1E set-token
7799: ' - 0 1F set-token
7800: ' * 0 20 set-token
7801: ' / 0 21 set-token
7802: ' mod 0 22 set-token
7803: ' and 0 23 set-token
7804: ' or 0 24 set-token
7805: ' xor 0 25 set-token
7806: ' invert 0 26 set-token
7807: ' lshift 0 27 set-token
7808: ' rshift 0 28 set-token
7809: ' >>a 0 29 set-token
7810: ' /mod 0 2A set-token
7811: ' u/mod 0 2B set-token
7812: ' negate 0 2C set-token
7813: ' abs 0 2D set-token
7814: ' min 0 2E set-token
7815: ' max 0 2F set-token
7816: ' >r 0 30 set-token
7817: ' r> 0 31 set-token
7818: ' r@ 0 32 set-token
7819: ' exit 0 33 set-token
7820: ' 0= 0 34 set-token
7821: ' 0<> 0 35 set-token
7822: ' 0< 0 36 set-token
7823: ' 0<= 0 37 set-token
7824: ' 0> 0 38 set-token
7825: ' 0>= 0 39 set-token
7826: ' < 0 3A set-token
7827: ' > 0 3B set-token
7828: ' = 0 3C set-token
7829: ' <> 0 3D set-token
7830: ' u> 0 3E set-token
7831: ' u<= 0 3F set-token
7832: ' u< 0 40 set-token
7833: ' u>= 0 41 set-token
7834: ' >= 0 42 set-token
7835: ' <= 0 43 set-token
7836: ' between 0 44 set-token
7837: ' within 0 45 set-token
7838: ' DROP 0 46 set-token
7839: ' DUP 0 47 set-token
7840: ' OVER 0 48 set-token
7841: ' SWAP 0 49 set-token
7842: ' ROT 0 4A set-token
7843: ' -ROT 0 4B set-token
7844: ' TUCK 0 4C set-token
7845: ' nip 0 4D set-token
7846: ' pick 0 4E set-token
7847: ' roll 0 4F set-token
7848: ' ?dup 0 50 set-token
7849: ' depth 0 51 set-token
7850: ' 2drop 0 52 set-token
7851: ' 2dup 0 53 set-token
7852: ' 2over 0 54 set-token
7853: ' 2swap 0 55 set-token
7854: ' 2rot 0 56 set-token
7855: ' 2/ 0 57 set-token
7856: ' u2/ 0 58 set-token
7857: ' 2* 0 59 set-token
7858: ' /c 0 5A set-token
7859: ' /w 0 5B set-token
7860: ' /l 0 5C set-token
7861: ' /n 0 5D set-token
7862: ' ca+ 0 5E set-token
7863: ' wa+ 0 5F set-token
7864: ' la+ 0 60 set-token
7865: ' na+ 0 61 set-token
7866: ' char+ 0 62 set-token
7867: ' wa1+ 0 63 set-token
7868: ' la1+ 0 64 set-token
7869: ' cell+ 0 65 set-token
7870: ' chars 0 66 set-token
7871: ' /w* 0 67 set-token
7872: ' /l* 0 68 set-token
7873: ' cells 0 69 set-token
7874: ' on 0 6A set-token
7875: ' off 0 6B set-token
7876: ' +! 0 6C set-token
7877: ' @ 0 6D set-token
7878: ' l@ 0 6E set-token
7879: ' w@ 0 6F set-token
7880: ' <w@ 0 70 set-token
7881: ' c@ 0 71 set-token
7882: ' ! 0 72 set-token
7883: ' l! 0 73 set-token
7884: ' w! 0 74 set-token
7885: ' c! 0 75 set-token
7886: ' 2@ 0 76 set-token
7887: ' 2! 0 77 set-token
7888: ' move 0 78 set-token
7889: ' fill 0 79 set-token
7890: ' comp 0 7A set-token
7891: ' noop 0 7B set-token
7892: ' lwsplit 0 7C set-token
7893: ' wljoin 0 7D set-token
7894: ' lbsplit 0 7E set-token
7895: ' bljoin 0 7F set-token
7896: ' wbflip 0 80 set-token
7897: ' upc 0 81 set-token
7898: ' lcc 0 82 set-token
7899: ' pack 0 83 set-token
7900: ' count 0 84 set-token
7901: ' body> 0 85 set-token
7902: ' >body 0 86 set-token
7903: ' fcode-revision 0 87 set-token
7904: ' span 0 88 set-token
7905: ' unloop 0 89 set-token
7906: ' expect 0 8A set-token
7907: ' alloc-mem 0 8B set-token \ alloc-mem
7908: ' free-mem 0 8C set-token \ free-mem
7909: ' key? 0 8D set-token
7910: ' key 0 8E set-token
7911: ' emit 0 8F set-token
7912: ' type 0 90 set-token
7913: ' cr 0 91 set-token \ should be (cr but terminal support is not
7914: ' cr 0 92 set-token
7915: ' hold 0 95 set-token
7916: ' <# 0 96 set-token
7917: ' u#> 0 97 set-token
7918: ' sign 0 98 set-token
7919: ' u# 0 99 set-token
7920: ' u#s 0 9A set-token
7921: ' u. 0 9B set-token
7922: ' u.r 0 9C set-token
7923: ' . 0 9D set-token
7924: ' .r 0 9E set-token
7925: ' .s 0 9F set-token
7926: ' base 0 A0 set-token
7927: ' $number 0 A2 set-token
7928: ' digit 0 A3 set-token
7929: ' -1 0 A4 set-token
7930: ' 0 0 A5 set-token
7931: ' 1 0 A6 set-token
7932: ' 2 0 A7 set-token
7933: ' 3 0 A8 set-token
7934: ' bl 0 A9 set-token
7935: ' bs 0 AA set-token
7936: ' bell 0 AB set-token
7937: ' bounds 0 AC set-token
7938: ' here 0 AD set-token
7939: ' aligned 0 AE set-token
7940: ' wbsplit 0 AF set-token
7941: ' bwjoin 0 B0 set-token
7942: ' b(<mark) 1 B1 set-token
7943: ' b(>resolve) 1 B2 set-token
7944: ' new-token 0 B5 set-token
7945: ' named-token 0 B6 set-token
7946: ' b(:) 1 B7 set-token
7947: ' b(value) 1 B8 set-token
7948: ' b(variable) 1 B9 set-token
7949: ' b(constant) 1 BA set-token
7950: ' b(create) 1 BB set-token
7951: ' b(defer) 1 BC set-token
7952: ' b(buffer:) 1 BD set-token
7953: ' b(field) 1 BE set-token
7954: ' INSTANCE 0 C0 set-token
7955: ' b(;) 1 C2 set-token
7956: ' b(to) 1 C3 set-token
7957: ' b(case) 1 C4 set-token
7958: ' b(endcase) 1 C5 set-token
7959: ' b(endof) 1 C6 set-token
7960: ' # 0 C7 set-token
7961: ' #s 0 C8 set-token
7962: ' #> 0 C9 set-token
7963: ' external-token 0 CA set-token
7964: ' $find 0 CB set-token
7965: ' offset16 0 CC set-token
7966: ' evaluate 0 CD set-token
7967: ' c, 0 D0 set-token
7968: ' w, 0 D1 set-token
7969: ' l, 0 D2 set-token
7970: ' , 0 D3 set-token
7971: ' um* 0 D4 set-token
7972: ' um/mod 0 D5 set-token
7973: ' d+ 0 D8 set-token
7974: ' d- 0 D9 set-token
7975: ' get-token 0 DA set-token
7976: ' set-token 0 DB set-token
7977: ' state 0 DC set-token \ possibly broken
7978: ' compile, 0 DD set-token
7979: ' behavior 0 DE set-token
7980: ' start0 0 F0 set-token
7981: ' start1 0 F1 set-token
7982: ' start2 0 F2 set-token
7983: ' start4 0 F3 set-token
7984: ' ferror 0 FC set-token
7985: ' version1 0 FD set-token
7986: ' end1 0 FF set-token
7987: ' my-address 0 102 set-token
7988: ' my-space 0 103 set-token
7989: ' property 0 110 set-token
7990: ' encode-int 0 111 set-token
7991: ' encode+ 0 112 set-token
7992: ' encode-phys 0 113 set-token
7993: ' encode-string 0 114 set-token
7994: ' encode-bytes 0 115 set-token
7995: ' reg 0 116 set-token
7996: ' model 0 119 set-token
7997: ' device-type 0 11A set-token
7998: ' parse-2int 0 11B set-token
7999: ' is-install 0 11C set-token
8000: ' is-remove 0 11D set-token
8001: ' is-selftest 0 11E set-token
8002: ' new-device 0 11F set-token
8003: ' diagnostic-mode? 0 120 set-token
8004: ' memory-test-suite 0 122 set-token
8005: ' mask 0 124 set-token
8006: ' get-msecs 0 125 set-token
8007: ' ms 0 126 set-token
8008: ' finish-device 0 127 set-token
8009: ' decode-phys 0 128 set-token
8010: ' #lines 0 150 set-token
8011: ' #columns 0 151 set-token
8012: ' line# 0 152 set-token
8013: ' column# 0 153 set-token
8014: ' inverse? 0 154 set-token
8015: ' inverse-screen? 0 155 set-token
8016: ' draw-character 0 157 set-token
8017: ' reset-screen 0 158 set-token
8018: ' toggle-cursor 0 159 set-token
8019: ' erase-screen 0 15A set-token
8020: ' blink-screen 0 15B set-token
8021: ' invert-screen 0 15C set-token
8022: ' insert-characters 0 15D set-token
8023: ' delete-characters 0 15E set-token
8024: ' insert-lines 0 15F set-token
8025: ' delete-lines 0 160 set-token
8026: ' draw-logo 0 161 set-token
8027: ' frame-buffer-adr 0 162 set-token
8028: ' screen-height 0 163 set-token
8029: ' screen-width 0 164 set-token
8030: ' window-top 0 165 set-token
8031: ' window-left 0 166 set-token
8032: ' default-font 0 16A set-token
8033: ' set-font 0 16B set-token
8034: ' char-height 0 16C set-token
8035: ' char-width 0 16D set-token
8036: ' >font 0 16E set-token
8037: ' fontbytes 0 16F set-token
8038: ' fb8-install 0 18B set-token
8039: ' device-name 0 201 set-token
8040: ' my-args 0 202 set-token
8041: ' my-self 0 203 set-token
8042: ' find-package 0 204 set-token
8043: ' open-package 0 205 set-token
8044: ' close-package 0 206 set-token
8045: ' find-method 0 207 set-token
8046: ' call-package 0 208 set-token
8047: ' $call-parent 0 209 set-token
8048: ' my-parent 0 20A set-token
8049: ' ihandle>phandle 0 20B set-token
8050: ' my-unit 0 20D set-token
8051: ' $call-method 0 20E set-token
8052: ' $open-package 0 20F set-token
8053: ' (is-user-word) 0 214 set-token
8054: ' suspend-fcode 0 215 set-token
8055: ' fc-abort 0 216 set-token
8056: ' catch 0 217 set-token
8057: ' throw 0 218 set-token
8058: ' get-my-property 0 21A set-token
8059: ' decode-int 0 21B set-token
8060: ' decode-string 0 21C set-token
8061: ' get-inherited-property 0 21D set-token
8062: ' delete-property 0 21E set-token
8063: ' get-package-property 0 21F set-token
8064: ' cpeek 0 220 set-token
8065: ' wpeek 0 221 set-token
8066: ' lpeek 0 222 set-token
8067: ' cpoke 0 223 set-token
8068: ' wpoke 0 224 set-token
8069: ' lpoke 0 225 set-token
8070: ' lwflip 0 226 set-token
8071: ' lbflip 0 227 set-token
8072: ' lbflips 0 228 set-token
8073: ' rx@ 0 22E set-token
8074: ' rx! 0 22F set-token
8075: ' rb@ 0 230 set-token
8076: ' rb! 0 231 set-token
8077: ' rw@ 0 232 set-token
8078: ' rw! 0 233 set-token
8079: ' rl@ 0 234 set-token
8080: ' rl! 0 235 set-token
8081: ' wbflips 0 236 set-token
8082: ' lwflips 0 237 set-token
8083: ' child 0 23B set-token
8084: ' peer 0 23C set-token
8085: ' next-property 0 23D set-token
8086: ' byte-load 0 23E set-token
8087: ' set-args 0 23F set-token
8088: ' left-parse-string 0 240 set-token
8089: ' bxjoin 0 241 set-token
8090: ' <l@ 0 242 set-token
8091: ' lxjoin 0 243 set-token
8092: ' wxjoin 0 244 set-token
8093: ' x, 0 245 set-token
8094: ' x@ 0 246 set-token
8095: ' x! 0 247 set-token
8096: ' /x 0 248 set-token
8097: ' /x* 0 249 set-token
8098: ' xa+ 0 24A set-token
8099: ' xa1+ 0 24B set-token
8100: ' xbflip 0 24C set-token
8101: ' xbflips 0 24D set-token
8102: ' xbsplit 0 24E set-token
8103: ' xlflip 0 24F set-token
8104: ' xlflips 0 250 set-token
8105: ' xlsplit 0 251 set-token
8106: ' xwflip 0 252 set-token
8107: ' xwflips 0 253 set-token
8108: ' xwsplit 0 254 set-token
8109: �������� � � (1275.fs 0 value function-type ' function-type @ constant <value>
8110: variable function-type ' function-type @ constant <variable>
8111: 0 constant function-type ' function-type @ constant <constant>
8112: : function-type ; ' function-type @ constant <colon>
8113: create function-type ' function-type @ constant <create>
8114: defer function-type ' function-type @ constant <defer>
8115: : fcode-revision ( -- n )
8116: 00030000 \ major * 65536 + minor
8117: ;
8118: : b(lit) ( -- n )
8119: next-ip read-fcode-num32
8120: ?compile-mode IF literal, THEN
8121: ;
8122: : b(")
8123: next-ip read-fcode-string
8124: ?compile-mode IF fc-string, align postpone count THEN
8125: ;
8126: : b(')
8127: next-ip read-fcode# get-token drop ?compile-mode IF literal, THEN
8128: ;
8129: : ?jump-direction ( n -- )
8130: dup 8000 >= IF FFFF swap - negate 2- THEN
8131: ;
8132: : ?negative
8133: 8000 and
8134: ;
8135: : dest-on-top
8136: 0 >r BEGIN dup @ 0= WHILE >r REPEAT
8137: BEGIN r> dup WHILE swap REPEAT
8138: drop
8139: ;
8140: : ?branch
8141: true =
8142: ;
8143: : read-fcode-offset \ ELSE needs to be fixed!
8144: ?offset16 IF next-ip read-fcode-num16 ELSE THEN
8145: ;
8146: : b?branch ( flag -- )
8147: ?compile-mode IF
8148: read-fcode-offset ?negative IF dest-on-top postpone until
8149: ELSE postpone if
8150: THEN
8151: ELSE
8152: ?branch IF 2 jump-n-ip
8153: ELSE read-fcode-offset
8154: ?jump-direction 2- jump-n-ip
8155: THEN
8156: THEN
8157: ; immediate
8158: : bbranch ( -- )
8159: ?compile-mode IF
8160: read-fcode-offset
8161: ?negative IF dest-on-top postpone again
8162: ELSE postpone else
8163: get-ip next-ip fcode@ B2 = IF drop ELSE set-ip THEN
8164: THEN
8165: ELSE
8166: read-fcode-offset ?jump-direction 2- jump-n-ip
8167: THEN
8168: ; immediate
8169: : b(<mark) ( -- )
8170: ?compile-mode IF postpone begin THEN
8171: ; immediate
8172: : b(>resolve) ( -- )
8173: ?compile-mode IF postpone then THEN
8174: ; immediate
8175: : ffwto; ( -- )
8176: BEGIN fcode@ dup c2 <> WHILE
8177: ." ffwto: skipping " dup . ." @ " get-ip . cr
8178: CASE 10 OF ( lit ) read-fcode-num32 drop ENDOF
8179: 11 OF ( ' ) read-fcode# drop ENDOF
8180: 12 OF ( " ) read-fcode-string 2drop ENDOF
8181: 13 OF ( bbranch ) read-fcode-offset drop ENDOF
8182: 14 OF ( b?branch ) read-fcode-offset drop ENDOF
8183: 15 OF ( loop ) read-fcode-offset drop ENDOF
8184: 16 OF ( +loop ) read-fcode-offset drop ENDOF
8185: 17 OF ( do ) read-fcode-offset drop ENDOF
8186: 18 OF ( ?do ) read-fcode-offset drop ENDOF
8187: 1C OF ( of ) read-fcode-offset drop ENDOF
8188: C6 OF ( endof ) read-fcode-offset drop ENDOF
8189: C3 OF ( to ) read-fcode# drop ENDOF
8190: dup OF next-ip ENDOF
8191: ENDCASE
8192: REPEAT next-ip
8193: ;
8194: : rpush ( rparm -- ) \ push the rparm to be on top of return stack after exit
8195: r> swap >r >r
8196: ;
8197: : rpop ( -- rparm ) \ pop the rparm that was on top of return stack before this
8198: r> r> swap >r
8199: ;
8200: : b1(;) ( -- )
8201: ." b1(;)" cr
8202: rpop set-ip
8203: ;
8204: : b(;) ( -- )
8205: postpone exit reveal postpone [
8206: ; immediate
8207: : b(:) ( -- )
8208: <colon> compile, ]
8209: ; immediate
8210: : b(case) ( sel -- sel )
8211: postpone case
8212: ; immediate
8213: : b(endcase)
8214: postpone endcase
8215: ; immediate
8216: : b(of)
8217: postpone of
8218: read-fcode-offset drop \ read and discard offset
8219: ; immediate
8220: : b(endof)
8221: postpone endof
8222: read-fcode-offset drop
8223: ; immediate
8224: : b(do)
8225: postpone do
8226: read-fcode-offset drop
8227: ; immediate
8228: : b(?do)
8229: postpone ?do
8230: read-fcode-offset drop
8231: ; immediate
8232: : b(loop)
8233: postpone loop
8234: read-fcode-offset drop
8235: ; immediate
8236: : b(+loop)
8237: postpone +loop
8238: read-fcode-offset drop
8239: ; immediate
8240: : b(leave)
8241: postpone leave
8242: ; immediate
8243: : new-token \ unnamed local fcode function
8244: align here next-ip read-fcode# 0 swap set-token
8245: ;
8246: : external-token ( -- ) \ named local fcode function
8247: next-ip read-fcode-string
8248: header ( str len -- ) \ create a header in the current dictionary entry
8249: new-token
8250: ;
8251: : new-token
8252: eva-debug? IF
8253: s" x" get-ip >r next-ip read-fcode# r> set-ip (u.) $cat strdup
8254: header
8255: THEN new-token
8256: ;
8257: : named-token \ decide wether or not to give a new token an own name in the dictionary
8258: fcode-debug? IF new-token ELSE external-token THEN
8259: ;
8260: : b(to) ( x -- )
8261: next-ip read-fcode#
8262: get-token drop
8263: >body cell -
8264: ?compile-mode IF literal, postpone ! ELSE ! THEN
8265: ; immediate
8266: : b(value)
8267: <value> , , reveal
8268: ;
8269: : b(variable)
8270: <variable> , 0 , reveal
8271: ;
8272: : b(constant)
8273: <constant> , , reveal
8274: ;
8275: : undefined-defer
8276: cr cr ." Unititialized defer word has been executed!" cr cr
8277: true fcode-end !
8278: ;
8279: : b(defer)
8280: <defer> , reveal
8281: postpone undefined-defer
8282: ;
8283: : b(create)
8284: <variable> ,
8285: postpone noop reveal
8286: ;
8287: : b(field) ( E: addr -- addr+offset ) ( F: offset size -- offset+size )
8288: <colon> , over literal,
8289: postpone + postpone exit
8290: +
8291: ;
8292: : b(buffer:) ( E: -- a-addr) ( F: size -- )
8293: <variable> , allot
8294: ;
8295: : suspend-fcode ( -- )
8296: noop \ has to be implemented more efficiently ;-)
8297: ;
8298: : offset16 ( -- )
8299: 16 to fcode-offset
8300: ;
8301: : version1 ( -- )
8302: 1 to fcode-spread
8303: 8 to fcode-offset
8304: read-header
8305: ;
8306: : start0 ( -- )
8307: 0 to fcode-spread
8308: offset16
8309: read-header
8310: ;
8311: : start1 ( -- )
8312: 1 to fcode-spread
8313: offset16
8314: read-header
8315: ;
8316: : start2 ( -- )
8317: 2 to fcode-spread
8318: offset16
8319: read-header
8320: ;
8321: : start4 ( -- )
8322: 4 to fcode-spread
8323: offset16
8324: read-header
8325: ;
8326: : end0 ( -- )
8327: true fcode-end !
8328: ;
8329: : end1 ( -- )
8330: end0
8331: ;
8332: : ferror ( -- )
8333: clear end0
8334: cr ." FCode# " fcode-num @ . ." not assigned!"
8335: cr ." FCode evaluation aborted." cr
8336: ." ( -- S:" depth . ." R:" rdepth . ." ) " .s cr
8337: abort
8338: ;
8339: : reset-local-fcodes
8340: FFF 800 DO ['] ferror 0 i set-token LOOP
8341: ;
8342: : byte-load ( addr xt -- )
8343: >r >r
8344: save-evaluator-state
8345: r> r>
8346: reset-fcode-end
8347: 1 to fcode-spread
8348: dup 1 = IF drop ['] rb@ THEN to fcode-rb@
8349: set-ip
8350: reset-local-fcodes
8351: depth >r
8352: evaluate-fcode
8353: r> depth 1- <> IF clear end0
8354: cr ." Ambiguous stack depth after byte-load!"
8355: cr ." FCode evaluation aborted." cr cr
8356: ELSE restore-evaluator-state
8357: THEN
8358: ['] c@ to fcode-rb@
8359: ;
8360: create byte-load-test-fcode
8361: f1 c, 08 c, 18 c, 69 c, 00 c, 00 c, 00 c, 68 c,
8362: 12 c, 16 c, 62 c, 79 c, 74 c, 65 c, 2d c, 6c c,
8363: 6f c, 61 c, 64 c, 2d c, 74 c, 65 c, 73 c, 74 c,
8364: 2d c, 66 c, 63 c, 6f c, 64 c, 65 c, 21 c, 21 c,
8365: 90 c, 92 c, ( a6 c, a7 c, 2e c, ) 00 c,
8366: : byte-load-test
8367: byte-load-test-fcode ['] w@
8368: ; immediate
8369: : fcode-ms
8370: s" ms" $find IF 0= IF compile, ELSE execute THEN THEN ; immediate
8371: : fcode-$find
8372: $find
8373: IF
8374: drop true
8375: ELSE
8376: false
8377: THEN
8378: ;
8379: �������� � P 0pci-class_0c.fs s" serial bus [ " type my-space pci-class-name type s" ]" type cr
8380: my-space pci-device-generic-setup
8381: : handle-usb-ohci-class ( -- )
8382: 4 config-w@ 110 or 4 config-w!
8383: pci-master-enable \ set PCI Bus master bit and
8384: pci-mem-enable \ memory space enable for USB scan
8385: 10 config-l@ \ get base address on stack for usb-ohci.fs
8386: s" usb-ohci.fs" included
8387: ;
8388: : handle-sbc-subclass ( -- )
8389: my-space pci-class@ ffff and CASE \ get PCI sub-class and interface
8390: 0310 OF handle-usb-ohci-class ENDOF \ USB OHCI controller
8391: ENDCASE
8392: ;
8393: handle-sbc-subclass
8394: �������� P( O� 0usb-ohci.fs CONSTANT baseaddrs
8395: s" OHCI base address = " baseaddrs usb-debug-print-val
8396: s" usb" 2dup device-name device-type
8397: 1 encode-int s" #address-cells" property
8398: 0 encode-int s" #size-cells" property
8399: : encode-unit ( port -- unit-str unit-len ) 1 hex-encode-unit ;
8400: : decode-unit ( addr len -- port ) 1 hex-decode-unit ;
8401: STRUCT
8402: /l field td>tattr
8403: /l field td>cbptr
8404: /l field td>ntd
8405: /l field td>bfrend
8406: CONSTANT /tdlen
8407: STRUCT
8408: /l field ed>eattr
8409: /l field ed>tdqtp
8410: /l field ed>tdqhp
8411: /l field ed>ned
8412: CONSTANT /edlen
8413: STRUCT
8414: /l field hc>hcattr
8415: /l field hc>hcdone
8416: CONSTANT /hclen
8417: baseaddrs CONSTANT HcRevision
8418: baseaddrs 4 + CONSTANT hccontrol
8419: baseaddrs 8 + CONSTANT hccomstat
8420: baseaddrs 0c + CONSTANT hcintstat
8421: baseaddrs 14 + CONSTANT hcintdsbl
8422: baseaddrs 18 + CONSTANT hchccareg
8423: baseaddrs 20 + CONSTANT hcctrhead
8424: baseaddrs 24 + CONSTANT hccurcont
8425: baseaddrs 28 + CONSTANT hcbulkhead
8426: baseaddrs 2c + CONSTANT hccurbulk
8427: baseaddrs 30 + CONSTANT hcdnehead
8428: baseaddrs 34 + CONSTANT hcintrval
8429: baseaddrs 40 + CONSTANT HcPeriodicStart
8430: baseaddrs 48 + CONSTANT hcrhdescA
8431: baseaddrs 4c + CONSTANT hcrhdescB
8432: baseaddrs 50 + CONSTANT HcRhStatus
8433: baseaddrs 54 + CONSTANT hcrhpstat
8434: baseaddrs 58 + CONSTANT hcrhpstat2
8435: baseaddrs 5c + CONSTANT hcrhpstat3
8436: usb-debug-flag IF
8437: 0 config-l@ ." - VENDOR: " 8 .r cr
8438: 40 config-l@ ." - PMC : " 8 .r
8439: 44 config-l@ ." PMCSR : " 8 .r cr
8440: E0 config-l@ ." - EXT1 : " 8 .r
8441: E4 config-l@ ." EXT2 : " 8 .r cr
8442: THEN
8443: 2 CONSTANT WDH
8444: 1 CONSTANT RHP-CCS \ Current Connect Status
8445: 2 CONSTANT RHP-PES \ Port Enable Status
8446: 10 CONSTANT RHP-PRS \ Port Reset Status
8447: 100 CONSTANT RHP-PPS \ Port Power Status
8448: 10000 CONSTANT RHP-CSC \ Connect Status Changed
8449: 100000 CONSTANT RHP-PRSC \ Port Reset Status Changed
8450: 0 CONSTANT OHCI-DP-SETUP
8451: 1 CONSTANT OHCI-DP-OUT
8452: 2 CONSTANT OHCI-DP-IN
8453: 3 CONSTANT OHCI-DP-INVALID
8454: 8006000100001200 CONSTANT get-ddescp
8455: 8006000200000900 CONSTANT get-cdescp
8456: 8006000400000900 CONSTANT get-idescp
8457: 8006000500000700 CONSTANT get-edescp
8458: A006000000001000 CONSTANT get-hdescp
8459: 0009010000000000 CONSTANT set-cdescp
8460: 2303010004000000 CONSTANT hpenable-set
8461: 2303040001000000 CONSTANT hp1rst-set
8462: 2303040002000000 CONSTANT hp2rst-set
8463: 2303040003000000 CONSTANT hp3rst-set
8464: 2303040004000000 CONSTANT hp4rst-set
8465: 2303080001000000 CONSTANT hp1pwr-set
8466: 2303080002000000 CONSTANT hp2pwr-set
8467: 2303080003000000 CONSTANT hp3pwr-set
8468: 2303080004000000 CONSTANT hp4pwr-set
8469: A003000000000400 CONSTANT hstatus-get
8470: A300000001000400 CONSTANT hp1sta-get
8471: A300000002000400 CONSTANT hp2sta-get
8472: A300000003000400 CONSTANT hp3sta-get
8473: A300000004000400 CONSTANT hp4sta-get
8474: 8008000000000100 CONSTANT get-config
8475: A1FE000000000100 CONSTANT GET-MAX-LUN
8476: 2 18 lshift CONSTANT DATA0-TOGGLE
8477: 3 18 lshift CONSTANT DATA1-TOGGLE
8478: 0f 1c lshift CONSTANT CC-FRESH-TD
8479: 8 CONSTANT STD-REQUEST-SETUP-SIZE
8480: 0 13 lshift CONSTANT TD-DP-SETUP
8481: 1 13 lshift CONSTANT TD-DP-OUT
8482: 2 13 lshift CONSTANT TD-DP-IN
8483: 400001 CONSTANT ed-cntatr
8484: 400002 CONSTANT ed-cntatr1
8485: 80081 CONSTANT ed-hubatr
8486: 80000 CONSTANT ed-defatr
8487: 0f0e40000 CONSTANT td-attr
8488: 00 VALUE ptr
8489: 200 CONSTANT MAX-TDS
8490: 0 VALUE td-freelist-head
8491: 0 VALUE td-freelist-tail
8492: 0 VALUE num-free-tds
8493: 0 VALUE max-rh-ports
8494: 0 VALUE current-stat
8495: INSTANCE VARIABLE td-list-region
8496: 14 CONSTANT MAX-EDS
8497: 0 VALUE ed-freelist-head
8498: 0 VALUE num-free-eds
8499: INSTANCE VARIABLE ed-list-region
8500: 0 VALUE usb-address
8501: 0 VALUE initial-hub-address
8502: 0 VALUE new-device-address
8503: 0 VALUE mps
8504: 0 VALUE DEBUG-TDS
8505: 0 VALUE case-failed \ available for general use to see IF a CASE statement
8506: 0 VALUE WHILE-failed \ available for general use to see IF a WHILE LOOP
8507: 8 CONSTANT DEFAULT-CONTROL-MPS
8508: 12 CONSTANT DEVICE-DESCRIPTOR-LEN
8509: 1 CONSTANT DEVICE-DESCRIPTOR-TYPE
8510: 1 CONSTANT DEVICE-DESCRIPTOR-TYPE-OFFSET
8511: 4 CONSTANT DEVICE-DESCRIPTOR-DEVCLASS-OFFSET
8512: 7 CONSTANT DEVICE-DESCRIPTOR-MPS-OFFSET
8513: 20 CONSTANT BULK-CONFIG-DESCRIPTOR-LEN
8514: 9 CONSTANT HUB-DEVICE-CLASS
8515: 0 CONSTANT NO-CLASS
8516: VARIABLE setup-packet \ 8 bytes for setup packet
8517: VARIABLE ch-buffer \ 1 byte character buffer
8518: INSTANCE VARIABLE dd-buffer
8519: INSTANCE VARIABLE cd-buffer
8520: 0 VALUE temp1
8521: 0 VALUE temp2
8522: 0 VALUE temp3
8523: 0 VALUE extra-bytes
8524: 0 VALUE num-td
8525: 0 VALUE current
8526: 0 VALUE device-speed
8527: : Show-OHCI-Register
8528: ." -> OHCI-Register: " cr
8529: ." - HcControl : " hccontrol rl@-le 8 .r
8530: ." CmdStat : " hccomstat rl@-le 8 .r
8531: ." HcInterr. : " hcintstat rl@-le 8 .r cr
8532: ." - HcFmIntval: " hcintrval rl@-le 8 .r
8533: ." Per. Start: " HcPeriodicStart rl@-le 8 .r cr
8534: ." - PortStat-1: " hcrhpstat rl@-le 8 .r
8535: ." PortStat-2: " hcrhpstat2 rl@-le 8 .r
8536: ." PortStat-3: " hcrhpstat3 rl@-le 8 .r cr
8537: ." Descr-A : " hcrhdescA rl@-le 8 .r
8538: ." Descr-B : " hcrhdescB rl@-le 8 .r
8539: ." HcRhStat : " HcRhStatus rl@-le 8 .r cr
8540: ;
8541: : display-ed ( ED-ADDRESS -- )
8542: TO temp1
8543: usb-debug-flag IF
8544: s" Dump OF ED " type temp1 u. cr
8545: s" eattr : " type temp1 ed>eattr l@-le u. cr
8546: s" tdqhp : " type temp1 ed>tdqhp l@-le u. cr
8547: s" tdqtp : " type temp1 ed>tdqtp l@-le u. cr
8548: s" ned : " type temp1 ed>ned l@-le u. cr
8549: THEN
8550: ;
8551: : display-td ( TD-ADDRESS -- )
8552: TO temp1
8553: usb-debug-flag IF
8554: s" TD " type temp1 u. s" dump: " type cr
8555: s" td>tattr : " type temp1 td>tattr l@-le u. cr
8556: s" td>cbptr : " type temp1 td>cbptr l@-le u. cr
8557: s" td>ntd : " type temp1 td>ntd l@-le u. cr
8558: s" td>bfrend : " type temp1 td>bfrend l@-le u. cr
8559: THEN
8560: ;
8561: : display-descriptors ( ED-ADDRESS -- )
8562: 10 1- not and ( ED-ADDRESS~ )
8563: dup display-ed ed>tdqhp l@-le BEGIN ( ED-ADDRESS~ )
8564: 10 1- not and ( ED-ADDRESS~ )
8565: dup 0<> ( ED-ADDRESS~ TRUE | FALSE )
8566: WHILE
8567: dup display-td td>ntd l@-le ( ED-ADDRESS~ )
8568: REPEAT
8569: drop
8570: ;
8571: : zero-out-a-td-except-link ( td -- )
8572: dup 0 swap td>tattr l!-le ( td )
8573: dup 0 swap td>cbptr l!-le ( td )
8574: dup 0 swap td>bfrend l!-le ( td )
8575: drop
8576: ;
8577: : initialize-td-free-list ( -- )
8578: MAX-TDS 0= IF EXIT THEN
8579: td-list-region @ 0= IF EXIT THEN
8580: td-list-region @ TO temp1
8581: 0 TO temp2 BEGIN
8582: temp1 zero-out-a-td-except-link
8583: temp1 /tdlen + dup temp1 td>ntd l!-le TO temp1
8584: temp2 1+ TO temp2
8585: temp2 MAX-TDS = ( TRUE | FALSE )
8586: UNTIL
8587: temp1 /tdlen - dup 0 swap td>ntd l!-le TO td-freelist-tail
8588: td-list-region @ TO td-freelist-head
8589: MAX-TDS TO num-free-tds
8590: ;
8591: : allocate-td-list ( n -- head tail )
8592: dup 0= IF drop 0 0 EXIT THEN ( 0 0 )
8593: dup num-free-tds > IF drop 0 0 EXIT THEN ( 0 0 )
8594: dup num-free-tds = IF ( n )
8595: drop td-freelist-head td-freelist-tail ( td-freelist-head td-freelist-tail )
8596: 0 TO td-freelist-head ( td-freelist-head td-freelist-tail )
8597: 0 TO td-freelist-tail ( td-freelist-head td-freelist-tail )
8598: 0 TO num-free-tds ( td-freelist-head td-freelist-tail )
8599: EXIT
8600: THEN
8601: dup num-free-tds swap - TO num-free-tds ( n )
8602: td-freelist-head ( n td-list-head )
8603: dup TO temp1 ( n td-list-head )
8604: swap ( td-list-head n )
8605: 0 DO ( td-list-head )
8606: temp1 TO temp2 ( td-list-head )
8607: temp1 td>ntd l@-le TO temp1 ( td-list-head )
8608: LOOP ( td-list-head )
8609: temp2 ( td-list-head td-list-tail )
8610: dup td>ntd 0 swap l!-le ( td-list-head td-list-tail )
8611: temp1 TO td-freelist-head ( td-list-head td-list-tail )
8612: ;
8613: : find-td-list-tail-and-size ( head -- tail n )
8614: TO temp1
8615: 0 TO temp2
8616: 0 TO temp3
8617: DEBUG-TDS IF
8618: s" BEGIN find-td-list-tail-and-size: " usb-debug-print
8619: THEN
8620: BEGIN
8621: temp1 0<> ( TRUE|FALSE )
8622: WHILE
8623: DEBUG-TDS IF
8624: temp1 u. cr
8625: THEN
8626: temp1 TO temp3
8627: temp1 td>ntd l@-le TO temp1
8628: temp2 1+ TO temp2
8629: REPEAT
8630: temp3 temp2 ( tail n )
8631: DEBUG-TDS IF
8632: s" END find-td-list-tail-and-size" usb-debug-print
8633: THEN
8634: ;
8635: : (free-td-list) ( head -- )
8636: dup find-td-list-tail-and-size num-free-tds + TO num-free-tds ( head tail )
8637: td-freelist-tail 0= IF ( head tail )
8638: dup TO td-freelist-tail ( head tail )
8639: THEN ( head tail )
8640: td>ntd td-freelist-head swap l!-le ( head )
8641: TO td-freelist-head
8642: ;
8643: : zero-out-an-ed-except-link ( ed -- )
8644: dup 0 swap ed>eattr l!-le ( ed )
8645: dup 0 swap ed>tdqtp l!-le ( ed )
8646: dup 0 swap ed>tdqhp l!-le ( ed )
8647: drop
8648: ;
8649: : initialize-ed-free-list ( -- )
8650: MAX-EDS 0= IF EXIT THEN
8651: ed-list-region @ 0= IF
8652: s" init-ed-list: ed-list-region is not allocated!" usb-debug-print
8653: EXIT
8654: THEN
8655: ed-list-region @ TO temp1
8656: 0 TO temp2 BEGIN
8657: temp1 zero-out-an-ed-except-link
8658: temp1 /edlen + dup temp1 ed>ned l!-le TO temp1
8659: temp2 1+ TO temp2
8660: temp2 MAX-EDS =
8661: UNTIL
8662: temp1 /edlen - ed>ned 0 swap l!-le
8663: ed-list-region @ TO ed-freelist-head
8664: MAX-EDS TO num-free-eds
8665: ;
8666: : allocate-ed ( -- ed-ptr )
8667: num-free-eds 0= IF 0 EXIT THEN
8668: ed-freelist-head ( ed-freelist-head )
8669: ed-freelist-head ed>ned l@-le TO ed-freelist-head ( ed-freelist-head )
8670: num-free-eds 1- TO num-free-eds ( ed-freelist-head )
8671: dup ed>ned 0 swap l!-le \ Terminate the Link. ( ed-freelist-head )
8672: ;
8673: : free-ed ( ed-ptr -- )
8674: dup zero-out-an-ed-except-link ( ed-ptr )
8675: dup ed>ned ed-freelist-head swap l!-le ( ed-ptr )
8676: TO ed-freelist-head
8677: num-free-eds 1+ TO num-free-eds
8678: ;
8679: 100 alloc-mem VALUE hchcca
8680: hchcca ff and IF
8681: s" Warning: hchcca not aligned!" usb-debug-print
8682: THEN
8683: 84 hchcca + CONSTANT hchccadneq
8684: : (allocate-mem) ( -- )
8685: /tdlen MAX-TDS * 10 + alloc-mem dup td-list-region ! ( td-list-region-ptr )
8686: f and IF
8687: s" Warning: td-list-region not aligned!" usb-debug-print
8688: THEN
8689: initialize-td-free-list
8690: /edlen MAX-EDS * 10 + alloc-mem dup ed-list-region ! ( ed-list-region-ptr )
8691: f and IF
8692: s" Warning: ed-list-region not aligned!" usb-debug-print
8693: THEN
8694: initialize-ed-free-list
8695: DEVICE-DESCRIPTOR-LEN chars alloc-mem dd-buffer !
8696: BULK-CONFIG-DESCRIPTOR-LEN chars alloc-mem cd-buffer !
8697: ;
8698: : (de-allocate-mem) ( -- )
8699: td-list-region @ ?dup IF
8700: /tdlen MAX-TDS * 10 + free-mem
8701: 0 td-list-region !
8702: THEN
8703: ed-list-region @ ?dup IF
8704: /edlen MAX-EDS * 10 + free-mem
8705: 0 ed-list-region !
8706: THEN
8707: dd-buffer @ ?dup IF
8708: DEVICE-DESCRIPTOR-LEN free-mem
8709: 0 dd-buffer !
8710: THEN
8711: cd-buffer @ ?dup IF
8712: BULK-CONFIG-DESCRIPTOR-LEN free-mem
8713: 0 cd-buffer !
8714: THEN
8715: ;
8716: : hc-suspend ( -- )
8717: 00C3 hccontrol rl!-le \ Suspend USB host controller
8718: ;
8719: : open ( -- TRUE|FALSE )
8720: (allocate-mem)
8721: TRUE
8722: ;
8723: : close ( -- )
8724: (de-allocate-mem)
8725: ;
8726: : HC-enable-control-list-processing ( -- )
8727: hccomstat dup rl@-le 02 or swap rl!-le
8728: hccontrol dup rl@-le 10 or swap rl!-le
8729: ;
8730: : HC-enable-bulk-list-processing ( -- )
8731: hccomstat dup rl@-le 04 or swap rl!-le
8732: hccontrol dup rl@-le 20 or swap rl!-le
8733: ;
8734: : HC-enable-interrupt-list-processing ( -- )
8735: hccontrol dup rl@-le 04 or swap rl!-le
8736: ;
8737: : (HC-ACK-WDH) ( -- ) WDH hcintstat rl!-le ;
8738: : (HC-CHECK-WDH) ( -- ) hcintstat rl@-le WDH and 0<> ;
8739: : disable-control-list-processing ( -- )
8740: hccontrol dup rl@-le ffffffef and swap rl!-le
8741: hccomstat dup rl@-le fffffffd and swap rl!-le
8742: ;
8743: : disable-bulk-list-processing ( -- )
8744: hccontrol dup rl@-le ffffffdf and swap rl!-le
8745: hccomstat dup rl@-le fffffffb and swap rl!-le
8746: ;
8747: : disable-interrupt-list-processing ( -- )
8748: hccontrol dup rl@-le fffffffb and swap rl!-le
8749: ;
8750: 0 VALUE current-toggle
8751: : fill-TD-list ( start-toggle addr dlen dp MPS TD-List-Head -- )
8752: TO temp1 ( start-toggle addr dlen dp MPS )
8753: TO temp2 ( start-toggle addr dlen dp )
8754: CASE ( start-toggle addr dlen )
8755: OHCI-DP-SETUP OF TD-DP-SETUP TO temp3 ENDOF ( start-toggle addr dlen )
8756: OHCI-DP-IN OF TD-DP-IN TO temp3 ENDOF ( start-toggle addr dlen )
8757: OHCI-DP-OUT OF TD-DP-OUT TO temp3 ENDOF ( start-toggle addr dlen )
8758: dup OF -1 TO temp3 ( start-toggle addr dlen )
8759: s" fill-TD-list: Invalid DP specified" usb-debug-print
8760: ENDOF
8761: ENDCASE
8762: temp3 -1 = IF EXIT THEN ( start-toggle addr dlen )
8763: rot ( addr dlen start-toggle )
8764: TO current-toggle swap ( dlen addr )
8765: BEGIN
8766: over temp2 >= ( dlen addr TRUE|FALSE )
8767: WHILE ( dlen addr )
8768: dup temp1 td>cbptr l!-le ( dlen addr )
8769: current-toggle 18 lshift ( dlen addr current-toggle~ )
8770: DATA0-TOGGLE ( dlen addr current-toggle~ toggle )
8771: CC-FRESH-TD temp3 or or or ( dlen addr or-result )
8772: temp1 td>tattr l!-le ( dlen addr~ )
8773: dup temp2 1- + temp1 td>bfrend l!-le ( dlen addr~ )
8774: temp2 + ( dlen next-addr )
8775: swap temp2 - swap
8776: temp1 td>ntd l@-le TO temp1 ( dlen next-addr )
8777: current-toggle ( dlen next-addr current-toggle )
8778: CASE
8779: 0 OF 1 TO current-toggle ENDOF
8780: 1 OF 0 TO current-toggle ENDOF
8781: ENDCASE
8782: REPEAT ( dlen addr )
8783: over 0<> IF
8784: dup temp1 td>cbptr l!-le ( dlen addr )
8785: current-toggle 18 lshift ( dlen addr curent-toggle~ )
8786: DATA0-TOGGLE ( dlen addr curent-toggle~ toggle )
8787: CC-FRESH-TD temp3 or or or ( dlen addr or-result )
8788: temp1 td>tattr l!-le ( dlen addr )
8789: + 1- temp1 td>bfrend l!-le
8790: ELSE
8791: 2drop
8792: THEN
8793: ;
8794: : (td-list-status) ( PointerToTDlist -- failingTD CCode TRUE | 0 )
8795: BEGIN ( PointerToTDlist )
8796: dup 0<> ( PointerToTDlist TRUE|FALSE )
8797: IF ( PointerToTDlist )
8798: dup td>tattr l@-le f0000000 and 1c rshift dup 0= TRUE swap
8799: ELSE
8800: drop FALSE dup ( FALSE )
8801: THEN
8802: WHILE
8803: drop drop td>ntd l@-le
8804: REPEAT
8805: ;
8806: : (wait-for-done-q) ( timeout -- TD-list TRUE | FALSE )
8807: BEGIN ( timeout )
8808: dup 0<> ( timeout TRUE|FALSE )
8809: (HC-CHECK-WDH) NOT ( timeout TRUE|FALSE TRUE|FALSE )
8810: AND \ not timed out AND WDH-bit not set
8811: WHILE
8812: 1 ms \ wait
8813: 1- ( timeout )
8814: dup ff and 0= IF show-proceed THEN
8815: REPEAT ( timeout )
8816: drop
8817: hchccadneq l@-le \ read last HcDoneHead (RAM)
8818: (HC-CHECK-WDH) \ HcDoneHead was updated ?
8819: IF
8820: (HC-ACK-WDH) \ clear register bit: WDH
8821: TRUE ( td-list TRUE )
8822: ELSE
8823: FALSE
8824: THEN
8825: ;
8826: : debug-td ( -- )
8827: s" Num Free TDs = " num-free-tds usb-debug-print-val
8828: ;
8829: : HC-reset ( -- )
8830: hccomstat dup rl@-le 01 or swap rl!-le \ issue HC reset
8831: BEGIN
8832: hccomstat rl@-le 01 and 0<> \ wait for reset end
8833: WHILE
8834: REPEAT
8835: 23f02edf hcintrval rl!-le \ frame-interval register
8836: hchcca hchccareg rl!-le \ HC communication area
8837: 0000 hcctrhead rl!-le \ control transfer head
8838: 0000 hcbulkhead rl!-le \ bulk transfer head
8839: 0ffff hcintdsbl rl!-le \ interrupt disable reg.
8840: 83 hccontrol rl!-le \ set USBOPERATIONAL
8841: 23f02edf hcintrval rl!-le \ frame-interval register
8842: hchcca hchccareg rl!-le \ HC communication area
8843: d# 50 ms
8844: hcrhdescA rl@-le ff and ( total-rh-ports )
8845: to max-rh-ports
8846: hcrhpstat TO current-stat \ start with first port status reg
8847: 0 \ port status default
8848: max-rh-ports 0 \ checking all ports
8849: DO
8850: current-stat rl@-le or \ OR-ing all stats
8851: 200 current-stat rl!-le \ Clear Port Power (CPP)
8852: current-stat 4 + TO current-stat \ check next RH-Port
8853: LOOP
8854: 100 and 0<> \ any of the ports had power ?
8855: IF
8856: d# 750 wait-proceed \ wait for power discharge
8857: THEN
8858: hcrhpstat TO current-stat \ start with first port status reg
8859: max-rh-ports 0
8860: DO
8861: 102 current-stat rl!-le \ power on and enable
8862: hcrhdescA 3 + rb@ 2 * ms \ startup delay 30 ms (2 * POTPGT)
8863: current-stat 4 + TO current-stat \ check next RH-Port
8864: LOOP
8865: d# 500 wait-proceed \ STEC device needs 300 ms
8866: ;
8867: : error-recovery ( -- )
8868: initialize-td-free-list
8869: initialize-ed-free-list
8870: HC-reset
8871: ;
8872: : store-initial-usb-hub-address ( -- )
8873: usb-address TO initial-hub-address
8874: ;
8875: : reset-to-initial-usb-hub-address ( -- )
8876: initial-hub-address TO usb-address
8877: ;
8878: : allocate-usb-address ( -- usb-address )
8879: usb-address 7f <> ( TRUE|FALSE )
8880: IF
8881: usb-address 1+ TO usb-address \ RISK: Check to see IF it overflows 127
8882: usb-address ( usb-address )
8883: THEN ( usb-address )
8884: ;
8885: s" usb-support.fs" INCLUDED
8886: : control-std-set-address ( speedbit -- usb-address TRUE | FALSE )
8887: >r ( R: speedbit )
8888: 0005000000000000 setup-packet !
8889: allocate-usb-address dup setup-packet 2 + c! ( usb-addr R: speedbit )
8890: s" USB set-address: " 2 pick usb-debug-print-val ( usb-addr R: speedbit )
8891: 0 0 0 setup-packet 8 r> controlxfer ( usb-addr TRUE | FALSE )
8892: IF ( TRUE | FALSE )
8893: TRUE ( TRUE )
8894: ELSE
8895: drop FALSE \ PENDING: Return the allocated address back. ( FALSE )
8896: THEN ( TRUE | FALSE )
8897: ;
8898: : control-std-get-device-descriptor
8899: 8006000100000000 setup-packet !
8900: 2 pick setup-packet 6 + w!-le
8901: setup-packet -rot ( data-buffer data-len setup-packet MPS fa )
8902: >r >r >r >r >r 0 r> r> r> r> r>
8903: controlxfer ( TRUE | FALSE )
8904: ;
8905: : control-std-get-configuration-descriptor
8906: TO temp1 ( data-buffer data-len MPS )
8907: TO temp2 ( data-buffer data-len )
8908: TO temp3 ( data-buffer )
8909: 8006000200000000 setup-packet !
8910: temp3 setup-packet 6 + w!-le
8911: 0 swap temp3 setup-packet temp2 temp1 controlxfer
8912: ;
8913: : control-std-get-maxlun ( MPS fun-addr dir data-buff data-len -- TRUE | FALSE )
8914: GET-MAX-LUN setup-packet ! ( MPS fun-addr dir data-buff data-len )
8915: setup-packet 5 pick 5 pick
8916: controlxfer ( MPS fun-addr TRUE | FALSE )
8917: nip nip ( TRUE | FALSE )
8918: ;
8919: : control-bulk-reset ( MPS fun-addr dir data-buff data-len -- TRUE | FALSE )
8920: 21FF000000000000 setup-packet ! ( MPS fun-addr dir data-buff data-len )
8921: setup-packet 5 pick 5 pick
8922: controlxfer ( MPS fun-addr TRUE | FALSE )
8923: nip nip ( TRUE | FALSE )
8924: ;
8925: : control-std-get-string-descriptor
8926: TO temp1 ( StringIndex data-buffer data-len MPS )
8927: TO temp2 ( StringIndex data-buffer data-len )
8928: TO temp3 ( StringIndex )
8929: 8006000300000000 setup-packet !
8930: temp3 setup-packet 6 + w!-le
8931: 409 setup-packet 4 + w!-le \ US English Language code.
8932: swap ( data buffer StringIndex )
8933: setup-packet 2 + c! ( data-buffer )
8934: 0 swap temp3 setup-packet temp2 temp1 controlxfer ( TRUE | FALSE )
8935: ;
8936: : control-std-set-configuration ( configvalue FuncAddr -- TRUE|FALSE )
8937: TO temp1 ( configvalue )
8938: TO temp2
8939: 0009000000000000 setup-packet ! \ RISK: Endian and 64-bit assumptions
8940: temp2 setup-packet 2 + w!-le
8941: 0 0 0 setup-packet DEFAULT-CONTROL-MPS temp1 controlxfer
8942: ;
8943: 0 VALUE port-number
8944: s" usb-enumerate.fs" INCLUDED
8945: : rhport-enumerate ( port-num -- )
8946: TO port-number
8947: device-speed control-std-set-address ( usb-addr TRUE | FALSE )
8948: IF
8949: device-speed or ( usb-addr+speedbit )
8950: TO new-device-address
8951: dd-buffer @ 8 erase
8952: dd-buffer @ DEFAULT-CONTROL-MPS DEFAULT-CONTROL-MPS ( buffer mps mps )
8953: new-device-address control-std-get-device-descriptor ( TRUE | FALSE )
8954: IF
8955: ELSE
8956: s" USB: Read Dev Descriptor failed" usb-debug-print EXIT
8957: THEN
8958: dd-buffer @ DEVICE-DESCRIPTOR-TYPE-OFFSET + c@ ( Descriptor-type )
8959: DEVICE-DESCRIPTOR-TYPE <> IF
8960: s" USB: Error Reading Device Descriptor" usb-debug-print
8961: s" Read descriptor is not OF the right type" usb-debug-print
8962: s" Aborting enumeration" usb-debug-print
8963: EXIT
8964: THEN
8965: dd-buffer @ DEVICE-DESCRIPTOR-MPS-OFFSET + c@ TO mps
8966: create-usb-device-tree
8967: ELSE
8968: s" Set address failed on port " port-number usb-debug-print-val
8969: s" Aborting Enumeration." usb-debug-print
8970: EXIT
8971: THEN
8972: ;
8973: : rhport-initialize ( -- )
8974: hcrhpstat TO current-stat \ start with first port status reg
8975: max-rh-ports 1+ 1
8976: DO
8977: current-stat rl@-le RHP-CCS and 0<> ( TRUE|FALSE )
8978: IF
8979: current-stat hcrhpstat3 = \ third port of NEC ?
8980: IF
8981: 81 to uDOC-present \ uDOC is present and now processed
8982: THEN
8983: s" Device connected to this port!" usb-debug-print
8984: RHP-PRS current-stat rl!-le \ issue a port reset
8985: BEGIN
8986: current-stat rl@-le RHP-PRS AND \ wait for reset end
8987: WHILE
8988: REPEAT
8989: hcrhdescA 3 + rb@ 2 * ms \ startup delay 30 ms (POTPGT)
8990: d# 100 ms
8991: current-stat rl@-le 200 and 4 lshift
8992: to device-speed \ store speed bit
8993: RHP-CSC RHP-PRSC or current-stat rl!-le
8994: I ['] rhport-enumerate CATCH IF \ Scan port
8995: s" USB scan failed on root hub port: " rot usb-debug-print-val
8996: reset-to-initial-usb-hub-address
8997: THEN
8998: ELSE
8999: s" No device detected at this port." usb-debug-print
9000: current-stat hcrhpstat3 = \ third port of NEC ? (=ModFD)
9001: IF \ here a ModFD should be on ELBA
9002: current-stat rl@-le 80000 and 0<> \ is over-current detected ?
9003: IF
9004: uDOC-present 08 or to uDOC-present \ set flag for uDOC-check
9005: THEN
9006: THEN
9007: THEN
9008: current-stat 4 + TO current-stat \ check next RH-Port
9009: uDOC-present 0f and to uDOC-present \ remove processing flag
9010: LOOP
9011: ;
9012: : enumerate ( -- )
9013: HC-reset
9014: ['] hc-suspend add-quiesce-xt \ Assert that HC will be supsended
9015: store-initial-usb-hub-address
9016: rhport-initialize \ Probe all available RH ports
9017: reset-to-initial-usb-hub-address
9018: ;
9019: set-ohci-alias
9020: �������� ;� ;� 0usb-support.fs 0 value NEXT-TD
9021: 0 VALUE num-tds
9022: 0 VALUE td-retire-count
9023: 0 VALUE saved-tail
9024: 0 VALUE poll-timer
9025: VARIABLE controlxfer-cmd
9026: : (ed-prepare) ( dir addr dlen setup-packet MPS ep-fun --
9027: FALSE | dir addr dlen ed-ptr setup-ptr )
9028: allocate-ed dup 0= IF ( dir addr dlen setup-packet MPS ep-fun ed-ptr )
9029: drop 3drop 2drop FALSE EXIT ( FALSE )
9030: THEN
9031: TO temp1 ( dir addr dlen setup-packet MPS ep-fun )
9032: temp1 zero-out-an-ed-except-link ( dir addr dlen setup-packet MPS ep-fun )
9033: temp1 ed>eattr l@-le or temp1 ed>eattr l!-le ( dir addr dlen setup-ptr MPS )
9034: dup TO temp2 10 lshift temp1 ed>eattr l@-le or temp1 ed>eattr l!-le
9035: temp1 swap TRUE ( dir addr dlen ed-ptr setup-ptr TRUE )
9036: ;
9037: : (td-prepare) ( dir addr dlen ed-ptr setup-ptr --
9038: dir FALSE | dir addr dlen ed-ptr setup-ptr td-head td-tail )
9039: 2 pick ( dir addr dlen ed-ptr setup-ptr dlen )
9040: temp2 ( dir addr dlen ed-ptr setup-ptr dlen MPS )
9041: /mod ( dir addr dlen ed-ptr setup-ptr rem quo )
9042: swap 0<> IF ( dir addr dlen ed-ptr setup-ptr quo )
9043: 1+
9044: THEN
9045: 2+
9046: dup TO num-tds ( dir addr dlen ed-ptr setup-ptr quo+2 )
9047: allocate-td-list dup 0= IF ( dir addr dlen ed-ptr setup-ptr quo+2 )
9048: 2drop ( dir addr dlen ed-ptr setup-ptr )
9049: drop ( dir addr dlen ed-ptr )
9050: free-ed ( dir addr dlen )
9051: 2drop ( dir )
9052: FALSE ( dir FALSE )
9053: EXIT
9054: THEN TRUE
9055: ;
9056: : (td-ready) ( dir addr dlen ed-ptr setup-ptr td-head td-tail -- )
9057: 3 pick ( dir addr dlen ed-ptr setup-ptr td-head td-tail ed-ptr )
9058: tuck ( dir addr dlen ed-ptr setup-ptr td-head ed-ptr td-tail ed-ptr )
9059: ed>tdqtp l!-le ( dir addr dlen ed-ptr setup-ptr td-head ed-ptr )
9060: ed>tdqhp l!-le ( dir addr dlen ed-ptr setup-ptr )
9061: over ed>ned 0 swap l!-le ( dir addr dlen ed-ptr setup-ptr )
9062: ;
9063: : (td-setup-status) ( dir addr dlen ed-ptr setup-ptr -- dir addr dlen ed-ptr )
9064: over ed>tdqhp l@-le ( dir addr dlen ed-ptr setup-ptr td-head )
9065: dup zero-out-a-td-except-link ( dir addr dlen ed-ptr setup-ptr td-head )
9066: dup td>tattr DATA0-TOGGLE CC-FRESH-TD or swap l!-le
9067: 2dup td>cbptr l!-le ( dir addr dlen ed-ptr setup-ptr td-head )
9068: 2dup td>bfrend swap STD-REQUEST-SETUP-SIZE 1- + swap l!-le
9069: 2drop ( dir addr dlen ed-ptr )
9070: ;
9071: : (td-tailpointer) ( dir addr dlen ed-ptr -- dir addr dlen ed-ptr )
9072: dup ed>tdqtp l@-le ( dir addr dlen ed-ptr td-tail )
9073: dup zero-out-a-td-except-link ( dir addr dlen ed-ptr td-tail )
9074: dup td>tattr dup l@-le DATA1-TOGGLE CC-FRESH-TD or or swap l!-le
9075: 4 pick 0= ( dir addr dlen ed-ptr td-tail flag )
9076: 3 pick 0<> ( dir addr dlen ed-ptr td-tail flag flag )
9077: and IF ( dir addr dlen ed-ptr td-tail )
9078: dup td>tattr dup l@-le TD-DP-OUT or swap l!-le
9079: ELSE
9080: dup td>tattr dup l@-le TD-DP-IN or swap l!-le
9081: THEN
9082: drop ( dir addr dlen ed-ptr )
9083: ;
9084: : (td-data) ( dir addr dlen ed-ptr -- ed-ptr )
9085: -rot ( dir ed-ptr addr dlen )
9086: dup 0<> IF ( dir ed-ptr addr dlen )
9087: >r >r >r TO temp1 r> r> r> temp1 ( ed-ptr addr dlen dir )
9088: 3 pick ( ed-ptr addr dlen dir ed-ptr )
9089: ed>tdqhp l@-le td>ntd l@-le ( ed-ptr addr dlen dir td-datahead )
9090: 4 pick ( ed-ptr addr dlen dir td-datahead ed-ptr )
9091: td>tattr l@-le 10 rshift ( ed-ptr addr dlen dir td-head-data MPS )
9092: swap ( ed-ptr addr dlen dir MPS td-head-data )
9093: >r >r >r >r >r 1 r> r> r> r> r>
9094: >r >r 0= IF ( ed-ptr 1 addr dlen dir )
9095: OHCI-DP-IN ( ed-ptr 1 addr dlen dir OHCI-DP-IN )
9096: ELSE
9097: OHCI-DP-OUT ( ed-ptr 1 addr dlen dir OHCI-DP-OUT )
9098: THEN
9099: r> r> ( ed-ptr 1 addr dlen dir OHCI-DP- MPS td-head-data )
9100: fill-TD-list
9101: ELSE
9102: 2drop nip ( ed-ptr )
9103: THEN
9104: ;
9105: 10 CONSTANT max-retire-td
9106: : (transfer-wait-for-doneq) ( ed-ptr -- TRUE | FALSE )
9107: dup ( ed-ptr ed-ptr )
9108: hcctrhead rl!-le ( ed-ptr )
9109: HC-enable-control-list-processing ( ed-ptr )
9110: 0 TO td-retire-count ( ed-ptr )
9111: 0 TO poll-timer ( ed-ptr )
9112: BEGIN
9113: td-retire-count num-tds <> ( ed-ptr TRUE | FALSE )
9114: poll-timer max-retire-td < and ( ed-ptr TRUE | FALSE )
9115: WHILE
9116: (HC-CHECK-WDH) ( ed-ptr )
9117: IF
9118: hchccadneq l@-le find-td-list-tail-and-size nip ( ed-ptr n )
9119: td-retire-count + TO td-retire-count ( ed-ptr )
9120: hchccadneq l@-le dup ( ed-ptr done-td done-td )
9121: (td-list-status) ( ed-ptr done-td failed-td CCcode )
9122: IF
9123: dup >r
9124: s" (transfer-wait-for-doneq: USB device communication error."
9125: usb-debug-print ( ed-ptr done-td failed-td CCcode R: CCcode )
9126: dup 4 = swap dup 5 = rot or ( ed-ptr done-td failed-td CCcode R: CCcode )
9127: IF
9128: max-retire-td TO poll-timer ( ed-ptr done-td failed-td CCcode R: CCcode )
9129: THEN
9130: usb-debug-flag
9131: IF
9132: s" CC code ->" type . cr
9133: s" Failing TD contents:" type cr display-td
9134: ELSE
9135: 2drop
9136: THEN ( ed-ptr done-td R: CCcode )
9137: controlxfer-cmd @ GET-MAX-LUN = r> 4 = and
9138: IF
9139: s" (transfer-wait-for-doneq): GET-MAX-LUN ControlXfer STALLed"
9140: usb-debug-print
9141: ELSE
9142: drop
9143: 5030 error" (USB) Device communication error."
9144: ABORT
9145: THEN
9146: THEN ( ed-ptr done-td )
9147: (free-td-list) ( ed-ptr )
9148: 0 hchccadneq l!-le ( ed-ptr )
9149: (HC-ACK-WDH) \ TDs were written to DOne queue. ACK the HC.
9150: THEN
9151: poll-timer 1+ TO poll-timer
9152: 4 ms \ longer 1 ms
9153: REPEAT ( ed-ptr )
9154: disable-control-list-processing ( ed-ptr )
9155: td-retire-count num-tds <> ( ed-ptr )
9156: IF
9157: dup display-descriptors ( ed-ptr )
9158: s" maximum of retire " usb-debug-print
9159: THEN
9160: free-ed
9161: td-retire-count num-tds <>
9162: IF
9163: FALSE ( FALSE )
9164: ELSE
9165: TRUE ( TRUE )
9166: THEN
9167: ;
9168: : controlxfer ( dir addr dlen setup-packet MPS ep-fun -- TRUE | FALSE )
9169: 2 pick @ controlxfer-cmd !
9170: (ed-prepare) ( FALSE | dir addr dlen ed-ptr setup-ptr )
9171: invert IF FALSE EXIT THEN
9172: (td-prepare) ( pt ed-type toggle buffer length mps head )
9173: invert IF FALSE EXIT THEN
9174: (td-ready) ( dir addr dlen ed-ptr setup-ptr )
9175: (td-setup-status) ( dir addr dlen ed-ptr )
9176: (td-tailpointer) ( dir addr dlen ed-ptr )
9177: (td-data) ( ed-ptr )
9178: dup ed>tdqtp l@-le TO saved-tail ( ed-ptr )
9179: dup ed>tdqtp 0 swap l!-le ( ed-ptr )
9180: (transfer-wait-for-doneq) ( TRUE | FALSE )
9181: ;
9182: 0201000000000000 CONSTANT CLEARHALTFEATURE
9183: 0 VALUE endpt-num
9184: 0 VALUE usb-addr-contr-req
9185: : control-std-clear-feature ( endpoint-nr usb-addr -- TRUE|FALSE )
9186: TO usb-addr-contr-req \ usb address
9187: TO endpt-num \ endpoint number
9188: CLEARHALTFEATURE setup-packet !
9189: endpt-num setup-packet 4 + c! \ endpoint number
9190: 0 0 0 setup-packet DEFAULT-CONTROL-MPS usb-addr-contr-req controlxfer
9191: ;
9192: 21FF000000000000 CONSTANT BULK-RESET
9193: : control-std-bulk-reset ( usb-addr -- TRUE|FALSE )
9194: TO usb-addr-contr-req
9195: BULK-RESET setup-packet !
9196: 0 0 0 setup-packet DEFAULT-CONTROL-MPS usb-addr-contr-req controlxfer
9197: ;
9198: : bulk-reset-recovery-procedure ( bulk-out-endp bulk-in-endp usb-addr -- )
9199: >r ( bulk-out-endp bulk-in-endp R: usb-addr )
9200: r@ control-std-bulk-reset
9201: IF s" bulk reset OK"
9202: ELSE s" bulk reset failed"
9203: THEN usb-debug-print
9204: 80 or r@ control-std-clear-feature
9205: IF s" control-std-clear IN endpoint OK"
9206: ELSE s" control-std-clear-IN endpoint failed"
9207: THEN usb-debug-print
9208: r@ control-std-clear-feature
9209: IF s" control-std-clear OUT endpoint OK"
9210: ELSE s" control-std-clear-OUT endpoint failed"
9211: THEN usb-debug-print
9212: r> drop
9213: ;
9214: 0 VALUE saved-rw-ed
9215: 0 VALUE num-rw-tds
9216: 0 VALUE num-rw-retired-tds
9217: 0 VALUE saved-rw-start-toggle
9218: 0 VALUE saved-list-type
9219: : (ed-prepare-rw)
9220: ( pt ed-type toggle buffer length mps address ed-ptr --
9221: FALSE | pt ed-type toggle buffer length mps )
9222: allocate-ed dup 0= IF
9223: drop 2drop 2drop 2drop drop
9224: saved-rw-start-toggle FALSE EXIT ( toggle FALSE )
9225: THEN
9226: TO saved-rw-ed ( pt ed-type toggle buffer length mps address )
9227: saved-rw-ed zero-out-an-ed-except-link
9228: saved-rw-ed ed>eattr l!-le ( pt ed-type toggle buffer length mps )
9229: dup 10 lshift saved-rw-ed ed>eattr l@-le or
9230: saved-rw-ed ed>eattr l!-le TRUE ( pt ed-type toggle buffer length mps TRUE )
9231: ;
9232: : (td-prepare-rw)
9233: ( pt ed-type toggle buffer length mps --
9234: FALSE | pt ed-type toggle buffer length mps head )
9235: 2dup ( pt ed-type toggle buffer length mps length mps )
9236: /mod ( pt ed-type toggle buffer length mps num-tds rem )
9237: swap 0<> IF ( pt ed-type toggle buffer length mps num-tds )
9238: 1+ ( pt ed-type toggle buffer length mps num-tds+1 )
9239: THEN
9240: dup TO num-rw-tds ( pt ed-type toggle buffer length mps num-tds )
9241: allocate-td-list ( pt ed-type toggle buffer length mps head tail )
9242: dup 0= IF
9243: 2drop 2drop 2drop 2drop
9244: saved-rw-ed free-ed
9245: ." rw-endpoint: TD list allocation failed" cr
9246: saved-rw-start-toggle FALSE ( FALSE )
9247: EXIT
9248: THEN
9249: drop TRUE ( pt ed-type toggle buffer length mps head TRUE )
9250: ;
9251: : (td-data-rw)
9252: 6 pick ( pt ed-type toggle buffer length mps head pt )
9253: FALSE TO case-failed CASE
9254: 0 OF OHCI-DP-IN ENDOF
9255: 1 OF OHCI-DP-OUT ENDOF
9256: 2 OF OHCI-DP-SETUP ENDOF
9257: dup OF TRUE TO case-failed
9258: ." rw-endpoint: Invalid Packet Type!" cr
9259: ENDOF
9260: ENDCASE ( pt ed-type toggle buffer length mps head dp )
9261: case-failed IF
9262: saved-rw-ed free-ed ( pt ed-type toggle buffer length mps head dp )
9263: drop (free-td-list) ( pt ed-type toggle buffer length mps head )
9264: 2drop 2drop 2drop
9265: saved-rw-start-toggle FALSE ( FALSE )
9266: EXIT ( FALSE )
9267: THEN
9268: -rot ( pt ed-type toggle buffer length dp mps head )
9269: dup >r ( pt ed-type toggle buffer length dp mps head )
9270: fill-TD-list r> TRUE ( pt et head TRUE )
9271: ;
9272: : (ed-ready-rw) ( pt et -- - | toggle FALSE )
9273: nip ( et )
9274: FALSE TO case-failed CASE
9275: 0 OF \ Control List. Queue the ED to control list
9276: 0 TO saved-list-type
9277: saved-rw-ed hcctrhead rl!-le
9278: HC-enable-control-list-processing
9279: ENDOF
9280: 1 OF \ Bulk List. Queue the ED to bulk list
9281: 1 TO saved-list-type
9282: saved-rw-ed hcbulkhead rl!-le
9283: HC-enable-bulk-list-processing
9284: ENDOF
9285: 2 OF \ Interrupt List.
9286: 2 TO saved-list-type
9287: saved-rw-ed hchccareg rl@-le rl!-le
9288: HC-enable-interrupt-list-processing
9289: ENDOF
9290: dup OF
9291: saved-rw-ed ed>tdqhp l@-le (free-td-list)
9292: saved-rw-ed free-ed
9293: TRUE TO case-failed
9294: ENDOF
9295: ENDCASE
9296: case-failed IF
9297: saved-rw-start-toggle FALSE ( toggle FALSE )
9298: EXIT
9299: THEN
9300: TRUE ( TRUE )
9301: ;
9302: : (wait-td-retire) ( -- )
9303: 0 TO num-rw-retired-tds
9304: FALSE TO while-failed
9305: BEGIN
9306: num-rw-retired-tds num-rw-tds < ( TRUE | FALSE )
9307: while-failed FALSE = and ( TRUE | FALSE )
9308: WHILE
9309: d# 5000 (wait-for-done-q) ( TD-list TRUE|FALSE )
9310: IF
9311: dup find-td-list-tail-and-size nip ( td-list size )
9312: num-rw-retired-tds + TO num-rw-retired-tds ( td-list )
9313: dup (td-list-status) ( td-list failed-TD CC )
9314: IF
9315: dup 4 =
9316: IF
9317: saved-list-type
9318: CASE
9319: 0 OF
9320: 0 0 control-std-clear-feature
9321: s" clear feature " usb-debug-print
9322: ENDOF
9323: 1 OF \ clean bulk stalled
9324: s" clear bulk when stalled " usb-debug-print
9325: disable-bulk-list-processing \ disable procesing
9326: saved-rw-ed ed>eattr l@-le dup \ extract
9327: 780 and 7 rshift 80 or \ endpoint and
9328: swap 7f and \ usb addr
9329: control-std-clear-feature
9330: ENDOF
9331: 2 OF
9332: 0 saved-rw-ed ed>eattr l@-le
9333: control-std-clear-feature
9334: ENDOF
9335: dup OF
9336: s" unknown status " usb-debug-print
9337: ENDOF
9338: ENDCASE
9339: ELSE ( td-list failed-TD CC )
9340: ." TD failed " 5b emit .s 5d emit cr
9341: 5040 error" (USB) device transaction error (wait-td-retire)."
9342: ABORT
9343: THEN
9344: 2drop drop
9345: TRUE TO while-failed \ transaction failed
9346: NEXT-TD 0<> \ clean the TD if we
9347: IF
9348: NEXT-TD (free-td-list) \ had a stalled
9349: THEN
9350: THEN
9351: (free-td-list)
9352: ELSE
9353: drop \ drop td-list pointer
9354: scan-time? IF 2e emit THEN \ show proceeding dots
9355: TRUE TO while-failed
9356: s" time out wait for done" usb-debug-print
9357: 20 ms \ wait for bad device
9358: THEN
9359: REPEAT
9360: ;
9361: : (process-retired-td) ( -- TRUE | FALSE )
9362: saved-list-type CASE
9363: 0 OF disable-control-list-processing ENDOF
9364: 1 OF disable-bulk-list-processing ENDOF
9365: 2 OF disable-interrupt-list-processing ENDOF
9366: ENDCASE
9367: saved-rw-ed ed>tdqhp l@-le 2 and 0<> IF
9368: 1
9369: s" retired 1" usb-debug-print
9370: ELSE
9371: 0
9372: s" retired 0" usb-debug-print
9373: THEN
9374: WHILE-failed IF
9375: FALSE ( FALSE )
9376: ELSE
9377: TRUE ( TRUE )
9378: THEN
9379: saved-rw-ed free-ed
9380: ;
9381: : (do-rw-endpoint)
9382: 4 pick ( pt ed-type toggle buffer length mps address toggle )
9383: TO saved-rw-start-toggle ( pt ed-type toggle buffer length mps address )
9384: (ed-prepare-rw) ( FALSE | pt ed-type toggle buffer length mps )
9385: invert IF FALSE EXIT THEN
9386: (td-prepare-rw) ( FALSE | pt ed-type toggle buffer length mps head )
9387: invert IF FALSE EXIT THEN
9388: (td-data-rw) ( FALSE | pt et head )
9389: invert IF FALSE EXIT THEN
9390: saved-rw-ed ed>tdqhp l!-le ( pt et )
9391: saved-rw-ed ed>tdqhp l@-le td>ntd l@-le TO NEXT-TD \ save for a stalled
9392: (ed-ready-rw)
9393: invert IF FALSE EXIT THEN
9394: (wait-td-retire)
9395: (process-retired-td) ( TRUE | FALSE )
9396: ;
9397: 0 VALUE transfer-len
9398: 0 VALUE mps-current
9399: 0 VALUE addr-current
9400: 0 VALUE usb-addr
9401: 0 VALUE toggle-current
9402: 0 VALUE type-current
9403: 0 VALUE pt-current
9404: 0 VALUE read-status
9405: 0 VALUE counter
9406: 0 VALUE residue
9407: : rw-endpoint
9408: 2 pick TO transfer-len ( pt ed-type toggle buffer length mps address )
9409: 1 pick TO mps-current ( pt ed-type toggle buffer length mps address )
9410: TRUE TO read-status ( pt ed-type toggle buffer length mps address )
9411: transfer-len mps-current num-free-tds * <= IF
9412: (do-rw-endpoint) ( toggle TRUE | toggle FALSE )
9413: TO read-status ( toggle )
9414: TO toggle-current
9415: ELSE
9416: TO usb-addr ( pt ed-type toggle buffer length mps )
9417: 2drop ( pt ed-type toggle buffer )
9418: TO addr-current ( pt ed-type toggle )
9419: TO toggle-current ( pt ed-type )
9420: TO type-current ( pt )
9421: TO pt-current
9422: transfer-len mps-current num-free-tds * /mod ( residue count )
9423: TO counter ( residue )
9424: TO residue
9425: mps-current num-free-tds * TO transfer-len BEGIN
9426: counter 0 > ( TRUE | FALSE )
9427: read-status TRUE = and ( TRUE | FALSE )
9428: WHILE
9429: pt-current type-current toggle-current ( pt ed-type toggle )
9430: addr-current transfer-len ( pt ed-type toggle buffer length )
9431: mps-current ( pt ed-type toggle buffer length mps )
9432: usb-addr (do-rw-endpoint) ( toggle TRUE | toggle FALSE )
9433: TO read-status ( toggle )
9434: TO toggle-current
9435: addr-current transfer-len + TO addr-current
9436: counter 1- TO counter
9437: REPEAT
9438: residue 0<> ( TRUE |FALSE )
9439: read-status TRUE = and IF
9440: residue TO transfer-len
9441: pt-current type-current toggle-current ( pt ed-type toggle )
9442: addr-current transfer-len ( pt ed-type toggle buffer length )
9443: mps-current ( pt ed-type toggle buffer length mps )
9444: usb-addr (do-rw-endpoint) ( toggle TRUE | toggle FALSE )
9445: TO read-status
9446: TO toggle-current
9447: THEN
9448: THEN
9449: read-status invert IF
9450: THEN
9451: toggle-current ( toggle )
9452: read-status ( TRUE | FALSE )
9453: ;
9454: �������� � � 0usb-hub.fs s" hub" device-name
9455: s" usb" device-type
9456: 1 encode-int s" #address-cells" property
9457: 0 encode-int s" #size-cells" property
9458: : encode-unit ( port-addr -- unit-str unit-len ) 1 hex-encode-unit ;
9459: : decode-unit ( addr len -- port-addr ) 1 hex-decode-unit ;
9460: 0 VALUE new-device-address
9461: 0 VALUE port-number
9462: 0 VALUE MPS-DCP
9463: 0 VALUE mps
9464: 0 VALUE my-usb-address
9465: 00 value device-speed
9466: : mps-property-set ( -- )
9467: s" HUB Compiling mps-property-set " usb-debug-print
9468: s" USB-ADDRESS" get-my-property ( TRUE | prop-addr prop-len FALSE )
9469: IF
9470: s" notpossible" usb-debug-print
9471: ELSE
9472: decode-int nip nip to my-usb-address
9473: THEN
9474: s" MPS-DCP" get-my-property ( TRUE | prop-addr prop-len FALSE )
9475: IF
9476: s" MPS-DCP property not found Assuming 8 as MAX PACKET SIZE" ( str len )
9477: usb-debug-print
9478: s" for the default control pipe" usb-debug-print
9479: 8 to MPS-DCP
9480: ELSE
9481: s" MPS-DCP property found!!" usb-debug-print ( prop-addr prop-len FALSE )
9482: decode-int nip nip to MPS-DCP
9483: THEN
9484: ;
9485: 2303080000000000 CONSTANT hppwr-set
9486: 2301080000000000 CONSTANT hppwr-clear
9487: 2303040000000000 CONSTANT hprst-set
9488: A300000000000400 CONSTANT hpsta-get
9489: 2303010000000000 CONSTANT hpena-set
9490: A006002900000000 CONSTANT hubds-get
9491: 8 CONSTANT DEFAULT-CONTROL-MPS
9492: 12 CONSTANT DEVICE-DESCRIPTOR-LEN
9493: 9 CONSTANT CONFIG-DESCRIPTOR-LEN
9494: 20 CONSTANT BULK-CONFIG-DESCRIPTOR-LEN
9495: 1 CONSTANT DEVICE-DESCRIPTOR-TYPE
9496: 1 CONSTANT DEVICE-DESCRIPTOR-TYPE-OFFSET
9497: 4 CONSTANT DEVICE-DESCRIPTOR-DEVCLASS-OFFSET
9498: 7 CONSTANT DEVICE-DESCRIPTOR-MPS-OFFSET
9499: 9 CONSTANT HUB-DEVICE-CLASS
9500: 0 CONSTANT NO-CLASS
9501: 00 VALUE temp1
9502: 00 VALUE temp2
9503: 00 VALUE temp3
9504: 00 VALUE po2pg \ Power On to Power Good
9505: VARIABLE setup-packet \ 8 bytes for setup packet
9506: VARIABLE ch-buffer \ 1 byte character buffer
9507: INSTANCE VARIABLE dd-buffer
9508: INSTANCE VARIABLE cd-buffer
9509: 8 chars alloc-mem VALUE status-buffer
9510: 9 chars alloc-mem VALUE hd-buffer
9511: : (allocate-mem) ( -- )
9512: DEVICE-DESCRIPTOR-LEN chars alloc-mem dd-buffer !
9513: BULK-CONFIG-DESCRIPTOR-LEN chars alloc-mem cd-buffer !
9514: ;
9515: : (de-allocate-mem) ( -- )
9516: dd-buffer @ ?dup IF
9517: DEVICE-DESCRIPTOR-LEN free-mem
9518: 0 dd-buffer !
9519: THEN
9520: cd-buffer @ ?dup IF
9521: BULK-CONFIG-DESCRIPTOR-LEN free-mem
9522: 0 cd-buffer !
9523: THEN
9524: ;
9525: : open ( -- TRUE )
9526: (allocate-mem)
9527: TRUE
9528: ;
9529: : close ( -- )
9530: (de-allocate-mem)
9531: ;
9532: : controlxfer ( dir addr dlen setup-packet MPS ep-fun -- TRUE|FALSE )
9533: s" controlxfer" $call-parent
9534: ;
9535: : control-std-set-address ( speedbit -- usb-address TRUE|FALSE )
9536: s" control-std-set-address" $call-parent
9537: ;
9538: : control-std-get-device-descriptor
9539: s" control-std-get-device-descriptor" $call-parent
9540: ;
9541: : control-std-get-configuration-descriptor
9542: s" control-std-get-configuration-descriptor" $call-parent
9543: ;
9544: : control-std-get-maxlun
9545: s" control-std-get-maxlun" $call-parent
9546: ;
9547: : control-std-set-configuration
9548: s" control-std-set-configuration" $call-parent
9549: ;
9550: : control-std-get-string-descriptor
9551: s" control-std-get-string-descriptor" $call-parent
9552: ;
9553: : rw-endpoint
9554: s" rw-endpoint" $call-parent
9555: ;
9556: : debug-td ( -- )
9557: s" debug-td" $call-parent
9558: ;
9559: : control-bulk-reset ( MPS fun-addr dir data-buff data-len -- TRUE | FALSE )
9560: s" control-bulk-reset" $call-parent
9561: ;
9562: : control-hub-port-power-set ( port# -- TRUE|FALSE )
9563: hppwr-set setup-packet ! ( port#)
9564: setup-packet 4 + c!
9565: 0 0 0 setup-packet MPS-DCP my-usb-address controlxfer ( TRUE | FALSE )
9566: ;
9567: : control-hub-port-power-clear ( port#-- TRUE|FALSE )
9568: hppwr-clear setup-packet ! ( port#)
9569: setup-packet 4 + c!
9570: 0 0 0 setup-packet MPS-DCP my-usb-address controlxfer ( TRUE|FALSE )
9571: ;
9572: : control-hub-port-reset-set ( port# -- TRUE|FALSE )
9573: hprst-set setup-packet ! ( port# )
9574: setup-packet 4 + c!
9575: 0 0 0 setup-packet MPS-DCP my-usb-address controlxfer ( TRUE|FALSE )
9576: ;
9577: : control-hub-port-enable ( port# -- TRUE|FALSE )
9578: hpena-set setup-packet ! ( port# )
9579: setup-packet 4 + c!
9580: 0 0 0 setup-packet MPS-DCP my-usb-address controlxfer ( TRUE|FALSE )
9581: ;
9582: : control-hub-port-status-get ( buffer port# -- TRUE|FALSE )
9583: hpsta-get setup-packet ! ( buffer port# )
9584: setup-packet 4 + c! ( buffer )
9585: 0 swap 4 setup-packet MPS-DCP my-usb-address controlxfer ( TRUE|FALSE )
9586: ;
9587: : control-get-hub-descriptor ( buffer buffer-length -- TRUE|FALSE )
9588: hubds-get setup-packet !
9589: dup setup-packet 6 + w!-le ( buffer buffer-length )
9590: 0 -rot setup-packet MPS-DCP my-usb-address controlxfer ( TRUE|FALSE )
9591: ;
9592: s" usb-enumerate.fs" INCLUDED
9593: : hub-configure-port ( port# -- )
9594: BEGIN ( port# )
9595: status-buffer 4 erase ( port# )
9596: status-buffer over control-hub-port-status-get drop ( port# )
9597: status-buffer w@-le 102 and 0= ( port# TRUE|FALSE )
9598: WHILE ( port# )
9599: REPEAT ( port# )
9600: po2pg 3 * ms \ wait for bPwrOn2PwrGood*3 ms
9601: dup control-hub-port-reset-set drop ( port# )
9602: BEGIN ( port# )
9603: status-buffer 4 erase ( port# )
9604: status-buffer over control-hub-port-status-get drop ( port# )
9605: status-buffer w@-le 10 and ( port# TRUE|FALSE )
9606: WHILE ( port# )
9607: REPEAT ( port# )
9608: status-buffer 4 erase ( port# )
9609: status-buffer over control-hub-port-status-get drop ( port# )
9610: status-buffer w@-le 103 and 103 <> ( port# TRUE|FALSE )
9611: s" Port status bits: " status-buffer w@-le usb-debug-print-val
9612: IF ( port# )
9613: drop
9614: s" Connect status: No device connected " usb-debug-print
9615: EXIT
9616: THEN
9617: status-buffer w@-le 200 and 4 lshift \ get speed bit
9618: dup to device-speed \ store speed bit
9619: control-std-set-address ( port# usb-addr TRUE|FALSE )
9620: 50 ms ( port# usb-addr TRUE|FALSE )
9621: debug-td ( port# usb-addr TRUE|FALSE )
9622: IF ( port# usb-addr )
9623: device-speed or ( port# usb-addr+speedbit )
9624: to new-device-address ( port# )
9625: to port-number
9626: dd-buffer @ DEVICE-DESCRIPTOR-LEN erase
9627: dd-buffer @ DEFAULT-CONTROL-MPS DEFAULT-CONTROL-MPS new-device-address
9628: control-std-get-device-descriptor ( TRUE|FALSE )
9629: IF
9630: dd-buffer @ DEVICE-DESCRIPTOR-TYPE-OFFSET + c@ ( descriptor-type )
9631: DEVICE-DESCRIPTOR-TYPE <> ( TRUE|FALSE )
9632: IF
9633: s" HUB: ERROR!! Invalid Device Descriptor for the new device"
9634: usb-debug-print
9635: ELSE
9636: dd-buffer @ DEVICE-DESCRIPTOR-MPS-OFFSET + c@ to mps
9637: dd-buffer @ DEVICE-DESCRIPTOR-LEN erase
9638: dd-buffer @ DEVICE-DESCRIPTOR-LEN mps new-device-address
9639: control-std-get-device-descriptor invert
9640: IF
9641: s" ** reading dev-descriptor failed ** " usb-debug-print
9642: THEN
9643: create-usb-device-tree
9644: THEN
9645: ELSE
9646: s" ERROR!! Failed to get device descriptor" usb-debug-print
9647: THEN
9648: ELSE ( port# )
9649: s" USB Set Adddress failed!!" usb-debug-print ( port# )
9650: s" Clearing Port Power..." usb-debug-print ( port# )
9651: control-hub-port-power-clear ( TRUE|FALSE )
9652: IF
9653: s" Port power down " usb-debug-print
9654: ELSE
9655: s" Unable to clear port power!!!" usb-debug-print
9656: THEN
9657: THEN
9658: ;
9659: : hub-enumerate ( -- )
9660: cd-buffer @ CONFIG-DESCRIPTOR-LEN erase
9661: cd-buffer @ CONFIG-DESCRIPTOR-LEN MPS-DCP my-usb-address
9662: control-std-get-configuration-descriptor drop
9663: cd-buffer @ 1+ c@ 2 <> IF
9664: s" Unable to read configuration descriptor" usb-debug-print
9665: EXIT
9666: THEN
9667: cd-buffer @ 4 + c@ 1 <> IF
9668: s" Not a valid HUB config descriptor" usb-debug-print
9669: EXIT
9670: THEN
9671: cd-buffer @ 5 + c@ to temp1 \ Store the configuration in temp1
9672: temp1 my-usb-address control-std-set-configuration drop
9673: my-usb-address to temp1
9674: hd-buffer 9 erase
9675: hd-buffer 9 control-get-hub-descriptor drop
9676: hd-buffer 2 + c@ to temp2 \ number of downstream ports
9677: s" HUB: Found " usb-debug-print
9678: s" number of downstream hub ports! : " temp2 usb-debug-print-val
9679: hd-buffer 5 + c@ to po2pg \ get bPwrOn2PwrGood
9680: temp2 1+ 1 DO
9681: i control-hub-port-power-set drop
9682: d# 20 ms
9683: LOOP
9684: d# 200 ms \ some devices need a long time (10s)
9685: temp2 1+ 1 DO
9686: s" hub-configure-port: " i usb-debug-print-val
9687: i hub-configure-port
9688: LOOP
9689: ;
9690: (allocate-mem)
9691: mps-property-set
9692: hub-enumerate
9693: (de-allocate-mem)
9694: �������� X 8usb-enumerate.fs : (hub-create) ( -- )
9695: mps port-number new-device-address port-number
9696: new-device set-space ( mps port-number usb-address )
9697: encode-int s" USB-ADDRESS" property ( mps port-number )
9698: s" Address Set" usb-debug-print
9699: encode-int s" reg" property ( mps )
9700: s" Port Number Set" usb-debug-print
9701: encode-int s" MPS-DCP" property
9702: s" MPS Set" usb-debug-print
9703: s" usb-hub.fs" INCLUDED
9704: s" Driver Included" usb-debug-print
9705: finish-device
9706: ;
9707: : (atapi-scsi-property-set) ( -- )
9708: dd-buffer @ e + c@ ( Manuf )
9709: dd-buffer @ f + c@ ( Manuf Prod )
9710: dd-buffer @ 10 + c@ ( Manuf Prod Serial-Num )
9711: cd-buffer @ 16 + w@-le ( Manuf Prod Serial-Num ep-mps )
9712: cd-buffer @ 14 + c@ ( Manuf Prod Serial-Num ep-mps ep-addr )
9713: cd-buffer @ 1d + w@-le ( Manuf Prod Serial-Num ep-mps ep-addr ep-mps )
9714: cd-buffer @ 1b + c@ ( Manuf Prod Serial-Num ep-mps ep-addr ep-mps ep-addr )
9715: mps port-number new-device-address port-number
9716: ( Manuf Prod Serial-Num ep-mps ep-addr ep-mps ep-addr
9717: mps port-num usb-addr port-num )
9718: new-device set-space
9719: ( Manuf Prod Serial-Num ep-mps ep-addr ep-mps ep-addr
9720: mps port-num usb-addr )
9721: encode-int s" USB-ADDRESS" property
9722: ( Manuf Prod Serial-Num ep-mps ep-addr ep-mps ep-addr
9723: mps port-num )
9724: encode-int s" reg" property
9725: ( Manuf Prod Serial-Num ep-mps ep-addr ep-mps ep-addr
9726: mps )
9727: encode-int s" MPS-DCP" property
9728: 2 0 DO
9729: dup 80 and IF
9730: 7f and encode-int
9731: s" BULK-IN-EP-ADDR" property
9732: encode-int s" MPS-BULKIN" property
9733: ELSE
9734: encode-int s" BULK-OUT-EP-ADDR" property
9735: encode-int s" MPS-BULKOUT" property
9736: THEN
9737: LOOP ( Manuf Prod Serial-Num )
9738: encode-int s" iSerialNumber" property ( Manuf Prod )
9739: encode-int s" iProduct" property ( Manuf )
9740: encode-int s" iManufacturer" property
9741: ;
9742: : (device-classify)
9743: cd-buffer @ BULK-CONFIG-DESCRIPTOR-LEN erase
9744: cd-buffer @ BULK-CONFIG-DESCRIPTOR-LEN mps new-device-address
9745: control-std-get-configuration-descriptor
9746: IF
9747: cd-buffer @ 1+ c@ ( Descriptor-type )
9748: 2 = IF
9749: cd-buffer @ 10 + c@ ( protocol )
9750: cd-buffer @ f + c@ ( protocol subclass )
9751: cd-buffer @ e + c@ ( protocol subclass class )
9752: TRUE
9753: ELSE
9754: s" Not a valid configuration descriptor!!" usb-debug-print
9755: FALSE
9756: THEN
9757: ELSE
9758: s" Unable to read configuration descriptor!!" usb-debug-print
9759: FALSE
9760: THEN
9761: ;
9762: : (atapi-8020-create) ( -- )
9763: (atapi-scsi-property-set)
9764: s" usb-storage.fs" INCLUDED
9765: finish-device
9766: ;
9767: : (atapi-8070-create) ( -- )
9768: (atapi-scsi-property-set)
9769: s" usb-storage.fs" INCLUDED
9770: finish-device
9771: ;
9772: : (scsi-create) ( -- )
9773: s" SCSI-CREATE " usb-debug-print
9774: dd-buffer @ 8 + w@-le 4b4 = \ VendorID = CYPRESS ?
9775: IF
9776: dd-buffer @ a + w@-le 6830 = \ Device = CY7C68300 ?
9777: IF
9778: d# 20 ms
9779: mps new-device-address 0 0 0 ( MPS fun-addr dir data-buff data-len )
9780: control-bulk-reset ( TRUE|FALSE )
9781: d# 100 ms
9782: mps new-device-address 0 0 0 ( TRUE|FALSE MPS fun-addr dir data-buff data-len )
9783: control-bulk-reset ( TRUE|FALSE TRUE|FALSE )
9784: and invert
9785: IF
9786: ." ** BULK-RESET failed **" cr
9787: THEN
9788: d# 20 ms
9789: THEN
9790: THEN
9791: 0 ch-buffer ! \ preset a clean response
9792: mps new-device-address 0 ch-buffer 1 control-std-get-maxlun ( TRUE|FALSE )
9793: IF
9794: ELSE
9795: s" ERROR in GET-MAX-LUN " usb-debug-print
9796: 0 ch-buffer ! \ clear invalid numbers
9797: cd-buffer @ 5 + c@ to temp1
9798: temp1 new-device-address control-std-set-configuration drop
9799: THEN
9800: 0 ( counter )
9801: begin
9802: dup 8 < ( counter flag ) \ max 8 * 500 ms
9803: ch-buffer c@ f > ( counter flag flag ) \ is MuxLUN above limit ?
9804: AND ( counter flag )
9805: while
9806: d# 500 ms \ this device is not yet ready
9807: 0 ch-buffer ! \ preset a clean response
9808: mps new-device-address 0 ch-buffer 1 control-std-get-maxlun ( TRUE|FALSE )
9809: not
9810: IF
9811: s" ** ERROR in GET-MAX-LUN ** " usb-debug-print
9812: drop 10 \ replace counter to force loop end
9813: THEN
9814: 1+ ( counter+1 )
9815: repeat
9816: drop
9817: ch-buffer c@ dup 0= swap f > or IF
9818: s" + LUN: " ch-buffer c@ usb-debug-print-val
9819: (atapi-scsi-property-set)
9820: s" usb-storage.fs" INCLUDED
9821: finish-device
9822: ELSE
9823: s" - LUN: " ch-buffer c@ usb-debug-print-val
9824: (atapi-scsi-property-set)
9825: s" usb-storage-wrapper.fs" INCLUDED
9826: finish-device
9827: THEN
9828: ;
9829: : (classify-storage) ( interface-protocol interface-subclass -- )
9830: s" USB: Mass Storage Device Found!" usb-debug-print
9831: swap 50 <> IF
9832: s" USB storage: Protocol is not 50." usb-debug-print
9833: drop EXIT
9834: THEN
9835: CASE
9836: 02 OF (atapi-8020-create) s" ATAPI Interface " usb-debug-print ENDOF
9837: 05 OF (atapi-8070-create) s" ATAPI Interface " usb-debug-print ENDOF
9838: 06 OF (scsi-create) s" SCSI Interface " usb-debug-print ENDOF
9839: dup OF s" USB storage: Unsupported sub-class code." usb-debug-print ENDOF
9840: ENDCASE
9841: ;
9842: : (keyboard-create) ( -- )
9843: cd-buffer @ 1f + c@ ( ep-mps )
9844: cd-buffer @ 1d + c@ ( ep-mps ep-addr )
9845: mps port-number new-device-address port-number
9846: new-device set-space ( ep-mps ep-addr mps port-num usb-addr )
9847: encode-int s" USB-ADDRESS" property ( ep-mps ep-addr mps port-num )
9848: encode-int s" reg" property ( ep-mps ep-addr mps )
9849: encode-int s" MPS-DCP" property ( ep-mps ep-addr )
9850: 7f and encode-int s" INT-IN-EP-ADDR" property
9851: encode-int s" MPS-INTIN" property
9852: new-device-address \ device-speed
9853: s" usb-keyboard.fs" INCLUDED
9854: finish-device
9855: ;
9856: : (mouse-create) ( -- )
9857: mps port-number new-device-address port-number
9858: new-device set-space ( mps port-num usb-addr )
9859: encode-int s" USB-ADDRESS" property ( mps port-num )
9860: encode-int s" reg" property ( mps )
9861: encode-int s" MPS-DCP" property
9862: s" usb-mouse.fs" INCLUDED
9863: finish-device
9864: ;
9865: : (classify-by-interface) ( -- )
9866: (device-classify) IF
9867: CASE
9868: 08 OF
9869: (classify-storage)
9870: ENDOF
9871: 03 OF
9872: s" USB: HID Found!" usb-debug-print
9873: 01 =
9874: IF
9875: case
9876: 01 of
9877: s" USB keyboard!" usb-debug-print
9878: (keyboard-create)
9879: endof
9880: 02 of
9881: s" USB mouse!" usb-debug-print
9882: (mouse-create)
9883: endof
9884: dup of
9885: s" USB: unsupported HID!" usb-debug-print
9886: endof
9887: endcase
9888: ELSE
9889: s" USB: unsupported HID!" usb-debug-print
9890: THEN
9891: ENDOF
9892: dup OF
9893: s" USB: unsupported interface type." usb-debug-print
9894: 2drop
9895: ENDOF
9896: ENDCASE
9897: THEN
9898: ;
9899: : create-usb-device-tree ( -- )
9900: dd-buffer @ DEVICE-DESCRIPTOR-DEVCLASS-OFFSET + c@ ( Device-class )
9901: CASE
9902: HUB-DEVICE-CLASS OF s" USB: HUB found" usb-debug-print
9903: (hub-create)
9904: ENDOF
9905: NO-CLASS OF
9906: (classify-by-interface)
9907: ENDOF
9908: DUP OF
9909: s" USB: Unknown device found." usb-debug-print
9910: ENDOF
9911: ENDCASE
9912: uDOC-present 0f and to uDOC-present \ remove uDOC processing flag
9913: ;
9914: �������� .� .M 0usb-storage.fs s" storage" device-name
9915: s" block" device-type
9916: 2 encode-int s" #address-cells" property
9917: 0 encode-int s" #size-cells" property
9918: 8 VALUE mps-bulk-out
9919: 8 VALUE mps-bulk-in
9920: 8 VALUE mps-dcp
9921: 0 VALUE bulk-in-ep
9922: 0 VALUE bulk-out-ep
9923: 0 VALUE bulk-in-toggle
9924: 0 VALUE bulk-out-toggle
9925: 0 VALUE lun
9926: 0 VALUE my-usb-address
9927: 0 VALUE csw-buffer
9928: 0e VALUE cfg-buffer
9929: 0 VALUE response-buffer
9930: 0 VALUE command-buffer
9931: 0 VALUE resp-size
9932: 0 VALUE resp-buffer
9933: INSTANCE VARIABLE ihandle-bulk
9934: INSTANCE VARIABLE ihandle-deblocker
9935: INSTANCE VARIABLE flag
9936: INSTANCE VARIABLE count
9937: 0 VALUE max-transfer
9938: 200 VALUE block-size \ default (512 Bytes)
9939: -1 VALUE max-block-num \ highest reported block-number
9940: 0f CONSTANT SCSI-COMMAND-OFFSET
9941: s" usb-storage-support.fs" INCLUDED
9942: 0 VALUE bulk-cnt
9943: 0 VALUE bulk-cmd-len
9944: 0 VALUE itest
9945: : do-bulk-command ( resp-buffer resp-size -- TRUE | FALSE )
9946: TO resp-size
9947: TO resp-buffer
9948: usb-debug-flag
9949: IF
9950: command-buffer 0E + c@ TO bulk-cmd-len
9951: s" cmd-length: " bulk-cmd-len usb-debug-print-val
9952: command-buffer bulk-cmd-len 0E + dump cr
9953: THEN
9954: 6 TO bulk-cnt \ 2 old value
9955: FALSE dup
9956: BEGIN
9957: 0=
9958: WHILE
9959: drop
9960: 1 1 bulk-out-toggle command-buffer 1f mps-bulk-out
9961: my-usb-address bulk-out-ep 7 lshift or
9962: rw-endpoint swap ( TRUE toggle | FALSE toggle )
9963: to bulk-out-toggle ( TRUE | FALSE )
9964: IF
9965: s" resp-size : " resp-size usb-debug-print-val
9966: resp-size 0<>
9967: IF \ do we need a response ?!
9968: 0 1 bulk-in-toggle resp-buffer resp-size mps-bulk-in
9969: my-usb-address bulk-in-ep 7 lshift or
9970: rw-endpoint swap ( TRUE toggle | FALSE toggle )
9971: to bulk-in-toggle ( TRUE | FALSE )
9972: ELSE
9973: TRUE
9974: THEN
9975: IF \ read the bulk CSW
9976: 0 1 bulk-in-toggle csw-buffer D mps-bulk-in
9977: my-usb-address bulk-in-ep 7 lshift or
9978: rw-endpoint swap ( TRUE toggle | FALSE toggle )
9979: to bulk-in-toggle ( TRUE | FALSE )
9980: IF
9981: s" Command successful." usb-debug-print
9982: TRUE dup
9983: ELSE
9984: s" Command failed in CSW stage" usb-debug-print
9985: FALSE dup
9986: THEN
9987: ELSE
9988: s" Command failed while receiving DATA... read CSW..." usb-debug-print
9989: 0 1 bulk-in-toggle csw-buffer D mps-bulk-in
9990: my-usb-address bulk-in-ep 7 lshift or
9991: rw-endpoint swap ( TRUE toggle | FALSE toggle )
9992: to bulk-in-toggle ( TRUE | FALSE )
9993: IF
9994: s" OK evaluate the CSW ..." usb-debug-print
9995: csw-buffer c + c@ dup TO itest
9996: s" CSW Status: " itest usb-debug-print-val
9997: dup
9998: 2 =
9999: IF \ Phase Error
10000: s" Phase error do a bulk reset-recovery ..." usb-debug-print
10001: bulk-out-ep bulk-in-ep my-usb-address
10002: bulk-reset-recovery-procedure
10003: THEN
10004: 1 =
10005: IF \ Command failed
10006: s" Command Failed do a bulk-reset-recovery" usb-debug-print
10007: bulk-out-ep bulk-in-ep my-usb-address
10008: bulk-reset-recovery-procedure
10009: THEN
10010: THEN
10011: FALSE dup
10012: THEN
10013: ELSE
10014: s" Command failed while Sending CBW ..." usb-debug-print
10015: FALSE dup
10016: THEN
10017: bulk-cnt 1 - TO bulk-cnt
10018: bulk-cnt 0=
10019: IF
10020: 2drop FALSE dup
10021: THEN
10022: REPEAT
10023: ;
10024: scsi-open
10025: usb-debug-flag to scsi-param-debug \ copy debug flag
10026: 24 CONSTANT inquiry-length \ was 20
10027: : inquiry ( -- )
10028: s" usb-storage: inquiry" usb-debug-print
10029: command-buffer 1 inquiry-length 80 lun scsi-length-inquiry
10030: build-cbw
10031: inquiry-length command-buffer SCSI-COMMAND-OFFSET + ( alloc-len address )
10032: scsi-build-inquiry
10033: response-buffer inquiry-length erase \ provide clean buffer
10034: response-buffer inquiry-length do-bulk-command
10035: IF
10036: s" Successfully read INQUIRY data" usb-debug-print
10037: 0d emit space space
10038: response-buffer c@ \ get 'Peripheral Device Type' (PDT)
10039: CASE
10040: 0 OF ." BLOCK-DEV: " ENDOF \ SCSI Block Device
10041: 5 OF ." CD-ROM : " ENDOF
10042: 7 OF ." OPTICAL : " ENDOF
10043: e OF ." RED-BLOCK: " ENDOF \ SCSI Reduced Block Device
10044: dup dup OF ." ? (" . 8 emit 29 emit 2 spaces ENDOF
10045: ENDCASE
10046: space
10047: response-buffer 8 + 16 encode-string s" ident-str" property
10048: response-buffer .inquiry-text
10049: ELSE
10050: 5040 error" (USB) Device transaction error. (inquiry)"
10051: ABORT
10052: THEN
10053: ;
10054: : read-capacity ( -- )
10055: s" usb-storage: read-capacity" usb-debug-print
10056: command-buffer 1 8 80 lun scsi-length-read-cap-10
10057: build-cbw
10058: command-buffer SCSI-COMMAND-OFFSET + ( address )
10059: scsi-build-read-cap-10
10060: lun 5 lshift
10061: command-buffer SCSI-COMMAND-OFFSET + ( address )
10062: read-cap-10>reserved1 c!
10063: response-buffer 8 erase \ provide clean buffer
10064: response-buffer 8 do-bulk-command
10065: IF
10066: s" Successfully read READ CAPACITY data" usb-debug-print
10067: ELSE
10068: 5040 error" (USB) Device transaction error. (capacity)"
10069: ABORT
10070: THEN
10071: ;
10072: : test-unit-ready ( -- TRUE | FALSE )
10073: command-buffer 1 0 80 lun scsi-length-test-unit-ready \ was: 0c
10074: build-cbw
10075: command-buffer SCSI-COMMAND-OFFSET + ( address )
10076: scsi-build-test-unit-ready ( cdb -- )
10077: response-buffer 0 do-bulk-command
10078: IF
10079: s" Successfully read test unit ready data" usb-debug-print
10080: s" Test Unit STATUS availabe in csw-buffer" usb-debug-print
10081: csw-buffer 0c + c@ 0= IF
10082: s" Test Unit Command Successfully Executed" usb-debug-print
10083: TRUE ( TRUE )
10084: ELSE
10085: s" Test Unit Command Failed to execute" usb-debug-print
10086: FALSE ( FALSE )
10087: THEN
10088: ELSE
10089: 5040 error" (USB) Device transaction error. (test-unit-ready)"
10090: ABORT
10091: THEN
10092: ;
10093: : wait-for-unit-ready ( -- TRUE|FALSE )
10094: s" --> WAIT: test-unit-ready ... " usb-debug-print
10095: d# 100 ( count ) \ up to 10 seconds
10096: BEGIN ( count )
10097: dup 0> ( count flag )
10098: test-unit-ready \ dup IF 2b ELSE 2d THEN emit
10099: not and ( count flag )
10100: WHILE
10101: 1- ( count )
10102: d# 100 wait-proceed \ wait 100 ms
10103: REPEAT ( count )
10104: 0=
10105: IF
10106: s" ** Device not ready ** " usb-debug-print
10107: FALSE
10108: ELSE
10109: TRUE
10110: THEN
10111: ;
10112: : request-sense ( -- )
10113: s" request-sense: Command ready." usb-debug-print
10114: command-buffer 1 12 80 lun scsi-length-request-sense
10115: build-cbw
10116: 12 command-buffer SCSI-COMMAND-OFFSET + ( alloc-len cdb )
10117: scsi-build-request-sense ( alloc-len cdb -- )
10118: response-buffer 12 do-bulk-command
10119: IF
10120: s" Read Sense data successfully" usb-debug-print
10121: ELSE
10122: 5040 error" (USB) Device transaction error. (request-sense)"
10123: ABORT
10124: THEN
10125: ;
10126: : start ( -- )
10127: command-buffer 1 0 80 lun scsi-length-start-stop-unit
10128: build-cbw
10129: command-buffer SCSI-COMMAND-OFFSET + ( cdb )
10130: scsi-const-start scsi-build-start-stop-unit ( state# cdb -- )
10131: response-buffer 0 do-bulk-command
10132: IF
10133: s" Start successfully" usb-debug-print
10134: ELSE
10135: 5040 error" (USB) Device transaction error. (start)"
10136: ABORT
10137: THEN
10138: ;
10139: : stop ( -- )
10140: command-buffer 1 0 80 lun scsi-length-start-stop-unit
10141: build-cbw
10142: command-buffer SCSI-COMMAND-OFFSET + ( cdb )
10143: scsi-const-stop scsi-build-start-stop-unit ( state# cdb -- )
10144: response-buffer 0 do-bulk-command
10145: IF
10146: s" Stop successfully" usb-debug-print
10147: ELSE
10148: 5040 error" (USB) Device transaction error. (stop)"
10149: ABORT
10150: THEN
10151: ;
10152: 0 VALUE temp1
10153: 0 VALUE temp2
10154: 0 VALUE temp3
10155: : seek ( pos-lo pos-hi -- status )
10156: 2dup lxjoin max-block-num block-size * >
10157: IF
10158: ." ** Seek Error: pos too large ("
10159: dup . over . ." -> " max-block-num block-size * .
10160: ." ) ** " cr
10161: -1 \ see spec-1275 page 183
10162: ELSE
10163: s" seek" ihandle-deblocker @ $call-method
10164: THEN
10165: ;
10166: : read ( address length -- actual )
10167: s" read" ihandle-deblocker @ $call-method
10168: ;
10169: : read-blocks ( address block# #blocks -- #read-blocks )
10170: 2dup + max-block-num >
10171: IF
10172: ." ** Requested block too large "
10173: 2dup + ." (" .d ." -> " max-block-num .d
10174: bs emit ." ) ... read aborted **" cr
10175: nip nip \ leave #blocks on stack
10176: ELSE
10177: block-size * command-buffer ( address block# transfer-len command-buffer )
10178: 1 2 pick 80 lun 0c build-cbw ( address block# transfer-len )
10179: dup to temp1 ( address block# transfer-len )
10180: block-size / ( address block# #blocks )
10181: command-buffer ( address block# #blocks command-addr )
10182: SCSI-COMMAND-OFFSET + ( address block# #blocks cdb )
10183: scsi-build-read? ( block# #blocks cdb -- length )
10184: command-buffer 0e + c! \ update bCBWCBLength-field with resulting CDB length
10185: temp1 ( address length )
10186: do-bulk-command
10187: IF
10188: s" Read data successfully" usb-debug-print
10189: ELSE
10190: 5040 error" (USB) Device transaction error. (read-blocks)"
10191: ABORT
10192: THEN
10193: temp1 block-size / ( #read-blocks )
10194: THEN
10195: ;
10196: d# 800 CONSTANT media-ready-retry
10197: : make-media-ready ( -- )
10198: s" usb-storage: make-media-ready" usb-debug-print
10199: 0 flag !
10200: 0 count !
10201: BEGIN
10202: flag @ 0=
10203: WHILE
10204: test-unit-ready IF
10205: s" Media ready for access." usb-debug-print
10206: 1 flag !
10207: ELSE
10208: count @ 1 + count !
10209: count @ media-ready-retry = IF
10210: 1 flag !
10211: 5000 error" (USB) Media or drive not ready for this blade."
10212: ABORT
10213: THEN
10214: request-sense
10215: response-buffer scsi-get-sense-ID? ( addr -- false | sense-ID true )
10216: IF
10217: ffff00 AND \ remaining: sense-key ASC
10218: CASE
10219: 023a00 OF \ MEDIUM NOT PRESENT (02 3a 00)
10220: 5010 error" (USB) No Media found! Check for the drawer/inserted media."
10221: ABORT
10222: ENDOF
10223: 020400 OF \ LOGICAL DRIVE NOT READY - INITIALIZATION REQUIRED
10224: 5010 error" (USB) No Media found! Check for the drawer/inserted media."
10225: ABORT
10226: ENDOF
10227: 033000 OF \ CANNOT READ MEDIUM - UNKNOWN FORMAT
10228: 5020 error" (USB) Unknown media format."
10229: ABORT
10230: ENDOF
10231: ENDCASE
10232: THEN
10233: THEN
10234: d# 10 ms \ wait maximum 10ms * 800 (=8s)
10235: REPEAT
10236: usb-debug-flag IF
10237: ." make-media-ready finished after "
10238: count @ decimal . hex ." tries." cr
10239: THEN
10240: ;
10241: : .showcap
10242: space
10243: test-unit-ready drop \ initial command
10244: request-sense
10245: response-buffer scsi-get-sense-ID? ( addr -- false | sense-ID true )
10246: IF
10247: dup FFFF00 and 023a00 = ( sense-id flag )
10248: IF
10249: uDOC-failure?
10250: 023a02 = \ see sense-codes SPC-3 clause 4.5.6
10251: IF
10252: ." Tray Open!"
10253: ELSE
10254: ." No Media"
10255: THEN
10256: ELSE ( sense-id )
10257: drop
10258: wait-for-unit-ready
10259: IF
10260: read-capacity
10261: response-buffer scsi-get-capacity-10 space .capacity-text
10262: ELSE
10263: request-sense
10264: response-buffer scsi-get-sense-ID? ( addr -- false | sense-ID true )
10265: IF
10266: dup ff0000 and 040000 = \ sense-code = 4 ?
10267: IF
10268: ." *HW-ERROR*"
10269: uDOC-failure?
10270: ELSE
10271: dup FFFF00 and 023a00 = IF uDOC-failure? THEN
10272: CASE ( sense-ID )
10273: 023a00 OF ." No Media " ENDOF
10274: 023a02 OF ." Tray Open! " ENDOF
10275: dup OF ." ? " ENDOF
10276: ENDCASE
10277: THEN
10278: THEN
10279: THEN
10280: THEN
10281: ELSE
10282: ." ?? "
10283: THEN
10284: ;
10285: : init-dev-ready
10286: test-unit-ready drop
10287: 4 >r \ loop-counter
10288: 0 0
10289: BEGIN
10290: 2drop
10291: request-sense
10292: response-buffer scsi-get-sense-data ( ascq asc sense-key )
10293: 0<> r> 1- dup >r 0<> AND \ loop-counter or sense-key
10294: WHILE
10295: REPEAT
10296: 2drop
10297: r> drop
10298: ;
10299: scsi-close \ no further scsi words required
10300: : (init-block-size)
10301: read-capacity
10302: response-buffer l@ dup 0<>
10303: IF
10304: to max-block-num \ highest block-number
10305: ELSE
10306: -1 to max-block-num \ indeterminate
10307: THEN
10308: response-buffer 4 +
10309: l@ to block-size
10310: s" usb-storage: block-size=" block-size usb-debug-print-val
10311: ;
10312: : open ( -- TRUE )
10313: s" usb-storage: open" usb-debug-print
10314: ihandle-bulk s" bulk" (open-package)
10315: make-media-ready
10316: (init-block-size) \ Init block-size before opening the deblocker
10317: ihandle-deblocker s" deblocker" (open-package)
10318: s" disk-label" find-package IF ( phandle )
10319: usb-debug-flag IF ." my-args for disk-label = " my-args swap . . cr THEN
10320: my-args rot interpose
10321: THEN
10322: TRUE ( TRUE )
10323: ;
10324: : close ( -- )
10325: ihandle-deblocker (close-package)
10326: ihandle-bulk (close-package)
10327: ;
10328: : (init-device-name) ( -- )
10329: init-dev-ready
10330: inquiry
10331: response-buffer c@
10332: CASE
10333: 1 OF .showcap s" tape" device-name ENDOF
10334: 5 OF .showcap s" cdrom" device-name s" CDROM found" usb-debug-print ENDOF
10335: 0 OF .showcap s" sbc-dev" device-name s" SBC Direct access device" usb-debug-print ENDOF
10336: 7 OF .showcap s" optical" device-name s" Optical memory found" usb-debug-print ENDOF
10337: 0E OF .showcap s" rbc-dev" device-name s" RBC direct acces device found" usb-debug-print ENDOF
10338: ENDCASE
10339: ;
10340: : (initial-setup)
10341: ihandle-bulk s" bulk" (open-package)
10342: device-init
10343: (init-device-name)
10344: set-drive-alias
10345: 200 to block-size \ Default block-size, will be overwritten in "open"
10346: 10000 to max-transfer
10347: ihandle-bulk (close-package)
10348: ;
10349: (initial-setup)
10350: �������� 8
10351: � 8usb-storage-support.fs : rw-endpoint
10352: s" rw-endpoint" $call-parent
10353: ;
10354: : controlxfer ( dir addr dlen setup-packet MPS ep-fun --- TRUE|FALSE )
10355: s" controlxfer" $call-parent
10356: ;
10357: : control-std-get-configuration-descriptor
10358: s" control-std-get-configuration-descriptor" $call-parent
10359: ;
10360: : control-std-set-configuration ( configvalue FuncAddr -- TRUE | FALSE )
10361: s" control-std-set-configuration" $call-parent ( TRUE | FALSE )
10362: ;
10363: : bulk-reset-recovery-procedure ( bulk-out-endp bulk-in-endp usb-addr -- )
10364: s" bulk-reset-recovery-procedure" $call-parent
10365: ;
10366: : build-cbw ( address tag transfer-len direction lun command-len -- )
10367: s" build-cbw" ihandle-bulk @ $call-method
10368: ;
10369: : analyze-csw ( address -- residue tag TRUE | reason FALSE )
10370: s" analyze-csw" ihandle-bulk @ $call-method
10371: ;
10372: : device-init ( -- )
10373: s" Starting to initialize usb-storage device" usb-debug-print
10374: s" USB-ADDRESS" get-my-property ( TRUE | propaddr proplen FALSE )
10375: IF
10376: s" not possible" usb-debug-print
10377: ELSE
10378: decode-int nip nip to my-usb-address
10379: THEN
10380: s" MPS-BULKOUT" get-my-property ( TRUE | propaddr proplen FALSE )
10381: IF
10382: s" not possible" usb-debug-print
10383: ELSE
10384: decode-int nip nip to mps-bulk-out
10385: THEN
10386: s" MPS-BULKIN" get-my-property ( TRUE | propaddr proplen FALSE )
10387: IF
10388: s" not possible" usb-debug-print
10389: ELSE
10390: decode-int nip nip to mps-bulk-in
10391: THEN
10392: s" BULK-IN-EP-ADDR" get-my-property ( TRUE | propaddr proplen FALSE )
10393: IF
10394: s" not possible" usb-debug-print
10395: ELSE
10396: decode-int nip nip to bulk-in-ep
10397: THEN
10398: s" BULK-OUT-EP-ADDR" get-my-property ( TRUE | propaddr proplen FALSE )
10399: IF
10400: s" not possible" usb-debug-print
10401: ELSE
10402: decode-int nip nip to bulk-out-ep
10403: THEN
10404: s" MPS-DCP" get-my-property ( TRUE | propaddr proplen FALSE )
10405: IF
10406: s" Not possible" usb-debug-print
10407: ELSE
10408: decode-int nip nip to mps-dcp
10409: THEN
10410: s" LUN" get-my-property ( TRUE | propaddr proplen FALSE )
10411: IF
10412: s" NOT Possible to extract LUN" usb-debug-print
10413: ELSE
10414: decode-int nip nip to lun
10415: THEN
10416: s" Extracted properties inherited from parent." usb-debug-print
10417: 40 alloc-mem to command-buffer
10418: 80 alloc-mem to response-buffer
10419: 10 alloc-mem to csw-buffer
10420: 8 alloc-mem to cfg-buffer
10421: s" Allocated buffers." usb-debug-print
10422: cfg-buffer 8 mps-dcp my-usb-address ( buffer len mps fun-addr )
10423: control-std-get-configuration-descriptor ( TRUE | FALSE )
10424: drop
10425: s" Configuration descriptor extracted." usb-debug-print
10426: cfg-buffer 5 + c@ my-usb-address ( configvalue fun-addr )
10427: control-std-set-configuration ( TRUE | FALSE )
10428: s" usb-storage: Set config returned: " rot usb-debug-print-val
10429: ;
10430: : (open-package) ( ihandle-var name-str name-len -- )
10431: find-package IF ( ihandle-var phandle )
10432: 0 0 rot open-package ( ihandle-var ihandle )
10433: swap !
10434: ELSE
10435: s" Support package not found" usb-debug-print
10436: THEN
10437: ;
10438: : (close-package) ( ihandle-var -- )
10439: dup @ close-package
10440: 0 swap !
10441: ;
10442: �������� x 3 8usb-storage-wrapper.fs s" scsi" device-name
10443: s" block-type" device-type
10444: 1 encode-int s" #address-cells" property
10445: 0 encode-int s" #size-cells" property
10446: : encode-unit 1 hex-encode-unit ;
10447: : decode-unit 1 hex-decode-unit ;
10448: 1 chars alloc-mem VALUE ch-buffer
10449: 8 VALUE mps-dcp
10450: 0 VALUE port-number
10451: 0 VALUE my-usb-address
10452: : control-std-get-maxlun
10453: s" control-std-get-maxlun" $call-parent
10454: ;
10455: : control-std-get-configuration-descriptor
10456: s" control-std-get-configuration-descriptor" $call-parent
10457: ;
10458: : rw-endpoint
10459: s" rw-endpoint" $call-parent
10460: ;
10461: : controlxfer ( dir addr dlen setup-packet MPS ep-fun -- TRUE|FALSE )
10462: s" controlxfer" $call-parent
10463: ;
10464: : control-std-set-configuration
10465: s" control-std-set-configuration" $call-parent
10466: ;
10467: : extract-properties ( -- )
10468: s" USB-ADDRESS" get-inherited-property ( prop-addr prop-len FALSE | TRUE )
10469: IF
10470: s" notpossible" usb-debug-print
10471: ELSE
10472: decode-int nip nip to my-usb-address
10473: THEN
10474: s" MPS-DCP" get-inherited-property ( prop-addr prop-len FALSE | TRUE )
10475: IF
10476: s" MPS-DCP property not found.Assume 8 as MAX PACKET SIZE" usb-debug-print
10477: s" for the default control pipe" usb-debug-print
10478: 8 to mps-dcp
10479: ELSE
10480: s" MPS-DCP property found!!" usb-debug-print
10481: decode-int nip nip to mps-dcp
10482: THEN
10483: s" reg" get-inherited-property ( prop-addr prop-len FLASE | TRUE )
10484: IF
10485: s" notpossible" usb-debug-print
10486: ELSE
10487: decode-int nip nip to port-number
10488: THEN
10489: ;
10490: : create-tree ( -- )
10491: mps-dcp my-usb-address 0 ch-buffer 1 ( MPS fun-addr dir data-buff data-len )
10492: control-std-get-maxlun ( TRUE | FALSE )
10493: IF
10494: s" GET-MAX-LUN IS WORKING :" usb-debug-print
10495: ELSE
10496: s" ERROR in GET-MAX-LUN " usb-debug-print
10497: THEN
10498: ch-buffer c@ 1 + 0 ( max-lun+1 0 )
10499: DO
10500: s" iManufacturer" get-inherited-property drop ( prop-addr prop-len TRUE )
10501: decode-int nip nip ( iManu )
10502: s" iProduct" get-inherited-property drop
10503: decode-int nip nip ( iManu iProd )
10504: s" iSerialNumber" get-inherited-property drop
10505: decode-int nip nip ( iManu iProd iSerNum )
10506: s" MPS-BULKOUT" get-inherited-property drop
10507: decode-int nip nip ( iManu iProd iSerNum MPS-BULKOUT )
10508: s" BULK-OUT-EP-ADDR" get-inherited-property drop
10509: decode-int nip nip ( iManu iProd iSerNum MPS-BULKOUT BULK-OUT-EP-ADDR )
10510: s" MPS-BULKIN" get-inherited-property drop
10511: ( iManu iProd iSerNum MPS-BULKOUT BULK-OUT-EP-ADDR prop-addr prop-len
10512: TRUE | FALSE )
10513: decode-int nip nip
10514: s" BULK-IN-EP-ADDR" get-inherited-property drop
10515: ( iManu iProd iSernum MPS-BULKOUT BULK-OUT-EP-ADDR MPS-BULKIN prop-addr
10516: prop-len TRUE | FALSE )
10517: decode-int nip nip
10518: ( iManu iProd iSernum MPS-BULKOUT BULK-OUT-EP-ADDR MPS-BULKIN
10519: BULKIN-EP-ADDR )
10520: mps-dcp port-number my-usb-address I
10521: ( iManu iProd iSernum MPS-BULKOUT BULK-OUT-EP-ADDR MPS-BULKIN
10522: BULKIN-EP-ADDR mps-dcp port-address my-usb-address lun-number )
10523: new-device
10524: ( iManu iProd iSernum MPS-BULKOUT BULK-OUT-EP-ADDR MPS-BULKIN
10525: BULKIN-EP-ADDR mps-dcp port-address my-usb-address lun-number )
10526: set-space
10527: ( iManu iProd iSernum MPS-BULKOUT BULK-OUT-EP-ADDR MPS-BULKIN
10528: BULKIN-EP-ADDR mps-dcp port-number my-usb-address )
10529: encode-int s" USB-ADDRESS" property
10530: ( iManu iProd iSernum MPS-BULKOUT BULK-OUT-EP-ADDR MPS-BULKIN
10531: BULKIN-EP-ADDR mps-dcp port-number )
10532: encode-int s" reg" property
10533: encode-int s" MPS-DCP" property
10534: ( iManu iProd iSernum MPS-BULKOUT BULK-OUT-EP-ADDR MPS-BULKIN
10535: BULKIN-EP-ADDR )
10536: I encode-int s" LUN" property
10537: ( iManu iProd iSernum MPS-BULKOUT BULK-OUT-EP-ADDR MPS-BULKIN
10538: BULKIN-EP-ADDR )
10539: encode-int s" BULK-IN-EP-ADDR" property
10540: encode-int s" MPS-BULKIN" property
10541: encode-int s" BULK-OUT-EP-ADDR" property
10542: encode-int s" MPS-BULKOUT" property ( iManu iProd iSerNum )
10543: encode-int s" iSerialNumber" property ( iManu iProd )
10544: encode-int s" iProduct" property ( iManu )
10545: encode-int s" iManufacturer" property ( -- )
10546: s" usb-storage.fs" INCLUDED
10547: finish-device
10548: LOOP
10549: ;
10550: extract-properties \ Extract the properties from parent
10551: create-tree \ this method creates the node for every lun with properties
10552: �������� *� * 0usb-keyboard.fs s" keyboard" device-name
10553: s" keyboard" device-type
10554: ." USB Keyboard" cr
10555: 3 encode-int s" assigned-addresses" property
10556: 1 encode-int s" reg" property
10557: 1 encode-int s" configuration#" property
10558: s" EN" encode-string s" language" property
10559: 1 constant NumLk
10560: 2 constant CapsLk
10561: 4 constant ScrLk
10562: 00 value kbd-addr
10563: to kbd-addr \ save speed bit
10564: 8 value mps-dcp
10565: 8 constant DEFAULT-CONTROL-MPS
10566: 8 chars alloc-mem value setup-packet
10567: 8 chars alloc-mem value kbd-report
10568: 4 chars alloc-mem value multi-key
10569: 0 value cfg-buffer
10570: 0 value led-state
10571: 0 value temp1
10572: 0 value temp2
10573: 0 value temp3
10574: 0 value ret
10575: 0 value scancode
10576: 0 value kbd-shift
10577: 0 value kbd-scan
10578: 0 value key-old
10579: 0 value expire-ms
10580: 0 value mps-int-in
10581: 0 value int-in-ep
10582: 0 value int-in-toggle
10583: kbd-addr \ give speed bit to include file
10584: s" usb-kbd-device-support.fs" included
10585: : control-cls-set-report ( reportvalue FuncAddr -- TRUE|FALSE )
10586: to temp1
10587: to temp2
10588: 2109000200000100 setup-packet !
10589: temp2 kbd-data l!-le
10590: 1 kbd-data 1 setup-packet DEFAULT-CONTROL-MPS temp1 controlxfer
10591: ;
10592: : control-cls-get-report ( data-buffer data-len MPS FuncAddr -- TRUE|FALSE )
10593: to temp1
10594: to temp2
10595: to temp3
10596: a101000100000000 setup-packet !
10597: temp3 setup-packet 6 + w!-le
10598: 0 swap temp3 setup-packet temp2 temp1 controlxfer
10599: ;
10600: : int-get-report ( -- ) \ get report for interrupt transfer
10601: 0 2 int-in-toggle kbd-report 8 mps-int-in
10602: kbd-addr int-in-ep 7 lshift or rw-endpoint \ get report
10603: swap to int-in-toggle if
10604: kbd-report @ ff00000000000000 and 38 rshift to kbd-shift \ store shift status
10605: kbd-report @ 0000ffffffffffff and to kbd-scan \ store scan codes
10606: else
10607: 0 to kbd-shift \ clear shift status
10608: 0 to kbd-scan \ clear scan code buffer
10609: then
10610: ;
10611: : ctl-get-report ( -- ) \ get report for control transfer
10612: kbd-report 8 8 kbd-addr control-cls-get-report if \ get report
10613: kbd-report @ ff00000000000000 and 38 rshift to kbd-shift \ store shift status
10614: kbd-report @ 0000ffffffffffff and to kbd-scan \ store scan codes
10615: else
10616: 0 to kbd-shift \ clear shift status
10617: 0 to kbd-scan \ clear scan code buffer
10618: then
10619: ;
10620: : set-led ( led -- )
10621: dup to led-state
10622: kbd-addr control-cls-set-report drop
10623: ;
10624: : is-shift ( -- true|false )
10625: kbd-shift 22 and if
10626: true
10627: else
10628: false
10629: then
10630: ;
10631: : is-alt ( -- true|false )
10632: kbd-shift 44 and if
10633: true
10634: else
10635: false
10636: then
10637: ;
10638: : is-ctrl ( -- true|false )
10639: kbd-shift 11 and if
10640: true
10641: else
10642: false
10643: then
10644: ;
10645: : ctrl_alt_del_key ( char -- )
10646: is-ctrl if \ ctrl is pressed?
10647: is-alt if \ alt is pressed?
10648: 4c = if \ del is pressed?
10649: s" reboot.... " usb-debug-print
10650: drop false \ invalidate del key on top of stack
10651: then
10652: false \ dummy for last drop
10653: then
10654: then
10655: drop \ clear stack
10656: ;
10657: : get-ukbd-char ( ScanCode -- char|false )
10658: dup ctrl_alt_del_key \ check ctrl+alt+del
10659: dup to scancode \ store scan code
10660: case \ translate scan code --> char
10661: 04 of [char] a endof
10662: 05 of [char] b endof
10663: 06 of [char] c endof
10664: 07 of [char] d endof
10665: 08 of [char] e endof
10666: 09 of [char] f endof
10667: 0a of [char] g endof
10668: 0b of [char] h endof
10669: 0c of [char] i endof
10670: 0d of [char] j endof
10671: 0e of [char] k endof
10672: 0f of [char] l endof
10673: 10 of [char] m endof
10674: 11 of [char] n endof
10675: 12 of [char] o endof
10676: 13 of [char] p endof
10677: 14 of [char] q endof
10678: 15 of [char] r endof
10679: 16 of [char] s endof
10680: 17 of [char] t endof
10681: 18 of [char] u endof
10682: 19 of [char] v endof
10683: 1a of [char] w endof
10684: 1b of [char] x endof
10685: 1c of [char] y endof
10686: 1d of [char] z endof
10687: 1e of [char] 1 endof
10688: 1f of [char] 2 endof
10689: 20 of [char] 3 endof
10690: 21 of [char] 4 endof
10691: 22 of [char] 5 endof
10692: 23 of [char] 6 endof
10693: 24 of [char] 7 endof
10694: 25 of [char] 8 endof
10695: 26 of [char] 9 endof
10696: 27 of [char] 0 endof
10697: 28 of 0d endof \ Enter
10698: 29 of 1b endof \ ESC
10699: 2a of 08 endof \ Backsace
10700: 2b of 09 endof \ Tab
10701: 2c of 20 endof \ Space
10702: 2d of [char] - endof
10703: 2e of [char] = endof
10704: 2f of [char] [ endof
10705: 30 of [char] ] endof
10706: 31 of [char] \ endof
10707: 33 of [char] ; endof
10708: 34 of [char] ' endof
10709: 35 of [char] ` endof
10710: 36 of [char] , endof
10711: 37 of [char] . endof
10712: 38 of [char] / endof
10713: 39 of led-state CapsLk xor set-led false endof \ CapsLk
10714: 3a of 1b 7e31315b to multi-key endof \ F1
10715: 3b of 1b 7e32315b to multi-key endof \ F2
10716: 3c of 1b 7e33315b to multi-key endof \ F3
10717: 3d of 1b 7e34315b to multi-key endof \ F4
10718: 3e of 1b 7e35315b to multi-key endof \ F5
10719: 3f of 1b 7e37315b to multi-key endof \ F6
10720: 40 of 1b 7e38315b to multi-key endof \ F7
10721: 41 of 1b 7e39315b to multi-key endof \ F8
10722: 42 of 1b 7e30315b to multi-key endof \ F9
10723: 43 of 1b 7e31315b to multi-key endof \ F10
10724: 44 of 1b 7e33315b to multi-key endof \ F11
10725: 45 of 1b 7e34315b to multi-key endof \ F12
10726: 47 of led-state ScrLk xor set-led false endof \ ScrLk
10727: 49 of 1b 7e315b to multi-key endof \ Ins
10728: 4a of 1b 7e325b to multi-key endof \ Home
10729: 4b of 1b 7e335b to multi-key endof \ PgUp
10730: 4c of 1b 7e345b to multi-key endof \ Del
10731: 4d of 1b 7e355b to multi-key endof \ End
10732: 4e of 1b 7e365b to multi-key endof \ PgDn
10733: 4f of 1b 435b to multi-key endof \ R-arrow
10734: 50 of 1b 445b to multi-key endof \ L-arrow
10735: 51 of 1b 425b to multi-key endof \ D-arrow
10736: 52 of 1b 415b to multi-key endof \ U-arrow
10737: 53 of led-state NumLk xor set-led false endof \ NumLk
10738: 54 of [char] / endof \ keypad /
10739: 55 of [char] * endof \ keypad *
10740: 56 of [char] - endof \ keypad -
10741: 57 of [char] + endof \ keypad +
10742: 58 of 0d endof \ keypad Enter
10743: 89 of [char] \ endof \ japanese yen
10744: dup of false endof \ other keys are false
10745: endcase
10746: to ret \ store char
10747: led-state CapsLk and 0 <> if \ if CapsLk is on
10748: scancode 03 > if \ from a to z ?
10749: scancode 1e < if
10750: ret 20 - to ret \ to Upper case
10751: then
10752: then
10753: then
10754: is-shift if \ if shift is on
10755: scancode 03 > if \ from a to z ?
10756: scancode 1e < if
10757: ret 20 - to ret \ to Upper case
10758: else
10759: scancode
10760: case \ translate scan code --> char
10761: 1e of [char] ! endof
10762: 1f of [char] @ endof
10763: 20 of [char] # endof
10764: 21 of [char] $ endof
10765: 22 of [char] % endof
10766: 23 of [char] ^ endof
10767: 24 of [char] & endof
10768: 25 of [char] * endof
10769: 26 of [char] ( endof
10770: 27 of [char] ) endof
10771: 2d of [char] _ endof
10772: 2e of [char] + endof
10773: 2f of [char] { endof
10774: 30 of [char] } endof
10775: 31 of [char] | endof
10776: 33 of [char] : endof
10777: 34 of [char] " endof
10778: 35 of [char] ~ endof
10779: 36 of [char] < endof
10780: 37 of [char] > endof
10781: 38 of [char] ? endof
10782: dup of ret endof \ other keys are no change
10783: endcase
10784: to ret \ overwrite new char
10785: then
10786: then
10787: then
10788: led-state NumLk and 0 <> if \ if NumLk is on
10789: scancode
10790: case \ translate scan code --> char
10791: 59 of [char] 1 endof
10792: 5a of [char] 2 endof
10793: 5b of [char] 3 endof
10794: 5c of [char] 4 endof
10795: 5d of [char] 5 endof
10796: 5e of [char] 6 endof
10797: 5f of [char] 7 endof
10798: 60 of [char] 8 endof
10799: 61 of [char] 9 endof
10800: 62 of [char] 0 endof
10801: 63 of [char] . endof \ keypad .
10802: dup of ret endof \ other keys are no change
10803: endcase
10804: to ret \ overwirte new char
10805: then
10806: ret \ return char
10807: ;
10808: : key-available? ( -- true|false )
10809: multi-key 0 <> IF
10810: true \ multi scan code key was pressed... so key is available
10811: EXIT \ done
10812: THEN
10813: kbd-scan 0 = IF \ if no kbd-scan code is currently available
10814: int-get-report \ check for one using int-get-report
10815: THEN
10816: kbd-scan 0 <> \ if a kbd-scan is available, report true, else false
10817: ;
10818: : usb-kread ( -- char|false ) \ usb key read for control transfer
10819: multi-key 0 <> if \ if multi scan code key is pressed
10820: multi-key ff and \ read one byte from buffer
10821: multi-key 8 rshift to multi-key \ move to next byte
10822: else \ normal key check
10823: kbd-scan 0 = IF
10824: int-get-report \ read report (interrupt transfer)
10825: THEN
10826: kbd-scan 0 <> if \ scan code exist?
10827: begin kbd-scan ff and dup 00 = while \ get a last scancode in report buffer
10828: kbd-scan 8 rshift to kbd-scan \ This algorithm is wrong --> must be fixed!
10829: drop \ KBD doesn't set scancode in pressed order!!!
10830: repeat
10831: dup key-old <> if \ if the scancode is new
10832: dup to key-old \ save current scan code
10833: get-ukbd-char \ translate scan code --> char
10834: milliseconds fa + to expire-ms \ set typematic delay 250ms
10835: else \ scan code is not changed
10836: milliseconds expire-ms > if \ if timer is expired ... should be considered timer carry over
10837: get-ukbd-char \ translate scan code --> char
10838: milliseconds 21 + to expire-ms \ set typematic rate 30cps
10839: else \ timer is not expired
10840: drop false \ do nothing
10841: then
10842: then
10843: kbd-scan 8 rshift to kbd-scan \ handled scan-code
10844: else
10845: 0 to key-old \ clear privious key
10846: false \ no scan code --> return false
10847: then
10848: then
10849: ;
10850: : key-read ( -- char )
10851: 0 begin drop usb-kread dup 0 <> until \ read key input (Interrupt transfer)
10852: ;
10853: : read ( addr len -- actual )
10854: 0= IF drop 0 EXIT THEN
10855: usb-kread ?dup IF swap c! 1 ELSE 0 swap c! -2 THEN
10856: ;
10857: kbd-init \ keyboard initialize
10858: milliseconds to expire-ms \ Timer initialize
10859: 0 to multi-key \ multi key buffer clear
10860: 7 set-led \ flash leds
10861: 250 ms
10862: 0 set-led
10863: s" keyboard" get-node node>path set-alias
10864: : open ( -- true )
10865: 7 set-led
10866: 100 ms
10867: 3 set-led
10868: 100 ms
10869: 1 set-led
10870: 100 ms
10871: usb-kread drop
10872: 0 set-led
10873: true
10874: ;
10875: : close ;
10876: �������� ` @usb-kbd-device-support.fs 00 value kbd-addr
10877: to kbd-addr
10878: 8 alloc-mem to kbd-report
10879: 4 chars alloc-mem value kbd-data
10880: : rw-endpoint
10881: s" rw-endpoint" $call-parent ;
10882: : controlxfer
10883: s" controlxfer" $call-parent ;
10884: : control-std-get-device-descriptor
10885: s" control-std-get-device-descriptor" $call-parent ;
10886: : control-std-get-configuration-descriptor
10887: s" control-std-get-configuration-descriptor" $call-parent ;
10888: : control-std-set-configuration
10889: s" control-std-set-configuration" $call-parent ;
10890: : control-cls-set-protocol ( reportvalue FuncAddr -- TRUE|FALSE )
10891: to temp1
10892: to temp2
10893: 210b000000000100 setup-packet !
10894: temp2 kbd-data l!-le
10895: 1 kbd-data 1 setup-packet DEFAULT-CONTROL-MPS temp1 controlxfer
10896: ;
10897: : control-cls-set-idle ( reportvalue FuncAddr -- TRUE|FALSE )
10898: to temp1
10899: to temp2
10900: 210a000000000000 setup-packet !
10901: temp2 kbd-data l!-le
10902: 0 kbd-data 0 setup-packet DEFAULT-CONTROL-MPS temp1 controlxfer
10903: ;
10904: : control-std-get-report-descriptor ( data-buffer data-len MPS FuncAddr -- TRUE|FALSE )
10905: to temp1
10906: to temp2
10907: to temp3
10908: 8106002200000000 setup-packet !
10909: temp3 setup-packet 6 + w!-le
10910: 0 swap temp3 setup-packet temp2 temp1 controlxfer
10911: ;
10912: : kbd-init
10913: s" Starting to initialize keyboard" usb-debug-print
10914: s" MPS-INTIN" get-my-property
10915: if
10916: s" not possible" usb-debug-print
10917: else
10918: decode-int nip nip to mps-int-in
10919: then
10920: s" INT-IN-EP-ADDR" get-my-property
10921: if
10922: s" not possible" usb-debug-print
10923: else
10924: decode-int nip nip to int-in-ep
10925: then
10926: 7f alloc-mem to cfg-buffer
10927: s" Allocated buffers!!" usb-debug-print
10928: cfg-buffer 12 8 kbd-addr \ get device descriptor
10929: control-std-get-device-descriptor
10930: drop
10931: cfg-buffer 9 8 kbd-addr \ get config descriptor
10932: control-std-get-configuration-descriptor
10933: drop
10934: cfg-buffer 5 + c@ kbd-addr \ set configuration
10935: control-std-set-configuration
10936: drop
10937: s" KBDS: Set config returned" usb-debug-print
10938: 0 kbd-addr control-cls-set-idle drop \ set idle
10939: s" KBDS: Set idle returned" usb-debug-print
10940: cfg-buffer 40 8 kbd-addr \ get report descriptor
10941: control-std-get-report-descriptor
10942: drop
10943: s" Finished initializing keyboard" usb-debug-print
10944: ;
10945: �������� &` &' 0usb-mouse.fs s" mouse" device-name
10946: s" mouse" device-type
10947: ." USB Mouse" cr
10948: 1 encode-int s" configuration#" property
10949: 2 encode-int s" #buttons" property
10950: 4 encode-int s" assigned-addresses" property
10951: 2 encode-int s" reg" property
10952: : open true ;
10953: : close ;
10954: : get-event ( msec -- pos.x pos.y buttons true|false )
10955: ;
10956: �������� KH K 0scsi-support.fs vocabulary scsi-words \ create new word list named 'scsi-words'
10957: also scsi-words definitions \ place next definitions into new list
10958: false value scsi-param-debug \ common debugging flag
10959: d# 0 value scsi-param-size \ length of CDB processed last
10960: h# 0 value scsi-param-control \ control word for CDBs as defined in SAM-4
10961: d# 0 value scsi-param-errors \ counter for detected errors
10962: : scsi-inc-errors
10963: scsi-param-errors 1 + to scsi-param-errors
10964: ;
10965: 00 CONSTANT scsi-cmd-test-unit-ready
10966: STRUCT
10967: /c FIELD test-unit-ready>operation-code \ 00h
10968: 4 FIELD test-unit-ready>reserved \ unused
10969: /c FIELD test-unit-ready>control \ control byte as specified in SAM-4
10970: CONSTANT scsi-length-test-unit-ready
10971: : scsi-build-test-unit-ready ( cdb -- )
10972: dup scsi-length-test-unit-ready erase ( cdb )
10973: scsi-param-control swap test-unit-ready>control c! ( )
10974: scsi-length-test-unit-ready to scsi-param-size \ update CDB length
10975: ;
10976: 03 CONSTANT scsi-cmd-request-sense
10977: STRUCT
10978: /c FIELD request-sense>operation-code \ 03h
10979: 3 FIELD request-sense>reserved \ unused
10980: /c FIELD request-sense>allocation-length \ buffer-length for data response
10981: /c FIELD request-sense>control \ control byte as specified in SAM-4
10982: CONSTANT scsi-length-request-sense
10983: : scsi-build-request-sense ( alloc-len cdb -- )
10984: >r ( alloc-len ) ( R: -- cdb )
10985: r@ scsi-length-request-sense erase ( alloc-len )
10986: scsi-cmd-request-sense r@ ( alloc-len cmd cdb )
10987: request-sense>operation-code c! ( alloc-len )
10988: dup d# 252 > \ buffer length too big ?
10989: IF
10990: scsi-inc-errors
10991: drop d# 252 \ replace with 252
10992: ELSE
10993: dup d# 18 < \ allocated buffer too small ?
10994: IF
10995: scsi-inc-errors
10996: drop 0 \ reject return data
10997: THEN
10998: THEN ( alloclen )
10999: r@ request-sense>allocation-length c! ( )
11000: scsi-param-control r> request-sense>control c! ( alloc-len cdb ) ( R: cdb -- )
11001: scsi-length-request-sense to scsi-param-size \ update CDB length
11002: ;
11003: 70 CONSTANT scsi-response(request-sense-0)
11004: 71 CONSTANT scsi-response(request-sense-1)
11005: STRUCT
11006: /c FIELD sense-data>response-code \ 70h (current errors) or 71h (deferred errors)
11007: /c FIELD sense-data>obsolete
11008: /c FIELD sense-data>sense-key \ D3..D0 = sense key, D7 = EndOfMedium
11009: /l FIELD sense-data>info
11010: /c FIELD sense-data>alloc-length \ <= 244 (for max size)
11011: /l FIELD sense-data>command-info
11012: /c FIELD sense-data>asc \ additional sense key
11013: /c FIELD sense-data>ascq \ additional sense key qualifier
11014: /c FIELD sense-data>unit-code
11015: 3 FIELD sense-data>key-specific
11016: /c FIELD sense-data>add-sense-bytes \ start of appended extra bytes
11017: CONSTANT scsi-length-sense-data
11018: : scsi-get-sense-data ( addr -- ascq asc sense-key )
11019: >r ( R: -- addr )
11020: r@ sense-data>response-code c@ 7f and 72 >= IF
11021: r@ 3 + c@ ( ascq )
11022: r@ 2 + c@ ( ascq asc )
11023: r> 1 + c@ 0f and ( ascq asc sense-key )
11024: ELSE
11025: r@ sense-data>ASCQ c@ ( ascq )
11026: r@ sense-data>ASC c@ ( ascq asc )
11027: r> sense-data>sense-key c@ 0f and ( ascq asc sense-key ) ( R: addr -- )
11028: THEN
11029: ;
11030: : scsi-get-sense-data? ( addr -- false | ascq asc sense-key true )
11031: dup
11032: sense-data>response-code c@
11033: 7e AND 70 = \ Response code (some devices have MSB set)
11034: IF
11035: scsi-get-sense-data TRUE
11036: ELSE
11037: drop FALSE \ drop addr
11038: THEN
11039: ;
11040: : scsi-get-sense-ID? ( addr -- false | ascq asc sense-key true )
11041: dup
11042: sense-data>response-code c@
11043: 7e AND 70 = \ Response code (some devices have MSB set)
11044: IF
11045: scsi-get-sense-data ( ascq asc sense-key )
11046: 10 lshift ( ascq asc sense-key16 )
11047: swap 8 lshift or ( ascq sense-key+asc )
11048: swap or \ 24-bit sense-ID ( sense-key+asc+ascq )
11049: TRUE
11050: ELSE
11051: drop FALSE \ drop addr
11052: THEN
11053: ;
11054: 12 CONSTANT scsi-cmd-inquiry
11055: STRUCT
11056: /c FIELD inquiry>operation-code \ 0x12
11057: /c FIELD inquiry>reserved \ + EVPD-Bit (vital product data)
11058: /c FIELD inquiry>page-code \ page code for vital product data (if used)
11059: /w FIELD inquiry>allocation-length \ length of Data-In-Buffer
11060: /c FIELD inquiry>control \ control byte as specified in SAM-4
11061: CONSTANT scsi-length-inquiry
11062: : scsi-build-inquiry ( alloc-len cdb -- )
11063: dup scsi-length-inquiry erase \ 6 bytes CDB
11064: scsi-cmd-inquiry over ( alloc-len cdb cmd cdb )
11065: inquiry>operation-code c! ( alloc-len cdb )
11066: scsi-param-control over inquiry>control c! ( alloc-len cdb )
11067: inquiry>allocation-length w! \ size of Data-In Buffer
11068: scsi-length-inquiry to scsi-param-size \ update CDB length
11069: ;
11070: STRUCT
11071: /c FIELD inquiry-data>peripheral \ qualifier and device type
11072: /c FIELD inquiry-data>reserved1
11073: /c FIELD inquiry-data>version \ supported SCSI version (1,2,3)
11074: /c FIELD inquiry-data>data-format
11075: /c FIELD inquiry-data>add-length \ total block length - 4
11076: /c FIELD inquiry-data>flags1
11077: /c FIELD inquiry-data>flags2
11078: /c FIELD inquiry-data>flags3
11079: d# 8 FIELD inquiry-data>vendor-ident \ vendor string
11080: d# 16 FIELD inquiry-data>product-ident \ device string
11081: /l FIELD inquiry-data>product-revision \ revision string
11082: d# 20 FIELD inquiry-data>vendor-specific \ optional params
11083: CONSTANT scsi-length-inquiry-data
11084: 25 CONSTANT scsi-cmd-read-capacity-10 \ command code
11085: STRUCT \ SCSI 10-byte CDB structure
11086: /c FIELD read-cap-10>operation-code
11087: /c FIELD read-cap-10>reserved1
11088: /l FIELD read-cap-10>lba
11089: /w FIELD read-cap-10>reserved2
11090: /c FIELD read-cap-10>reserved3
11091: /c FIELD read-cap-10>control
11092: CONSTANT scsi-length-read-cap-10
11093: : scsi-build-read-cap-10 ( cdb -- )
11094: dup scsi-length-read-cap-10 erase ( cdb )
11095: scsi-cmd-read-capacity-10 over ( cdb cmd cdb )
11096: read-cap-10>operation-code c! ( cdb )
11097: scsi-param-control swap read-cap-10>control c! ( )
11098: scsi-length-read-cap-10 to scsi-param-size \ update CDB length
11099: ;
11100: STRUCT
11101: /l FIELD read-cap-10-data>max-lba
11102: /l FIELD read-cap-10-data>block-size
11103: CONSTANT scsi-length-read-cap-10-data
11104: : scsi-get-capacity-10 ( addr -- block-size #blocks )
11105: >r ( addr -- ) ( R: -- addr )
11106: r@ read-cap-10-data>block-size l@ ( block-size )
11107: r> read-cap-10-data>max-lba l@ ( block-size #blocks ) ( R: addr -- )
11108: ;
11109: 9e CONSTANT scsi-cmd-read-capacity-16 \ command code
11110: STRUCT \ SCSI 16-byte CDB structure
11111: /c FIELD read-cap-16>operation-code
11112: /c FIELD read-cap-16>service-action
11113: /l FIELD read-cap-16>lba-high
11114: /l FIELD read-cap-16>lba-low
11115: /l FIELD read-cap-16>allocation-length \ should be 32
11116: /c FIELD read-cap-16>reserved
11117: /c FIELD read-cap-16>control
11118: CONSTANT scsi-length-read-cap-16
11119: : scsi-build-read-cap-16 ( cdb -- )
11120: >r r@ ( R: -- cdb )
11121: scsi-length-read-cap-16 erase ( )
11122: scsi-cmd-read-capacity-16 ( code )
11123: r@ read-cap-16>operation-code c! ( )
11124: 10 r@ read-cap-16>service-action c!
11125: d# 32 \ response size 32 bytes
11126: r@ read-cap-16>allocation-length l! ( )
11127: scsi-param-control r> read-cap-16>control c! ( R: cdb -- )
11128: scsi-length-read-cap-16 to scsi-param-size \ update CDB length
11129: ;
11130: STRUCT
11131: /l FIELD read-cap-16-data>max-lba-high \ upper quadlet of Max-LBA
11132: /l FIELD read-cap-16-data>max-lba-low \ lower quadlet of Max-LBA
11133: /l FIELD read-cap-16-data>block-size \ logical block length in bytes
11134: /c FIELD read-cap-16-data>protect \ type of protection (4 bits)
11135: /c FIELD read-cap-16-data>exponent \ logical blocks per physical blocks
11136: /w FIELD read-cap-16-data>lowest-aligned \ first LBA of a phsy. block
11137: 10 FIELD read-cap-16-data>reserved \ 16 reserved bytes
11138: CONSTANT scsi-length-read-cap-16-data \ results in 32
11139: : scsi-get-capacity-16 ( addr -- block-size #blocks )
11140: >r ( R: -- addr )
11141: r@ read-cap-16-data>block-size l@ ( block-size )
11142: r@ read-cap-16-data>max-lba-high l@ ( block-size #blocks-high )
11143: d# 32 lshift ( block-size #blocks-upper )
11144: r> read-cap-16-data>max-lba-low l@ + ( block-size #blocks ) ( R: addr -- )
11145: ;
11146: 5a CONSTANT scsi-cmd-mode-sense-10
11147: STRUCT
11148: /c FIELD mode-sense-10>operation-code
11149: /c FIELD mode-sense-10>res-llbaa-dbd-res
11150: /c FIELD mode-sense-10>pc-page-code \ page code + page control
11151: /c FIELD mode-sense-10>sub-page-code
11152: 3 FIELD mode-sense-10>reserved2
11153: /w FIELD mode-sense-10>allocation-length
11154: /c FIELD mode-sense-10>control
11155: CONSTANT scsi-length-mode-sense-10
11156: : scsi-build-mode-sense-10 ( alloc-len subpage page cdb -- )
11157: >r ( alloc-len subpage page ) ( R: -- cdb )
11158: r@ scsi-length-mode-sense-10 erase \ 10 bytes CDB
11159: scsi-cmd-mode-sense-10 ( alloc-len subpage page cmd )
11160: r@ mode-sense-10>operation-code c! ( alloc-len subpage page )
11161: 10 r@ mode-sense-10>res-llbaa-dbd-res c! \ long LBAs accepted
11162: r@ mode-sense-10>pc-page-code c! ( alloc-len subpage )
11163: r@ mode-sense-10>sub-page-code c! ( alloc-len )
11164: r@ mode-sense-10>allocation-length w! ( )
11165: scsi-param-control r> mode-sense-10>control c! ( R: cdb -- )
11166: scsi-length-mode-sense-10 to scsi-param-size \ update CDB length
11167: ;
11168: STRUCT
11169: /w FIELD mode-sense-10-data>head-length
11170: /c FIELD mode-sense-10-data>head-medium
11171: /c FIELD mode-sense-10-data>head-param
11172: /c FIELD mode-sense-10-data>head-longlba
11173: /c FIELD mode-sense-10-data>head-reserved
11174: /w FIELD mode-sense-10-data>head-descr-len
11175: CONSTANT scsi-length-mode-sense-10-data
11176: : .mode-sense-data ( addr -- )
11177: cr
11178: dup mode-sense-10-data>head-length
11179: w@ ." Mode Length: " .d space
11180: dup mode-sense-10-data>head-medium
11181: c@ ." / Medium Type: " .d space
11182: dup mode-sense-10-data>head-longlba
11183: c@ ." / Long LBA: " .d space
11184: mode-sense-10-data>head-descr-len
11185: w@ ." / Descr. Length: " .d
11186: ;
11187: 08 CONSTANT scsi-cmd-read-6
11188: STRUCT
11189: /c FIELD read-6>operation-code \ 08h
11190: /c FIELD read-6>block-address-msb \ upper 5 bits
11191: /w FIELD read-6>block-address \ lower 16 bits
11192: /c FIELD read-6>length \ number of blocks to read
11193: /c FIELD read-6>control \ CDB control
11194: CONSTANT scsi-length-read-6
11195: : scsi-build-read-6 ( block# #blocks cdb -- )
11196: >r ( block# #blocks ) ( R: -- cdb )
11197: r@ scsi-length-read-6 erase \ 6 bytes CDB
11198: scsi-cmd-read-6 r@ read-6>operation-code c! ( block# #blocks )
11199: dup d# 255 > \ #blocks exceeded limit ?
11200: IF
11201: scsi-inc-errors
11202: drop 1 \ replace with any valid number
11203: THEN
11204: r@ read-6>length c! \ set #blocks to read
11205: dup 1fffff > \ check address upper limit
11206: IF
11207: scsi-inc-errors
11208: drop \ remove original block#
11209: 1fffff \ replace with any valid address
11210: THEN
11211: dup d# 16 rshift
11212: r@ read-6>block-address-msb c! \ set upper 5 bits
11213: ffff and
11214: r@ read-6>block-address w! \ set lower 16 bits
11215: scsi-param-control r> read-6>control c! ( R: cdb -- )
11216: scsi-length-read-6 to scsi-param-size \ update CDB length
11217: ;
11218: 28 CONSTANT scsi-cmd-read-10
11219: STRUCT
11220: /c FIELD read-10>operation-code
11221: /c FIELD read-10>protect
11222: /l FIELD read-10>block-address \ logical block address (32bits)
11223: /c FIELD read-10>group
11224: /w FIELD read-10>length \ transfer length (16-bits)
11225: /c FIELD read-10>control
11226: CONSTANT scsi-length-read-10
11227: : scsi-build-read-10 ( block# #blocks cdb -- )
11228: >r ( block# #blocks ) ( R: -- cdb )
11229: r@ scsi-length-read-10 erase \ 10 bytes CDB
11230: scsi-cmd-read-10 r@ read-10>operation-code c! ( block# #blocks )
11231: r@ read-10>length w! ( block# )
11232: r@ read-10>block-address l! ( )
11233: scsi-param-control r> read-10>control c! ( R: cdb -- )
11234: scsi-length-read-10 to scsi-param-size \ update CDB length
11235: ;
11236: a8 CONSTANT scsi-cmd-read-12
11237: STRUCT
11238: /c FIELD read-12>operation-code \ code: a8
11239: /c FIELD read-12>protect \ RDPROTECT, DPO, FUA, FUA_NV
11240: /l FIELD read-12>block-address \ lba
11241: /l FIELD read-12>length \ transfer length (32bits)
11242: /c FIELD read-12>group \ group number
11243: /c FIELD read-12>control
11244: CONSTANT scsi-length-read-12
11245: : scsi-build-read-12 ( block# #blocks cdb -- )
11246: >r ( block# #blocks ) ( R: -- cdb )
11247: r@ scsi-length-read-12 erase \ 12 bytes CDB
11248: scsi-cmd-read-12 r@ read-12>operation-code c! ( block# #blocks )
11249: r@ read-12>length l! ( block# )
11250: r@ read-12>block-address l! ( )
11251: scsi-param-control r> read-12>control c! ( R: cdb -- )
11252: scsi-length-read-12 to scsi-param-size \ update CDB length
11253: ;
11254: : scsi-build-read? ( block# #blocks cdb -- length )
11255: over ( block# #blocks cdb #blocks )
11256: fffe > \ tx-length (#blocks) exceeds 16-bit limit ?
11257: IF
11258: scsi-build-read-12 ( block# #blocks cdb -- )
11259: scsi-length-read-12 ( length )
11260: ELSE ( block# #blocks cdb )
11261: scsi-build-read-10 ( block# #blocks cdb -- )
11262: scsi-length-read-10 ( length )
11263: THEN
11264: ;
11265: 1b CONSTANT scsi-cmd-start-stop-unit
11266: STRUCT
11267: /c FIELD start-stop-unit>operation-code
11268: /c FIELD start-stop-unit>immed
11269: /w FIELD start-stop-unit>reserved
11270: /c FIELD start-stop-unit>pow-condition
11271: /c FIELD start-stop-unit>control
11272: CONSTANT scsi-length-start-stop-unit
11273: f1 CONSTANT scsi-const-active-power \ param used for start-stop-unit
11274: f2 CONSTANT scsi-const-idle-power \ param used for start-stop-unit
11275: f3 CONSTANT scsi-const-standby-power \ param used for start-stop-unit
11276: 3 CONSTANT scsi-const-load \ param used for start-stop-unit
11277: 2 CONSTANT scsi-const-eject \ param used for start-stop-unit
11278: 1 CONSTANT scsi-const-start
11279: 0 CONSTANT scsi-const-stop
11280: : scsi-build-start-stop-unit ( state# cdb -- )
11281: >r ( state# ) ( R: -- cdb )
11282: r@ scsi-length-start-stop-unit erase \ 6 bytes CDB
11283: scsi-cmd-start-stop-unit r@ start-stop-unit>operation-code c!
11284: dup 3 >
11285: IF
11286: 4 lshift \ shift to upper nibble
11287: THEN ( state )
11288: r@ start-stop-unit>pow-condition c! ( )
11289: scsi-param-control r> start-stop-unit>control c! ( R: cdb -- )
11290: scsi-length-start-stop-unit to scsi-param-size \ update CDB length
11291: ;
11292: 2b CONSTANT scsi-cmd-seek
11293: STRUCT
11294: /c FIELD seek>operation-code
11295: /c FIELD seek>reserved1
11296: /l FIELD seek>lba
11297: 3 FIELD seek>reserved2
11298: /c FIELD seek>control
11299: CONSTANT scsi-length-seek
11300: : scsi-build-seek ( lba cdb -- )
11301: >r ( lba ) ( R: -- cdb )
11302: r@ scsi-length-seek erase \ 10 bytes CDB
11303: scsi-cmd-seek r@ seek>operation-code c!
11304: r> seek>lba l! ( ) ( R: cdb -- )
11305: scsi-length-seek to scsi-param-size \ update CDB length
11306: ;
11307: STRUCT
11308: /w FIELD media-event-data-len
11309: /c FIELD media-event-nea-class
11310: /c FIELD media-event-supp-class
11311: /l FIELD media-event-data
11312: CONSTANT scsi-length-media-event
11313: : scsi-build-get-media-event ( cdb -- )
11314: dup c erase ( cdb )
11315: 4a over c! ( cdb )
11316: 01 over 1 + c!
11317: 10 over 4 + c!
11318: 08 over 8 + c!
11319: drop
11320: ;
11321: : .sense-text ( scode -- )
11322: case
11323: 0 OF s" OK" ENDOF
11324: 1 OF s" RECOVERED ERR" ENDOF
11325: 2 OF s" NOT READY" ENDOF
11326: 3 OF s" MEDIUM ERROR" ENDOF
11327: 4 OF s" HARDWARE ERR" ENDOF
11328: 5 OF s" ILLEGAL REQUEST" ENDOF
11329: 6 OF s" UNIT ATTENTION" ENDOF
11330: 7 OF s" DATA PROTECT" ENDOF
11331: 8 OF s" BLANK CHECK" ENDOF
11332: 9 OF s" VENDOR SPECIFIC" ENDOF
11333: a OF s" COPY ABORTED" ENDOF
11334: b OF s" ABORTED COMMAND" ENDOF
11335: d OF s" VOLUME OVERFLOW" ENDOF
11336: e OF s" MISCOMPARE" ENDOF
11337: dup OF s" UNKNOWN" ENDOF
11338: endcase
11339: 5b emit type 5d emit
11340: ;
11341: : .status-text ( stat -- )
11342: case
11343: 00 OF s" GOOD" ENDOF
11344: 02 OF s" CHECK CONDITION" ENDOF
11345: 04 OF s" CONDITION MET" ENDOF
11346: 08 OF s" BUSY" ENDOF
11347: 18 OF s" RESERVATION CONFLICT" ENDOF
11348: 28 OF s" TASK SET FULL" ENDOF
11349: 30 OF s" ACA ACTIVE" ENDOF
11350: 40 OF s" TASK ABORTED" ENDOF
11351: dup OF s" UNKNOWN" ENDOF
11352: endcase
11353: 5b emit type 5d emit
11354: ;
11355: : .dec3-2 ( prenum postnum -- )
11356: swap
11357: base @ >r \ save actual base setting
11358: decimal \ show decimal values
11359: 4 .r 2e emit
11360: dup 9 <= IF 30 emit THEN .d \ 3 pre-decimal, right aligned
11361: r> base ! \ restore base
11362: ;
11363: : .capacity-text ( block-size #blocks -- )
11364: scsi-param-debug \ debugging flag set ?
11365: IF \ show additional info
11366: 2dup
11367: cr
11368: ." LBAs: " .d \ highest logical block number
11369: ." / Block-Size: " .d
11370: ." / Total Capacity: "
11371: THEN
11372: * \ calculate total capacity
11373: dup d# 1000000000000 >= \ check terabyte limit
11374: IF
11375: d# 1000000000000 /mod
11376: swap
11377: d# 10000000000 / \ limit remainder to two digits
11378: .dec3-2 ." TB" \ show terabytes as xxx.yy
11379: ELSE
11380: dup d# 1000000000 >= \ check gigabyte limit
11381: IF
11382: d# 1000000000 /mod
11383: swap
11384: d# 10000000 /
11385: .dec3-2 ." GB" \ show gigabytes as xxx.yy
11386: ELSE
11387: dup d# 1000000 >=
11388: IF
11389: d# 1000000 /mod \ check mega byte limit
11390: swap
11391: d# 10000 /
11392: .dec3-2 ." MB" \ show megabytes as xxx.yy
11393: ELSE
11394: dup d# 1000 >= \ check kilo byte limit
11395: IF
11396: d# 1000 /mod
11397: swap
11398: d# 10 /
11399: .dec3-2 ." kB"
11400: ELSE
11401: .d ." Bytes"
11402: THEN
11403: THEN
11404: THEN
11405: THEN
11406: ;
11407: : .inquiry-text ( addr -- )
11408: 22 emit \ enclose text with "
11409: dup inquiry-data>vendor-ident 8 type space
11410: dup inquiry-data>product-ident 10 type space
11411: inquiry-data>product-revision 4 type
11412: 22 emit
11413: ;
11414: : scsi-supp-init ( -- )
11415: false to scsi-param-debug \ no debug strings
11416: h# 0 to scsi-param-size
11417: h# 0 to scsi-param-control \ common CDB control byte
11418: d# 0 to scsi-param-errors \ local errors (param limits)
11419: ;
11420: 0 VALUE scsi-context \ addr of word list on top
11421: : scsi-init ( -- )
11422: also scsi-words \ append scsi word-list
11423: context to scsi-context \ save for close process
11424: scsi-supp-init \ preset all scsi-param-xxx values
11425: scsi-param-debug
11426: IF
11427: space ." SCSI-SUPPORT OPENED" cr
11428: .wordlists
11429: THEN
11430: ;
11431: : scsi-close ( -- )
11432: scsi-param-debug
11433: IF
11434: space ." Closing SCSI-SUPPORT .. " cr
11435: THEN
11436: context scsi-context = \ scsi word list still active ?
11437: IF
11438: scsi-param-errors 0<> \ any errors occured ?
11439: IF
11440: cr ." ** WARNING: " scsi-param-errors .d
11441: ." SCSI Errors occured ** " cr
11442: THEN
11443: previous \ remove scsi word list on top
11444: 0 to scsi-context \ prevent from being misinterpreted
11445: ELSE
11446: cr ." ** WARNING: Trying to close non-open SCSI-SUPPORT (1) ** " cr
11447: THEN
11448: scsi-param-debug
11449: IF
11450: .wordlists
11451: THEN
11452: ;
11453: s" scsi-init" $find drop \ return execution pointer, when included
11454: previous \ remove scsi word list from search path
11455: definitions \ place next definitions into previous list
11456: �������� &p &8 0vio-hvterm.fs ." Populating " pwd cr
11457: : open true ;
11458: : close ;
11459: : write ( adr len -- actual ) tuck type ;
11460: : read ( adr len -- actual )
11461: 0= IF drop 0 EXIT THEN
11462: hvterm-key? 0= IF 0 swap c! -2 EXIT THEN
11463: hvterm-key swap c! 1
11464: ;
11465: : setup-alias
11466: " hvterm" find-alias 0= IF
11467: " hvterm" get-node node>path set-alias
11468: ELSE THEN
11469: ;
11470: setup-alias
11471: �������� , +� 0vio-vscsi.fs ." Populating " pwd
11472: 0 CONSTANT vscsi-debug
11473: 0 VALUE vscsi-unit
11474: : l2dma ( laddr - dma_addr)
11475: ;
11476: 0 VALUE crq-base
11477: 0 VALUE crq-dma
11478: 0 VALUE crq-offset
11479: 1000 CONSTANT CRQ-SIZE
11480: CREATE crq 10 allot
11481: : crq-alloc ( -- )
11482: CRQ-SIZE alloc-mem to crq-base 0 to crq-offset
11483: crq-base l2dma to crq-dma
11484: ;
11485: : crq-free ( -- )
11486: vscsi-unit hv-free-crq
11487: crq-base CRQ-SIZE free-mem 0 to crq-base
11488: ;
11489: : crq-init ( -- res )
11490: crq-alloc
11491: vscsi-debug IF
11492: ." VSCSI: allocated crq at " crq-base . cr
11493: THEN
11494: crq-base CRQ-SIZE erase
11495: vscsi-unit crq-dma CRQ-SIZE hv-reg-crq
11496: dup 0 <> IF
11497: ." VSCSI: Error " . ." registering CRQ !" cr
11498: crq-free
11499: THEN
11500: ;
11501: : crq-cleanup ( -- )
11502: crq-base 0 = IF EXIT THEN
11503: vscsi-debug IF
11504: ." VSCSI: freeing crq at " crq-base . cr
11505: THEN
11506: crq-free
11507: ;
11508: : crq-send ( msgaddr -- true | false )
11509: vscsi-unit swap hv-send-crq 0 =
11510: ;
11511: : crq-poll ( -- true | false)
11512: crq-offset crq-base + dup
11513: vscsi-debug IF
11514: ." VSCSI: crq poll " dup .
11515: THEN
11516: c@
11517: vscsi-debug IF
11518: ." value=" dup . cr
11519: THEN
11520: 80 and 0 <> IF
11521: dup crq 10 move
11522: 0 swap c!
11523: crq-offset 10 + dup CRQ-SIZE >= IF drop 0 THEN to crq-offset
11524: true
11525: ELSE drop false THEN
11526: ;
11527: : crq-wait ( -- true | false)
11528: 0 BEGIN drop crq-poll dup not WHILE d# 1 ms REPEAT
11529: dup not IF
11530: ." VSCSI: Timeout waiting response !" cr EXIT
11531: ELSE
11532: vscsi-debug IF
11533: ." VSCSI: got crq: " crq dup l@ . ." " 4 + dup l@ . ." "
11534: 4 + dup l@ . ." " 4 + l@ . cr
11535: THEN
11536: THEN
11537: ;
11538: 01 CONSTANT VIOSRP_SRP_FORMAT
11539: 02 CONSTANT VIOSRP_MAD_FORMAT
11540: 03 CONSTANT VIOSRP_OS400_FORMAT
11541: 04 CONSTANT VIOSRP_AIX_FORMAT
11542: 06 CONSTANT VIOSRP_LINUX_FORMAT
11543: 07 CONSTANT VIOSRP_INLINE_FORMAT
11544: struct
11545: 1 field >crq-valid
11546: 1 field >crq-format
11547: 1 field >crq-reserved
11548: 1 field >crq-status
11549: 2 field >crq-timeout
11550: 2 field >crq-iu-len
11551: 8 field >crq-iu-data-ptr
11552: constant /crq
11553: : srp-send-crq ( addr len -- )
11554: 80 crq >crq-valid c!
11555: VIOSRP_SRP_FORMAT crq >crq-format c!
11556: 0 crq >crq-reserved c!
11557: 0 crq >crq-status c!
11558: 0 crq >crq-timeout w!
11559: ( len ) crq >crq-iu-len w!
11560: ( addr ) l2dma crq >crq-iu-data-ptr x!
11561: crq crq-send
11562: not IF
11563: ." VSCSI: Error sending CRQ !" cr
11564: THEN
11565: ;
11566: : srp-wait-crq ( -- [tag true] | false )
11567: crq-wait not IF false EXIT THEN
11568: crq >crq-format c@ VIOSRP_SRP_FORMAT <> IF
11569: ." VSCSI: Unsupported SRP response: "
11570: crq >crq-format c@ . cr
11571: false EXIT
11572: THEN
11573: crq >crq-iu-data-ptr x@ true
11574: ;
11575: scsi-open
11576: 0 VALUE >srp_opcode
11577: 00 CONSTANT SRP_LOGIN_REQ
11578: 01 CONSTANT SRP_TSK_MGMT
11579: 02 CONSTANT SRP_CMD
11580: 03 CONSTANT SRP_I_LOGOUT
11581: c0 CONSTANT SRP_LOGIN_RSP
11582: c1 CONSTANT SRP_RSP
11583: c2 CONSTANT SRP_LOGIN_REJ
11584: 80 CONSTANT SRP_T_LOGOUT
11585: 81 CONSTANT SRP_CRED_REQ
11586: 82 CONSTANT SRP_AER_REQ
11587: 41 CONSTANT SRP_CRED_RSP
11588: 42 CONSTANT SRP_AER_RSP
11589: 02 CONSTANT SRP_BUF_FORMAT_DIRECT
11590: 04 CONSTANT SRP_BUF_FORMAT_INDIRECT
11591: struct
11592: 1 field >srp-login-opcode
11593: 3 +
11594: 8 field >srp-login-tag
11595: 4 field >srp-login-req-it-iu-len
11596: 4 +
11597: 2 field >srp-login-req-buf-fmt
11598: 1 field >srp-login-req-flags
11599: 5 +
11600: 10 field >srp-login-init-port-ids
11601: 10 field >srp-login-trgt-port-ids
11602: constant /srp-login
11603: struct
11604: 1 field >srp-lresp-opcode
11605: 3 +
11606: 4 field >srp-lresp-req-lim-delta
11607: 8 field >srp-lresp-tag
11608: 4 field >srp-lresp-max-it-iu-len
11609: 4 field >srp-lresp-max-ti-iu-len
11610: 2 field >srp-lresp-buf-fmt
11611: 1 field >srp-lresp-flags
11612: constant /srp-login-resp
11613: struct
11614: 1 field >srp-lrej-opcode
11615: 3 +
11616: 4 field >srp-lrej-reason
11617: 8 field >srp-lrej-tag
11618: 8 +
11619: 2 field >srp-lrej-buf-fmt
11620: constant /srp-login-rej
11621: 00 CONSTANT SRP_NO_DATA_DESC
11622: 01 CONSTANT SRP_DATA_DESC_DIRECT
11623: 02 CONSTANT SRP_DATA_DESC_INDIRECT
11624: struct
11625: 1 field >srp-cmd-opcode
11626: 1 field >srp-cmd-sol-not
11627: 3 +
11628: 1 field >srp-cmd-buf-fmt
11629: 1 field >srp-cmd-dout-desc-cnt
11630: 1 field >srp-cmd-din-desc-cnt
11631: 8 field >srp-cmd-tag
11632: 4 +
11633: 8 field >srp-cmd-lun
11634: 1 +
11635: 1 field >srp-cmd-task-attr
11636: 1 +
11637: 1 field >srp-cmd-add-cdb-len
11638: 10 field >srp-cmd-cdb
11639: 0 field >srp-cmd-cdb-add
11640: constant /srp-cmd
11641: struct
11642: 1 field >srp-rsp-opcode
11643: 1 field >srp-rsp-sol-not
11644: 2 +
11645: 4 field >srp-rsp-req-lim-delta
11646: 8 field >srp-rsp-tag
11647: 2 +
11648: 1 field >srp-rsp-flags
11649: 1 field >srp-rsp-status
11650: 4 field >srp-rsp-dout-res-cnt
11651: 4 field >srp-rsp-din-res-cnt
11652: 4 field >srp-rsp-sense-len
11653: 4 field >srp-rsp-resp-len
11654: 0 field >srp-rsp-data
11655: constant /srp-rsp
11656: CREATE srp 100 allot
11657: 0 VALUE srp-len
11658: : srp-prep-cmd-nodata ( id lun -- )
11659: srp /srp-cmd erase
11660: SRP_CMD srp >srp-cmd-opcode c!
11661: 1 srp >srp-cmd-tag x!
11662: srp >srp-cmd-lun 1 + c! \ lun
11663: srp >srp-cmd-lun c! \ id
11664: /srp-cmd to srp-len
11665: ;
11666: : srp-prep-cmd-io ( addr len id lun -- )
11667: srp-prep-cmd-nodata ( addr len )
11668: swap l2dma ( len dmaaddr )
11669: srp srp-len + ( len dmaaddr descaddr )
11670: dup >r x! r> 8 + ( len descaddr+8 )
11671: dup 0 swap l! 4 + ( len descaddr+c )
11672: l!
11673: srp-len 10 + to srp-len
11674: ;
11675: : srp-prep-cmd-read ( addr len id lun -- )
11676: srp-prep-cmd-io
11677: 01 srp >srp-cmd-buf-fmt c! \ in direct buffer
11678: 1 srp >srp-cmd-din-desc-cnt c!
11679: ;
11680: : srp-prep-cmd-write ( addr len id lun -- )
11681: srp-prep-cmd-io
11682: 10 srp >srp-cmd-buf-fmt c! \ out direct buffer
11683: 1 srp >srp-cmd-dout-desc-cnt c!
11684: ;
11685: : srp-send-cmd ( -- )
11686: vscsi-debug IF
11687: ." VSCSI: Sending SCSI cmd " srp >srp-cmd-cdb c@ . cr
11688: THEN
11689: srp srp-len srp-send-crq
11690: ;
11691: : srp-rsp-find-sense ( -- addr )
11692: srp >srp-rsp-data
11693: ;
11694: : srp-wait-rsp ( -- true | [ ascq asc sense-key false ] )
11695: srp-wait-crq not IF false EXIT THEN
11696: dup 1 <> IF
11697: ." VSCSI: Invalid CRQ response tag, want 1 got " . cr
11698: false EXIT
11699: THEN drop
11700: srp >srp-rsp-tag x@ dup 1 <> IF
11701: ." VSCSI: Invalid SRP response tag, want 1 got " . cr
11702: false EXIT
11703: THEN drop
11704: srp >srp-rsp-status c@
11705: vscsi-debug IF
11706: ." VSCSI: Got response status: "
11707: dup .status-text cr
11708: THEN
11709: 0 <> IF
11710: srp-rsp-find-sense
11711: scsi-get-sense-data
11712: vscsi-debug IF
11713: ." VSCSI: Sense key: " dup .sense-text cr
11714: THEN
11715: false EXIT
11716: THEN
11717: true
11718: ;
11719: CREATE sector d# 512 allot
11720: 0 VALUE current-id
11721: 0 VALUE current-lun
11722: : test-unit-ready ( -- true | [ ascq asc sense-key false ] )
11723: current-id current-lun srp-prep-cmd-nodata
11724: srp >srp-cmd-cdb scsi-build-test-unit-ready
11725: srp-send-cmd
11726: srp-wait-rsp
11727: ;
11728: : inquiry ( -- true | false )
11729: sector ff current-id current-lun srp-prep-cmd-read
11730: ff srp >srp-cmd-cdb scsi-build-inquiry
11731: srp-send-cmd
11732: srp-wait-rsp
11733: dup not IF nip nip nip EXIT THEN \ swallow sense
11734: ;
11735: : read-capacity ( -- true | false )
11736: sector scsi-length-read-cap-10 current-id current-lun srp-prep-cmd-read
11737: srp >srp-cmd-cdb scsi-build-read-cap-10
11738: srp-send-cmd
11739: srp-wait-rsp
11740: dup not IF nip nip nip EXIT THEN \ swallow sense
11741: ;
11742: : start-stop-unit ( state# -- true | false )
11743: current-id current-lun srp-prep-cmd-nodata
11744: srp >srp-cmd-cdb scsi-build-start-stop-unit
11745: srp-send-cmd
11746: srp-wait-rsp
11747: dup not IF nip nip nip EXIT THEN \ swallow sense
11748: ;
11749: : get-media-event ( -- true | false )
11750: sector scsi-length-media-event current-id current-lun srp-prep-cmd-read
11751: srp >srp-cmd-cdb scsi-build-get-media-event
11752: srp-send-cmd
11753: srp-wait-rsp
11754: dup not IF nip nip nip EXIT THEN \ swallow sense
11755: ;
11756: : read-blocks ( -- addr block# #blocks blksz -- [ #read-blocks true ] | false )
11757: over * ( addr block# #blocks len )
11758: >r rot r> ( block# #blocks addr len )
11759: 5 0 DO
11760: 2dup current-id current-lun
11761: srp-prep-cmd-read ( block# #blocks addr len )
11762: 2swap ( addr len block# #blocks )
11763: 2dup srp >srp-cmd-cdb scsi-build-read-10 ( addr len block# #blocks )
11764: 2swap ( block# #blocks addr len )
11765: srp-send-cmd
11766: srp-wait-rsp
11767: IF 2drop nip true UNLOOP EXIT THEN
11768: srp >srp-rsp-status c@ 8 <> IF
11769: nip nip nip 2drop 2drop false EXIT
11770: THEN
11771: 3drop
11772: 100 ms
11773: LOOP
11774: 2drop 2drop false
11775: ;
11776: : vscsi-cleanup
11777: ." VSCSI: Cleaning up" cr
11778: crq-cleanup
11779: vscsi-unit 0 rtas-set-tce-bypass
11780: ;
11781: : vscsi-init ( -- true | false )
11782: ." VSCSI: Initializing" cr
11783: " reg" get-node get-package-property IF
11784: ." VSCSI: Not reg property !!!" 0
11785: THEN
11786: decode-int to vscsi-unit 2drop
11787: vscsi-unit 1 rtas-set-tce-bypass
11788: crq-init 0 <> IF false EXIT THEN
11789: " "(C0 01 00 00 00 00 00 00 00 00 00 00 00 00 00 00)" drop
11790: crq-send not IF
11791: ." VSCSI: Error sending init command"
11792: crq-cleanup false EXIT
11793: THEN
11794: crq-wait not IF
11795: crq-cleanup false EXIT
11796: THEN
11797: crq c@ c0 <> crq 1 + c@ 02 <> or IF
11798: ." VSCSI: Initial handshake failed"
11799: crq-cleanup false EXIT
11800: THEN
11801: ['] vscsi-cleanup add-quiesce-xt
11802: true
11803: ;
11804: 0 INSTANCE VALUE target-id
11805: 0 INSTANCE VALUE target-lun
11806: : set-address ( lun id -- )
11807: to target-id to target-lun
11808: ;
11809: : dev-max-transfer ( -- n )
11810: 10000 \ Larger value seem to have problems with some CDROMs
11811: ;
11812: : dev-get-capacity ( -- blocksize #blocks )
11813: target-id to current-id target-lun to current-lun
11814: read-capacity not IF 0 0 EXIT THEN
11815: sector scsi-get-capacity-10
11816: ;
11817: : dev-read-blocks ( -- addr block# #blocks blksize -- #read-blocks )
11818: target-id to current-id target-lun to current-lun
11819: read-blocks
11820: ;
11821: : initial-test-unit-ready ( -- true | [ ascq asc sense-key false ] )
11822: 0 0 0 false
11823: 3 0 DO
11824: 2drop 2drop
11825: test-unit-ready dup IF UNLOOP EXIT THEN
11826: LOOP
11827: ;
11828: : compare-sense ( ascq asc key ascq2 asc2 key2 -- true | false )
11829: 3 pick = ( ascq asc key ascq2 asc2 keycmp )
11830: swap 4 pick = ( ascq asc key ascq2 keycmp asccmp )
11831: rot 5 pick = ( ascq asc key keycmp asccmp ascqcmp )
11832: and and nip nip nip
11833: ;
11834: 0 CONSTANT CDROM-READY
11835: 1 CONSTANT CDROM-NOT-READY
11836: 2 CONSTANT CDROM-NO-DISK
11837: 3 CONSTANT CDROM-TRAY-OPEN
11838: 4 CONSTANT CDROM-INIT-REQUIRED
11839: 5 CONSTANT CDROM-TRAY-MAYBE-OPEN
11840: : cdrom-status ( -- status )
11841: initial-test-unit-ready
11842: IF CDROM-READY EXIT THEN
11843: vscsi-debug IF
11844: ." TestUnitReady sense: " 3dup . . . cr
11845: THEN
11846: 3dup 1 4 2 compare-sense IF
11847: 3drop CDROM-NOT-READY EXIT
11848: THEN
11849: get-media-event IF
11850: sector w@ 4 >= IF
11851: sector 2 + c@ 04 = IF
11852: sector 5 + c@
11853: dup 02 and 0<> IF drop 3drop CDROM-READY EXIT THEN
11854: dup 01 and 0<> IF drop 3drop CDROM-TRAY-OPEN EXIT THEN
11855: drop 3drop CDROM-NO-DISK EXIT
11856: THEN
11857: THEN
11858: THEN
11859: 3dup 2 4 2 compare-sense IF
11860: 3drop CDROM-INIT-REQUIRED EXIT
11861: THEN
11862: over 4 = over 2 = and IF
11863: 3drop CDROM-READY EXIT
11864: THEN
11865: over 3a = IF
11866: 3drop CDROM-NO-DISK EXIT
11867: THEN
11868: 3drop CDROM-TRAY-MAYBE-OPEN
11869: ;
11870: : cdrom-try-close-tray ( -- )
11871: scsi-const-load start-stop-unit drop
11872: ;
11873: : cdrom-must-close-tray ( -- )
11874: scsi-const-load start-stop-unit not IF
11875: ." Tray open !" cr -65 throw
11876: THEN
11877: ;
11878: : dev-prep-cdrom ( -- )
11879: target-id to current-id target-lun to current-lun
11880: 5 0 DO
11881: cdrom-status CASE
11882: CDROM-READY OF UNLOOP EXIT ENDOF
11883: CDROM-NO-DISK OF ." No medium !" cr -65 THROW ENDOF
11884: CDROM-TRAY-OPEN OF cdrom-must-close-tray ENDOF
11885: CDROM-INIT-REQUIRED OF cdrom-try-close-tray ENDOF
11886: CDROM-TRAY-MAYBE-OPEN OF cdrom-try-close-tray ENDOF
11887: ENDCASE
11888: d# 1000 ms
11889: LOOP
11890: ." Drive not ready !" cr -65 THROW
11891: ;
11892: : dev-prep-disk ( -- )
11893: ;
11894: : vscsi-create-disk ( lun id -- )
11895: " disk" 0 " vio-vscsi-device.fs" included
11896: ;
11897: : vscsi-create-cdrom ( lun id -- )
11898: " cdrom" 1 " vio-vscsi-device.fs" included
11899: ;
11900: : wrapped-inquiry ( -- true | false )
11901: inquiry not IF false EXIT THEN
11902: sector inquiry-data>peripheral c@ e0 and 0 =
11903: ;
11904: 8 CONSTANT #dev
11905: : vscsi-find-disks ( -- )
11906: ." VSCSI: Looking for disks" cr
11907: #dev 0 DO \ check 8 devices (no LUNs)
11908: i to current-id 0 to current-lun
11909: wrapped-inquiry IF
11910: ." SCSI ID " i .
11911: sector inquiry-data>peripheral c@ CASE
11912: 0 OF ." DISK : " 0 i vscsi-create-disk ENDOF
11913: 5 OF ." CD-ROM : " 0 i vscsi-create-cdrom ENDOF
11914: 7 OF ." OPTICAL : " 0 i vscsi-create-cdrom ENDOF
11915: e OF ." RED-BLOCK: " 0 i vscsi-create-disk ENDOF
11916: dup dup OF ." ? (" . 8 emit 29 emit 5 spaces ENDOF
11917: ENDCASE
11918: sector .inquiry-text cr
11919: THEN
11920: LOOP
11921: ;
11922: scsi-close
11923: : setup-alias
11924: " scsi" find-alias 0= IF
11925: " scsi" get-node node>path set-alias
11926: ELSE THEN
11927: ;
11928: : vscsi-init-and-scan ( -- )
11929: vscsi-init IF
11930: vscsi-find-disks
11931: setup-alias
11932: THEN
11933: ;
11934: vscsi-init-and-scan
11935: �������� H 8vio-vscsi-device.fs new-device
11936: VALUE is_cdrom
11937: 2swap ( $name lun id )
11938: 2dup set-unit encode-phys " reg" property
11939: 2dup device-name
11940: 2dup find-alias 0= IF
11941: get-node node>path set-alias
11942: ELSE 2drop THEN
11943: s" block" device-type
11944: 0 INSTANCE VALUE block-size
11945: 0 INSTANCE VALUE max-block-num
11946: 0 INSTANCE VALUE max-transfer
11947: : read-blocks ( addr block# #blocks -- #read )
11948: block-size " dev-read-blocks" $call-parent
11949: not IF
11950: ." Read blocks failed !" cr -1 throw
11951: THEN
11952: ;
11953: INSTANCE VARIABLE deblocker
11954: : open ( -- true | false )
11955: my-unit " set-address" $call-parent
11956: is_cdrom IF " dev-prep-cdrom" ELSE " dev-prep-disk" THEN $call-parent
11957: " dev-get-capacity" $call-parent to max-block-num to block-size
11958: " dev-max-transfer" $call-parent to max-transfer
11959: 0 0 " deblocker" $open-package dup deblocker ! dup IF
11960: " disk-label" find-package IF
11961: my-args rot interpose
11962: THEN
11963: THEN 0<>
11964: ;
11965: : close ( -- )
11966: deblocker @ close-package ;
11967: : seek ( pos.lo pos.hi -- status )
11968: s" seek" deblocker @ $call-method ;
11969: : read ( addr len -- actual )
11970: s" read" deblocker @ $call-method ;
11971: finish-device
11972: �������� 8 &� 0vio-veth.fs ." Populating " pwd cr
11973: " network" device-type
11974: INSTANCE VARIABLE obp-tftp-package
11975: : open ( -- okay? )
11976: my-unit 1 rtas-set-tce-bypass
11977: my-args s" obp-tftp" $open-package obp-tftp-package ! true
11978: ;
11979: : close ( -- )
11980: s" close" obp-tftp-package @ $call-method
11981: my-unit 0 rtas-set-tce-bypass
11982: ;
11983: : load ( addr -- len )
11984: s" load" obp-tftp-package @ $call-method
11985: ;
11986: : ping ( -- )
11987: s" ping" obp-tftp-package @ $call-method
11988: ;
11989: : setup-alias
11990: " net" find-alias 0= IF
11991: " net" get-node node>path set-alias
11992: ELSE THEN
11993: ;
11994: setup-alias
11995: �������� 0build_info.img printf t[CC]t%sn build_info.img; gcc -m64
11996: Using built-in specs.
11997: Target: powerpc-linux-gnu
11998: Configured with: ../src/configure -v --with-pkgversion='Debian 4.4.5-10' --with-bugurl=file:///usr/share/doc/gcc-4.4/README.Bugs --enable-languages=c,c++,fortran,objc,obj-c++ --prefix=/usr --program-suffix=-4.4 --enable-shared --enable-multiarch --enable-linker-build-id --with-system-zlib --libexecdir=/usr/lib --without-included-gettext --enable-threads=posix --with-gxx-include-dir=/usr/include/c++/4.4 --libdir=/usr/lib --enable-nls --enable-clocale=gnu --enable-libstdcxx-debug --enable-objc-gc --enable-secureplt --disable-softfloat --enable-targets=powerpc-linux,powerpc64-linux --with-cpu=default32 --with-long-double-128 --enable-checking=release --build=powerpc-linux-gnu --host=powerpc-linux-gnu --target=powerpc-linux-gnu
11999: Thread model: posix
12000: gcc version 4.4.5 (Debian 4.4.5-10)
12001: GNU ld (GNU Binutils for Debian) 2.20.1-system.20100303
12002: Supported emulations:
12003: elf32ppclinux
12004: elf32ppc
12005: elf32ppcsim
12006: elf64ppc
12007: elf32_spu
12008: �������� �۫�
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.