theseus-save.fs 3.98 KB
Newer Older
bp's avatar
bp committed
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54
\ MINOS saving

: dump-attribs ( attrib -- )
    dup :hfix    and IF  ."  hfixbox "  THEN
    dup :vfix    and IF  ."  vfixbox "  THEN
    dup :flip    and IF  ."  flipbox "  THEN
\    dup :resized and IF  ."  rzbox "    THEN
    dup $F0 and IF base push hex ."  $" dup . ."  noborderbox "  THEN
    drop ;

: dump-skips ( hskip vskip -- )
    2dup 1 1 d= IF  ."  panel" 2drop
    ELSE  ?dup IF  space .d ." vskips" THEN
          ?dup IF  space .d ." hskips" THEN
    THEN ;

: dump-border ( border -- )
    ?dup IF  space .d ." borderbox"  THEN ;

: @vars ( o -- border hskip vskip attrib )
    combined with
        borderw cx@  hskip cx@  vskip cx@  attribs c@
    endwith ;

: dump-vars ( o -- )
    @vars dump-attribs dump-skips dump-border ;

: dump-link ( o -- )
    find-linker
    ?dup IF  ."  dup ^^ with C[ " all-descs find-object
        descriptors with dump-name endwith ."  ]C ( MINOS ) endwith "
    THEN ;

: dump-bind ( o -- )
    names find-name ?dup IF
        hint-name with name $@ endwith
        dup IF  ."  ^^bind " type  ELSE  2drop  THEN
    THEN ;

forward (dump-box
Defer do-dump
Defer do-boxdump
Defer do-bug

: dump-childs ( o n -- )
    0 ?DO
        sliderview with widgets self & sliderview @ class?
            IF  inner self  ELSE  self  THEN  endwith
        gadget with
            ^ ^ all-descs find-object 0= & combined @ class? and
        endwith
        IF
            (dump-box
        ELSE
bp's avatar
bp committed
55
            dup >r all-descs find-object
bp's avatar
bp committed
56 57 58
            dup IF
                do-dump
            ELSE
bp's avatar
bp committed
59 60
                r@ do-bug
            THEN  rdrop
bp's avatar
bp committed
61 62 63 64 65 66 67 68 69 70
        THEN
    LOOP drop ;

: (dump-box ( o -- )
    2 indent +!
    dup >r combined with childs self n @ endwith
    dup >r dump-childs
    -2 indent +!
    r> r> do-boxdump ;

bp's avatar
bp committed
71 72
Variable stubs

bp's avatar
bp committed
73
: dump-box ( o -- )
74 75
    [: descriptors with dump endwith ;] IS do-dump
    [: >r cr indent @ spaces
bp's avatar
bp committed
76 77 78
       .d r@ >class" lctype ."  new"
       r@ dump-bind
       r@ dump-vars
79 80
       r> dump-link ;] IS do-boxdump
    [: cr indent @ spaces nip widget with
bp's avatar
bp committed
81 82
       & hvrule @ class? IF  .' hvline'
       ELSE  .' cross new ( this is a stub )' 1 stubs +!  THEN
83
       endwith ;] IS do-bug
bp's avatar
bp committed
84 85 86
    (dump-box ;

: dispose-box ( o -- )
87
    [: descriptors with dispose endwith ;] IS do-dump
bp's avatar
bp committed
88
    ['] 2drop IS do-boxdump
bp's avatar
bp committed
89
    ['] 2drop IS do-bug
bp's avatar
bp committed
90 91 92 93
    (dump-box ;

: dump-name ( o -- )
    all-descs find-object
94
    ?dup IF  descriptors with  dump-ptr  endwith  THEN ;
bp's avatar
bp committed
95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133

: ?dump-box-name ( o -- )
    names find-name ?dup IF
        hint-name with
            name $@ nip
            IF  cr indent @ spaces
                hint self >class" lctype
                ."  ptr " name $@ type  THEN
        endwith
    THEN ;

| : >slider-o ( o -- o' )
    gadget with & sliderview @ class?
        IF  sliderview inner self  ELSE  self  THEN
    endwith ;
| : >backing-o ( o -- o' )
    gadget with & backing @ class?
        IF    self dump-name backing child self  ELSE  self  THEN
    endwith ;
| : box-o? ( o -- o flag )
    gadget with
        ^ ^ all-descs find-object 0= & combined @ class? and
    endwith ;

: dump-names ( o -- )
    dup ?dump-box-name
    combined with childs self n @ endwith
    0 ?DO
        gadget with widgets self ^ endwith
        >slider-o >backing-o box-o?
        IF  recurse  ELSE  dump-name  THEN
    LOOP drop ;

: dump-all ( -- ) base push hex
    cur resources dump-declaration
    cur resources dump-implementation
    0 cur resources script? IF
        cr ." : main"
        0 cur resources dump-script
134
        cr drop ."   event-loop bye ;"
bp's avatar
bp committed
135 136 137
        cr ." script? [IF]  main  [THEN]"
    THEN ;

bp's avatar
bp committed
138
also dos also float
bp's avatar
bp committed
139 140

: dump-file ( addr u -- )
bp's avatar
bp committed
141
    6 set-precision  stubs off
bp's avatar
bp committed
142 143
    r/w exe output-file
    ." #! " 0 arg type cr
bp's avatar
bp committed
144 145
    ." \ code generated by theseus, call 'theseus <file>' to edit" cr
    ." \ do not edit manually if you don't know what you are doing" cr
bp's avatar
bp committed
146 147 148
    cr
    ." also editor also minos also forth" cr
    dump-all
bp's avatar
bp committed
149 150
    cr ." previous previous previous" cr eot
    stubs @ IF  ." There have been " stubs ? ." empty stubs." cr  THEN ;
bp's avatar
bp committed
151

bp's avatar
bp committed
152
previous previous