Graphviz code: graphviz.pal
From PROSE Programming Language - Wiki
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% graphviz.pal
% Author: Mark R. Bannister
% Date: 20/Apr/2017
%
% Creates some graphviz functions for producing a .gv dot file based on
% nexus objects passed into gv_add_node()
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
~Module
EQUS {[sys.tools]}
._init
func/def [gv_open], &[.open], NULL, [psIndex], [data]
func/def [gv_add_node], &[.add_node], NULL, [psPointer], [node]
func/def [gv_close], &[.close]
% For testing only
%func/def [main], &[.main]
local/rtn
.open
var/addr P0, [data] % 0=no data, 1=classes, 2=attributes
% 3=add stat class to file objects
% (and convert statMode to octal)
attr/index P0, P0, [psIndex]
reg/load P15, P0
var/global NULL, [psIndex], [data], P0
attr/mvadd ![.prose.sys.io], [psStreamOut],
[digraph G {\n],
[ concentrate=true;\n],
[ ratio=compress;\n]
% Use HTML tables if we need to display data too
reg/jmpge &[.no_shape], P15, #1
func/rtn
.no_shape
attr/add ![.prose.sys.io], [psStreamOut], [ node [shape=none\]\n]
func/rtn
.close
attr/add ![.prose.sys.io], [psStreamOut], [}\n]
func/rtn
.add_node
var/addr P0, [node], P15, [data]
attr/index P15, P15, [psIndex]
attr/copy P1, P0, [psPointer]
obj/addr P0, P1
reg/jmplt &[.no_add_stat], P15, #3
% Add the stat class if requested
reg/clr SFLG
class/test P0, [psFile], [psFileHook]
reg/jmpeq &[.no_add_stat], SFLG, #0
class/add P0, [psStatUnix]
attr/load P14, [statMode]
.no_add_stat
% Convert dots in node path to underscores
local/jsr &[.replace_illegal_chars]
reg/move P9, P1
reg/copy P11, P9
% Get parent node
reg/load P8, NULL
error/jmp &[.no_parent], ![.prose.error.sys.BadObject]
obj/pa P5, P0
error/jmp
var/local P5, [psPointer], [parent], P5
attr/copy P1, P5, [psPointer]
local/jsr &[.replace_illegal_chars]
reg/move P8, P1
% Add node label
local/jsr &[.label_node]
% Output node in graph
attr/mvadd ![.prose.sys.io], [psStreamOut], [ ], P8, [ -> ], P9, [\n]
func/rtn
.no_parent
% Output root node
local/jsr &[.label_node]
func/rtn
.label_node
attr/copy P12, P0, [pn]
reg/jmpge &[.render_class], P15, #1
attr/mvadd ![.prose.sys.io], [psStreamOut], [ ], P11, [ [label="], P12, ["\]\n]
local/rtn
.render_class
% Render HTML for the list of object classes and attributes
attr/mvadd ![.prose.sys.io], [psStreamOut],
[ ], P11, [ [label=<\n],
[ <table border="0" cellborder="1" cellspacing="0" cellpadding="8">\n],
[ <tr><td bgcolor="#3366ff"><font color="#ffffff"><b>], P12, [</b></font></td></tr>\n],
[ <tr><td><table border="0" cellborder="0" cellspacing="0" cellpadding="2">\n]
% Iterate through class list
stack/push P1, P2, P3, P4, P5
class/load P1, (P0)
.class_loop
class/load P2, (P1)
reg/jmpeq &[.class_break], P2, NULL
reg/copy P3, P2
attr/mvadd ![.prose.sys.io], [psStreamOut],
[ <tr><td align="left"><font color="#3366ff"><b>objectClass:</b></font></td><td align="left">], P3, [</td></tr>\n]
local/jmp &[.class_loop]
.class_break
attr/mvadd ![.prose.sys.io], [psStreamOut], [ </table></td></tr>\n]
reg/jmplt &[.label_rtn], P15, #2
% Iterate through attribute list
attr/mvadd ![.prose.sys.io], [psStreamOut],
[ <tr><td><table border="0" cellborder="0" cellspacing="0" cellpadding="2">\n]
attr/load P1, (P0)
error/jmp &[.attr_catch], ![.prose.error.sys.NoEntry], ![.prose.error.sys.NoSupport]
.attr_loop
attr/load P2, (P1)
reg/jmpeq &[.attr_break], P2, NULL
local/jsr &[.render_attr]
local/jmp &[.attr_loop]
.render_attr
reg/copy P3, P2
% Iterate through attribute values
attr/copy P4, (P0, P2)
% ... except stdin, stdout, stderr
reg/clr SFLG
reg/cmp P3, [psStreamIn], P3, [psStreamOut], P3, [psStreamError],
P3, [psStreamDebug], P3, [psByteStream]
reg/jmpeq &[.atval_loop], SFLG, #0
attr/mvadd ![.prose.sys.io], [psStreamOut],
[ <tr><td align="left"><font color="#3366ff"><b>], P3, [:</b></font></td><td align="left"> ], [</td></tr>\n]
local/rtn
.attr_catch
error/clr
error/jmp &[.attr_catch], ![.prose.error.sys.NoEntry], ![.prose.error.sys.NoSupport]
local/rtn
.atval_loop
attr/copy P5, (P4)
reg/jmpeq &[.atval_break], P5, NULL
%
% If data mode is 3 and this is the statMode class, convert to octal
%
reg/jmplt &[.atval_display], P15, #3
reg/jmpne &[.atval_display], P2, P14
reg/conv P5, P5, #10
reg/conv P5, P5, #8
reg/copy P5, [0], P5
.atval_display
reg/copy P3, P2
attr/mvadd ![.prose.sys.io], [psStreamOut],
[ <tr><td align="left"><font color="#3366ff"><b>], P3, [:</b></font></td><td align="left">], P5, [</td></tr>\n]
local/jmp &[.atval_loop]
.atval_break
local/rtn
.attr_break
error/jmp
attr/mvadd ![.prose.sys.io], [psStreamOut], [ </table></td></tr>\n]
.label_rtn
attr/mvadd ![.prose.sys.io], [psStreamOut], [ </table>\n >\]\n]
stack/pull P5, P4, P3, P2, P1
local/rtn
.replace_illegal_chars
stack/push P0
.loop
reg/xscan P0, P1, [.]
reg/jmpeq &[.loop2], P0, NULL
reg/save P1, (#0x5f000000, P0, #0xff000000)
local/jmp &[.loop]
.loop2
reg/xscan P0, P1, [#]
reg/jmpeq &[.loop3], P0, NULL
reg/save P1, (#0x5f000000, P0, #0xff000000)
local/jmp &[.loop2]
.loop3
reg/xscan P0, P1, [-]
reg/jmpeq &[.loop4], P0, NULL
reg/save P1, (#0x5f000000, P0, #0xff000000)
local/jmp &[.loop3]
.loop4
reg/xscan P0, P1, [/]
reg/jmpeq &[.loop_end], P0, NULL
reg/save P1, (#0x5f000000, P0, #0xff000000)
local/jmp &[.loop4]
.loop_end
stack/pull P0
local/rtn
%.main
% For testing only
%func/call NULL, [tools.gv_open], #0
%func/call NULL, [tools.gv_add_node], ![.prose]
%func/call NULL, [tools.gv_add_node], ![.prose.sys]
%func/call NULL, [tools.gv_add_node], ![.prose.sys.io]
%func/call NULL, [tools.gv_add_node], ![.prose.code]
%func/call NULL, [tools.gv_add_node], ![.prose.code.sys]
%func/call NULL, [tools.gv_add_node], ![.prose.error]
%func/call NULL, [tools.gv_add_node], ![.prose.error.sys]
%func/call NULL, [tools.gv_add_node], ![.prose.error.sys.StackLocked]
%func/call NULL, [tools.gv_add_node], ![.prose.error.sys.RegisterDuplication]
%func/call NULL, [tools.gv_add_node], ![.prose.error.sys.OutOfBounds]
%func/call NULL, [tools.gv_close]
%func/rtn
