Annotation of gforth/oofsampl.fs, revision 1.1
1.1 ! pazsan 1: \ oof.fs Object Oriented FORTH
! 2: \ This file is (c) 1996 by Bernd Paysan
! 3: \ e-mail: paysan@informatik.tu-muenchen.de
! 4: \
! 5: \ Please copy and share this program, modify it for your system
! 6: \ and improve it as you like. But don't remove this notice.
! 7: \
! 8: \ Thank you.
! 9: \
! 10:
! 11: \ Data structures: data 28nov93py
! 12:
! 13: : place ( addr1 n addr2 -- )
! 14: over >r rot over 1+ r> move c! ;
! 15:
! 16: : i! postpone ! ; immediate
! 17: : i@ postpone @ ; immediate
! 18:
! 19: object class data \ abstract data class
! 20: cell var ref \ reference counter
! 21: method ! method @ method .
! 22: method null method atom? method #
! 23: how: : atom? ( -- flag ) true ;
! 24: : # ( -- n ) 0 ;
! 25: : null ( -- addr ) new ;
! 26: class;
! 27:
! 28: \ Data structures: int 30apr93py
! 29:
! 30: data class int
! 31: cell var value
! 32: how: : ! value i! ;
! 33: : @ value i@ ;
! 34: : . @ 0 .r ;
! 35: : init ( data -- ) ! ;
! 36: : dispose -1 ref +!
! 37: ref i@ 0> 0= IF super dispose THEN ;
! 38: : null 0 new ;
! 39: class;
! 40:
! 41:
! 42:
! 43: \ Data structures: list 17nov93py
! 44:
! 45: 0 Value nil
! 46:
! 47: data class lists
! 48: data ptr first data ptr next
! 49: method empty? method ?
! 50: how: : null nil ;
! 51: : atom? false ;
! 52: class;
! 53:
! 54: lists class nil-class
! 55:
! 56: how: : empty? true ;
! 57: : dispose ;
! 58: : . ." ()" ;
! 59: class;
! 60:
! 61: nil-class : (nil (nil self TO nil
! 62: nil (nil bind first nil (nil bind next
! 63:
! 64:
! 65: \ Data structures: list 12mar94py
! 66:
! 67: lists class linked
! 68: how: : empty? false ;
! 69: : # next # 1+ ;
! 70: : ? first . ;
! 71: : @ first @ ;
! 72: : ! first ! ;
! 73: : init ( first next -- )
! 74: dup >o 1 ref +! o> bind next
! 75: dup >o 1 ref +! o> bind first ;
! 76: : . self >o [char] (
! 77: BEGIN emit ? next atom? next self o> >o
! 78: IF ." . " data . o> ." )" EXIT THEN bl
! 79: empty? UNTIL o> drop ." )" ;
! 80: : dispose -1 ref +! ref i@ 0> 0=
! 81: IF first dispose next dispose super dispose THEN ;
! 82: class;
! 83:
! 84: \ Data structures: string 04dec93py
! 85:
! 86: int class string
! 87: how: : ! ( addr count -- )
! 88: value i@ over 1+ resize throw value i!
! 89: value i@ place ;
! 90: : @ ( -- addr count ) value i@ count ;
! 91: : . @ type ;
! 92: : init ( addr count -- )
! 93: dup 1+ allocate throw value i! value i@ place ;
! 94: : null S" " new ;
! 95: : dispose ref i@ 1- 0> 0=
! 96: IF value i@ free throw THEN super dispose ;
! 97: class;
! 98:
! 99: \ Data sturctures: pointer 17nov93py
! 100:
! 101: data class pointer
! 102: data ptr container
! 103: method ptr!
! 104: how: : ! container ! ;
! 105: : @ container @ ;
! 106: : . container . ;
! 107: : # container # ;
! 108: : init ( data -- ) dup >o 1 ref +! o> bind container ;
! 109: : ptr! ( data -- ) container dispose init ;
! 110: : dispose -1 ref +! ref i@ 0> 0=
! 111: IF container dispose super dispose THEN ;
! 112: : null nil new ;
! 113: class;
! 114:
! 115: \ Data sturctures: array 30apr93py
! 116:
! 117: data class array
! 118: data [] container
! 119: cell var range
! 120: how: : ! container ! ;
! 121: : @ container @ ;
! 122: : . [char] [
! 123: # 0 ?DO emit I container . [char] , LOOP drop ." ]" ;
! 124: : init ( data n -- ) range i! bind container ;
! 125: : dispose -1 ref +! ref i@ 0> 0=
! 126: IF # 0 ?DO I container dispose LOOP
! 127: super dispose THEN ;
! 128: : null nil 0 new ;
! 129: : # range i@ ;
! 130: : atom? false ;
! 131: class;
! 132:
! 133: \ Data structure utilities 17nov93py
! 134:
! 135: : cons linked new ;
! 136: : list nil cons ;
! 137: : car >o lists first self o> ;
! 138: : cdr >o lists next self o> ;
! 139: : print >o data . o> ;
! 140: : ddrop >o data dispose o> ;
! 141: : make-string string new ;
! 142: : $" state @ IF postpone S" postpone make-string exit THEN
! 143: [char] " parse make-string ; immediate
! 144:
! 145: \ Examples
! 146:
! 147: $" This" $" is" $" a" list cons $" example" $" list" list cons list cons cons
! 148: cr dup print
! 149: cr dup car print
! 150: cr dup cdr cdr car print
! 151: pointer : list1
! 152: cr list1 .
! 153:
! 154: 1 2 3 3 int new[] 3 array : lotus
! 155: cr lotus .
! 156: cr 2 lotus @ .
! 157: cr 0 lotus @ .
! 158: cr 5 1 lotus ! lotus .
! 159:
! 160: \ Interface test
! 161:
! 162: interface bla
! 163: method fasel
! 164: method blubber
! 165: method Hu
! 166: how:
! 167: : fasel ." Bla Fasel" Hu ;
! 168: : blubber ." urps urps" Hu fasel ;
! 169: interface;
! 170:
! 171: object class test
! 172: bla
! 173: method .
! 174: how:
! 175: : Hu ." ! " ;
! 176: : . fasel ;
! 177: class;
! 178:
! 179: test : test1
! 180: cr test1 fasel
! 181: cr test1 blubber
! 182: cr test1 .
! 183: cr test1 self >o bla blubber o>
! 184:
! 185: \ This should output the following lines:
! 186: \
! 187: \ (This (is a) (example list))
! 188: \ This
! 189: \ (example list)
! 190: \ (This (is a) (example list))
! 191: \ [1,2,3]
! 192: \ 3
! 193: \ 1
! 194: \ [1,5,3]
! 195: \ Bla Fasel!
! 196: \ urps urps! Bla Fasel!
! 197: \ Bla Fasel!
! 198: \ urps urps! Bla Fasel!
! 199:
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>