Репозиторий Sisyphus
Последнее обновление: 27 сентября 2021 | Пакетов: 17343 | Посещений: 21961003
en ru br
Репозитории ALT
S:0.0-alt3
5.1: 0.0-alt3
4.1: 0.0-alt2
4.0: 0.0-alt2
www.altlinux.org/Changes

Группа :: Разработка/Прочее
Пакет: ansforth-ext-oof

 Главная   Изменения   Спек   Патчи   Исходники   Загрузить   Gear   Bugs and FR  Repocop 

pax_global_header00006660000000000000000000000064111034424300014502gustar00rootroot0000000000000052 comment=bb21f55bd65697d7c81fad2541e04edde66767f4
oof/000075500000000000000000000000001110344243000116275ustar00rootroot00000000000000oof/oof.fs000064400000000000000000000447121110344243000127540ustar00rootroot00000000000000\ oof.fs Object Oriented FORTH
\ This file is (c) 1996 by Bernd Paysan
\ e-mail: paysan@informatik.tu-muenchen.de
\
\ Please copy and share this program, modify it for your system
\ and improve it as you like. But don't remove this notice.
\
\ Thank you.
\
\ The program uses the following words
\ from CORE :
\ decimal : bl word 0= ; = cells Constant Variable ! Create , allot @ IF
\ POSTPONE >r ELSE +! dup + THEN immediate r> * >body cell+ Literal drop
\ align here aligned DOES> execute ['] 2@ recurse swap 1+ over LOOP and
\ EXIT ?dup 0< rot r@ - i negate +LOOP 2drop BEGIN WHILE 2dup REPEAT 1-
\ rshift > / ' move UNTIL or count
\ from CORE-EXT :
\ nip tuck true ?DO compile, false Value erase pick :noname 0<>
\ from BLOCK-EXT :
\ \
\ from EXCEPTION :
\ throw
\ from EXCEPTION-EXT :
\ abort"
\ from FILE :
\ ( S"
\ from FLOAT :
\ faligned
\ from LOCAL :
\ TO
\ from MEMORY :
\ allocate free
\ from SEARCH :
\ find definitions get-order set-order get-current wordlist set-current
\ search-wordlist
\ from SEARCH-EXT :
\ also Forth previous
\ from STRING :
\ /string compare
\ from TOOLS-EXT :
\ [IF] [THEN] [ELSE] state

\ Loadscreen 27dec95py

decimal

: define? ( -- flag )
bl word find nip 0= ;

define? cell [IF]
1 cells Constant cell
[THEN]

define? ?EXIT [IF]
: ?EXIT postpone IF postpone EXIT postpone THEN ; immediate
[THEN]

define? Vocabulary [IF]
: Vocabulary wordlist create ,
DOES> @ >r get-order nip r> swap set-order ;
[THEN]

define? faligned [IF] false [ELSE] 1 faligned 8 = [THEN]
[IF]
: 8aligned ( n1 -- n2 ) faligned ;
[ELSE]
: 8aligned ( n1 -- n2 ) 7 + -8 and ;
[THEN]

Vocabulary Objects also Objects also definitions

Vocabulary types types also

0 cells Constant :wordlist
1 cells Constant :parent
2 cells Constant :child
3 cells Constant :next
4 cells Constant :method#
5 cells Constant :var#
6 cells Constant :newlink
7 cells Constant :iface
8 cells Constant :init

0 cells Constant :inext
1 cells Constant :ilist
2 cells Constant :ilen
3 cells Constant :inum

Variable op
: op! ( o -- ) op ! ;

Forth definitions

Create ostack 0 , 16 cells allot

: ^ ( -- o ) op @ ;
: o@ ( -- o ) op @ @ ;
: >o ( o -- )
state @
IF postpone ^ postpone >r postpone op!
ELSE 1 ostack +! ^ ostack dup @ cells + ! op!
THEN ; immediate
: o> ( -- )
state @
IF postpone r> postpone op!
ELSE ostack dup @ cells + @ op! -1 ostack +!
THEN ; immediate
: o[] ( n -- ) o@ :var# + @ * ^ + op! ;

Objects definitions

\ Coding 27dec95py

0 Constant #static
1 Constant #method
2 Constant #early
3 Constant #var
4 Constant #defer

: exec? ( addr -- flag )
>body cell+ @ #method = ;
: static? ( addr -- flag )
>body cell+ @ #static = ;
: early? ( addr -- flag )
>body cell+ @ #early = ;
: defer? ( addr -- flag )
>body cell+ @ #defer = ;

false Value oset?

: o+, ( addr offset -- )
postpone Literal postpone ^ postpone +
oset? IF postpone op! ELSE postpone >o THEN drop ;
: o*, ( addr offset -- )
postpone Literal postpone * postpone Literal postpone +
oset? IF postpone op! ELSE postpone >o THEN ;
: ^+@ ( offset -- addr ) ^ + @ ;
: o+@, ( addr offset -- )
postpone Literal postpone ^+@ oset? IF postpone op! ELSE postpone >o THEN drop ;
: ^*@ ( offset -- addr ) ^ + @ tuck @ :var# + @ 8aligned * + ;
: o+@*, ( addr offset -- )
postpone Literal postpone ^*@ oset? IF postpone op! ELSE postpone >o THEN drop ;

\ variables / memory allocation 30oct94py

Variable lastob
Variable lastparent 0 lastparent !
Variable vars
Variable methods
Variable decl 0 decl !
Variable 'link

: crash true abort" unbound method" ;

: link, ( addr -- ) align here 'link ! , 0 , 0 , ;

0 link,

\ type declaration 30oct94py

: vallot ( size -- offset ) vars @ >r dup vars +!
'link @ 0=
IF lastparent @ dup IF :newlink + @ THEN link,
THEN
'link @ 2 cells + +! r> ;

: valign ( -- ) vars @ aligned vars ! ;
define? faligned 0= [IF]
: vfalign ( -- ) vars @ faligned vars ! ;
[THEN]

: mallot ( -- offset ) methods @ cell methods +! ;

types definitions

: static ( -- ) \ oof- oof
\G Create a class-wide cell-sized variable.
mallot Create , #static ,
DOES> @ o@ + ;
: method ( -- ) \ oof- oof
\G Create a method selector.
mallot Create , #method ,
DOES> @ o@ + @ execute ;
: early ( -- ) \ oof- oof
\G Create a method selector for early binding.
Create ['] crash , #early ,
DOES> @ execute ;
: var ( size -- ) \ oof- oof
\G Create an instance variable
vallot Create , #var ,
DOES> @ ^ + ;
: defer ( -- ) \ oof- oof
\G Create an instance defer
valign cell vallot Create , #defer ,
DOES> @ ^ + @ execute ;

\ dealing with threads 29oct94py

Objects definitions

: object-order ( wid0 .. widm m addr -- wid0 .. widn n )
dup IF 2@ >r recurse r> swap 1+ ELSE drop THEN ;

: interface-order ( wid0 .. widm m addr -- wid0 .. widn n )
dup IF 2@ >r recurse r> :ilist + @ swap 1+
ELSE drop THEN ;

: add-order ( addr -- n ) dup 0= ?EXIT >r
get-order r> swap >r 0 swap
dup >r object-order r> :iface + @ interface-order
r> over >r + set-order r> ;

: drop-order ( n -- ) 0 ?DO previous LOOP ;

\ object compiling/executing 20feb95py

: o, ( xt early? -- )
over exec? over and IF
drop >body @ o@ + @ compile, EXIT THEN
over static? over and IF
drop >body @ o@ + @ postpone Literal EXIT THEN
drop dup early? IF >body @ THEN compile, ;

: findo ( string -- cfa n )
o@ add-order >r
find
?dup 0= IF drop set-order true abort" method not found!" THEN
r> drop-order ;

false Value method?

: method, ( object early? -- ) true to method?
swap >o >r bl word findo 0< state @ and
IF r> o, ELSE r> drop execute THEN o> false to method? ;

: cmethod, ( object early? -- )
state @ >r state on method, r> state ! ;

: early, ( object -- ) true to oset? true method,
state @ oset? and IF postpone o> THEN false to oset? ;
: late, ( object -- ) true to oset? false method,
state @ oset? and IF postpone o> THEN false to oset? ;

\ new, 29oct94py

previous Objects definitions

Variable alloc
0 Value ohere

: oallot ( n -- ) ohere + to ohere ;

: ((new, ( link -- )
dup @ ?dup IF recurse THEN cell+ 2@ swap ohere + >r
?dup IF ohere >r dup >r :newlink + @ recurse r> r> ! THEN
r> to ohere ;

: (new ( object -- )
ohere >r dup >r :newlink + @ ((new, r> r> ! ;

: init-instance ( pos link -- pos )
dup >r @ ?dup IF recurse THEN r> cell+ 2@
IF drop dup >r ^ +
>o o@ :init + @ execute 0 o@ :newlink + @ recurse o>
r> THEN + ;

: init-object ( object -- size )
>o o@ :init + @ execute 0 o@ :newlink + @ init-instance o> ;

: (new, ( object -- ) ohere dup >r over :var# + @ erase (new
r> init-object drop ;

: size@ ( objc -- size ) :var# + @ 8aligned ;
: (new[], ( n o -- addr ) ohere >r
dup size@ rot over * oallot r@ ohere dup >r 2 pick -
?DO I to ohere >r dup >r (new, r> r> dup negate +LOOP
2drop r> to ohere r> ;

\ new, 29oct94py

Create chunks here 16 cells dup allot erase

: DelFix ( addr root -- ) dup @ 2 pick ! ! ;

: NewFix ( root size # -- addr )
BEGIN 2 pick @ ?dup 0=
WHILE 2dup * allocate throw over 0
?DO dup 4 pick DelFix 2 pick +
LOOP
drop
REPEAT
>r drop r@ @ rot ! r@ swap erase r> ;

: >chunk ( n -- root n' )
1- -8 and dup 3 rshift cells chunks + swap 8 + ;

: Dalloc ( size -- addr )
dup 128 > IF allocate throw EXIT THEN
>chunk 2048 over / NewFix ;

: Salloc ( size -- addr ) align here swap allot ;

: dispose, ( addr size -- )
dup 128 > IF drop free throw EXIT THEN
>chunk drop DelFix ;

: new, ( o -- addr ) dup :var# + @
alloc @ execute dup >r to ohere (new, r> ;

: new[], ( n o -- addr ) dup :var# + @ 8aligned
2 pick * alloc @ execute to ohere (new[], ;

Forth definitions

: dynamic ['] Dalloc alloc ! ; dynamic
: static ['] Salloc alloc ! ;

Objects definitions

\ instance creation 29mar94py

: instance, ( o -- ) alloc @ >r static new, r> alloc ! drop
DOES> state @ IF dup postpone Literal oset? IF postpone op! ELSE postpone >o THEN THEN early, ;
: ptr, ( o -- ) 0 , ,
DOES> state @
IF dup postpone Literal postpone @ oset? IF postpone op! ELSE postpone >o THEN cell+
ELSE @ THEN late, ;

: array, ( n o -- ) alloc @ >r static new[], r> alloc ! drop
DOES> ( n -- ) dup dup @ size@
state @ IF o*, ELSE nip rot * + THEN early, ;

\ class creation 29mar94py

Variable voc#
Variable classlist
Variable old-current
Variable ob-interface

: voc! ( addr -- ) get-current old-current !
add-order 2 + voc# !
get-order wordlist tuck classlist ! 1+ set-order
also types classlist @ set-current ;

: (class ( parent -- )
here lastob ! true decl ! 0 ob-interface !
0 , dup voc! dup lastparent !
dup 0= IF 0 ELSE :method# + 2@ THEN methods ! vars !
DOES> false method, ;

: (is ( addr -- ) bl word findo drop
dup defer? abort" not deferred!"
>body @ state @
IF postpone ^ postpone Literal postpone + postpone !
ELSE ^ + ! THEN ;

: inherit ( -- ) bl word findo drop
dup exec? IF >body @ dup o@ + @ swap lastob @ + ! EXIT THEN
abort" Not a polymorph method!" ;

\ instance variables inside objects 27dec93py

: instvar, ( addr -- ) dup , here 0 , 0 vallot swap !
'link @ 2 cells + @ IF 'link @ link, THEN
'link @ >r dup r@ cell+ ! :var# + @ dup vars +! r> 2 cells + !
DOES> dup 2@ swap state @ IF o+, ELSE ^ + nip nip THEN
early, ;

: instptr> ( -- ) DOES> dup 2@ swap
state @ IF o+@, ELSE ^ + @ nip nip THEN late, ;

: instptr, ( addr -- ) , here 0 , cell vallot swap !
instptr> ;

: (o* ( i addr -- addr' ) dup @ :var# + @ 8aligned rot * + ;

: instarray, ( addr -- ) , here 0 , cell vallot swap !
DOES> dup 2@ swap
state @ IF o+@*, ELSE ^ + @ nip nip (o* THEN
late, ;

\ bind instance pointers 27mar94py

: ((link ( addr -- o addr' ) 2@ swap ^ + ;

: (link ( -- o addr ) bl word findo drop >body state @
IF postpone Literal postpone ((link EXIT THEN ((link ;

: parent? ( class o -- class class' ) @
BEGIN 2dup = ?EXIT dup WHILE :parent + @ REPEAT ;

: (bound ( obj1 obj2 adr2 -- ) >r over parent?
nip 0= abort" not the same class !" r> ! ;

: (bind ( addr -- ) \ <name>
(link state @ IF postpone (bound EXIT THEN (bound ;

: (sbound ( o addr -- ) dup cell+ @ swap (bound ;

Forth definitions

: bind ( o -- ) ' state @
IF postpone Literal postpone >body postpone (sbound EXIT THEN
>body (sbound ; immediate

Objects definitions

\ method implementation 29oct94py

Variable m-name
Variable last-interface 0 last-interface !

: interface, ( -- ) last-interface @
BEGIN dup WHILE dup , @ REPEAT drop ;

: inter, ( iface -- )
align here over :inum + @ lastob @ + !
here over :ilen + @ dup allot move ;

: interfaces, ( -- ) ob-interface @ lastob @ :iface + !
ob-interface @
BEGIN dup WHILE 2@ inter, REPEAT drop ;

: lastob! ( -- ) lastob @ dup
BEGIN nip dup @ here cell+ 2 pick ! dup 0= UNTIL drop
dup , op! o@ lastob ! ;

: thread, ( -- ) classlist @ , ;
: var, ( -- ) methods @ , vars @ , ;
: parent, ( -- o parent )
o@ lastparent @ 2dup dup , 0 ,
dup IF :child + dup @ , ! ELSE , drop THEN ;
: 'link, ( -- )
'link @ ?dup 0=
IF lastparent @ dup IF :newlink + @ THEN THEN , ;
: cells, ( -- )
methods @ :init ?DO ['] crash , cell +LOOP ;

\ method implementation 20feb95py

types definitions

: how: ( -- ) \ oof- oof how-to
\G End declaration, start implementation
decl @ 0= abort" not twice!" 0 decl !
align interface,
lastob! thread, parent, var, 'link, 0 , cells, interfaces,
dup
IF dup :method# + @ >r :init + swap r> :init /string move
ELSE 2drop THEN ;

: class; ( -- ) \ oof- oof end-class
\G End class declaration or implementation
decl @ IF how: THEN 0 'link !
voc# @ drop-order old-current @ set-current ;

: ptr ( -- ) \ oof- oof
\G Create an instance pointer
Create immediate lastob @ here lastob ! instptr, ;
: asptr ( class -- ) \ oof- oof
\G Create an alias to an instance pointer, cast to another class.
cell+ @ Create immediate
lastob @ here lastob ! , , instptr> ;

: Fpostpone postpone postpone ; immediate

: : ( <methodname> -- ) \ oof- oof colon
decl @ abort" HOW: missing! "
bl word findo 0= abort" not found"
dup exec? over early? or over >body cell+ @ 0< or
0= abort" not a method"
m-name ! :noname ;

Forth

: ; ( xt colon-sys -- ) \ oof- oof
postpone ;
m-name @ dup >body swap exec?
IF @ o@ +
ELSE dup cell+ @ 0< IF 2@ swap o@ + @ + THEN
THEN ! ; immediate

Forth definitions

\ object 23mar95py

Create object immediate 0 (class \ do not create as subclass
cell var oblink \ create offset for backlink
static thread \ method/variable wordlist
static parento \ pointer to parent
static childo \ ptr to first child
static nexto \ ptr to next child of parent
static method# \ number of methods (bytes)
static size \ number of variables (bytes)
static newlink \ ptr to allocated space
static ilist \ interface list
method init ( ... -- ) \ object- oof
method dispose ( -- ) \ object- oof

early class ( "name" -- ) \ object- oof
early new ( -- o ) \ object- oof
immediate
early new[] ( n -- o ) \ object- oof new-array
immediate
early : ( "name" -- ) \ object- oof define
early ptr ( "name" -- ) \ object- oof
early asptr ( o "name" -- ) \ object- oof
early [] ( n "name" -- ) \ object- oof array
early :: ( "name" -- ) \ object- oof scope
immediate
early class? ( o -- flag ) \ object- oof class-query
early super ( "name" -- ) \ object- oof
immediate
early self ( -- o ) \ object- oof
early bind ( o "name" -- ) \ object- oof
immediate
early bound ( class addr "name" -- ) \ object- oof
early link ( "name" -- class addr ) \ object- oof
immediate
early is ( xt "name" -- ) \ object- oof
immediate
early send ( xt -- ) \ object- oof
immediate
early with ( o -- ) \ object- oof
immediate
early endwith ( -- ) \ object- oof
immediate
early ' ( "name" -- xt ) \ object- oof tick
immediate
early postpone ( "name" -- ) \ object- oof
immediate
early definitions ( -- ) \ object- oof

\ base object class implementation part 23mar95py

how:
0 parento !
0 childo !
0 nexto !
: class ( -- ) Create immediate o@ (class ;
: : ( -- ) Create immediate o@
decl @ IF instvar, ELSE instance, THEN ;
: ptr ( -- ) Create immediate o@
decl @ IF instptr, ELSE ptr, THEN ;
: asptr ( addr -- )
decl @ 0= abort" only in declaration!"
Create immediate o@ , cell+ @ , instptr> ;
: [] ( n -- ) Create immediate o@
decl @ IF instarray, ELSE array, THEN ;
: new ( -- o ) o@ state @
IF Fpostpone Literal Fpostpone new, ELSE new, THEN ;
: new[] ( n -- o ) o@ state @
IF Fpostpone Literal Fpostpone new[], ELSE new[], THEN ;
: dispose ( -- ) ^ size @ dispose, ;
: bind ( addr -- ) (bind ;
: bound ( o1 o2 addr2 -- ) (bound ;
: link ( -- o addr ) (link ;
: class? ( class -- flag ) ^ parent? nip 0<> ;
: :: ( -- )
state @ IF ^ true method, ELSE inherit THEN ;
: super ( -- ) parento true method, ;
: is ( cfa -- ) (is ;
: self ( -- obj ) ^ ;
: init ( -- ) ;

: ' ( -- xt ) bl word findo 0= abort" not found!"
state @ IF Fpostpone Literal THEN ;
: send ( xt -- ) execute ;
: postpone ( -- ) o@ add-order Fpostpone Fpostpone drop-order ;

: with ( -- )
state @ oset? 0= and IF Fpostpone >o THEN
o@ add-order voc# ! false to oset? ;
: endwith Fpostpone o> voc# @ drop-order ;

: definitions
o@ add-order 1+ voc# ! also types o@ lastob !
false to oset? get-current old-current !
thread @ set-current ;
class; \ object

\ interface 01sep96py

Objects definitions

: implement ( interface -- ) \ oof-interface- oof
align here over , ob-interface @ , ob-interface !
:ilist + @ >r get-order r> swap 1+ set-order 1 voc# +! ;

: inter-method, ( interface -- ) \ oof-interface- oof
:ilist + @ bl word count 2dup s" '" compare
0= dup >r IF 2drop bl word count THEN
rot search-wordlist
dup 0= abort" Not an interface method!"
r> IF drop state @ IF postpone Literal THEN EXIT THEN
0< state @ and IF compile, ELSE execute THEN ;

Variable inter-list
Variable lastif
Variable inter#

Vocabulary interfaces interfaces definitions

: method ( -- ) \ oof-interface- oof
mallot Create , inter# @ ,
DOES> 2@ swap o@ + @ + @ execute ;

: how: ( -- ) \ oof-interface- oof
align
here lastif @ ! 0 decl !
here last-interface @ , last-interface !
inter-list @ , methods @ , inter# @ ,
methods @ :inum cell+ ?DO ['] crash , LOOP ;

: interface; ( -- ) \ oof-interface- oof
old-current @ set-current
previous previous ;

: : ( <methodname> -- ) \ oof-interface- oof colon
decl @ abort" HOW: missing! "
bl word count lastif @ @ :ilist + @
search-wordlist 0= abort" not found"
dup >body cell+ @ 0< 0= abort" not a method"
m-name ! :noname ;

Forth

: ; ( xt colon-sys -- ) \ oof-interface- oof
postpone ;
m-name @ >body @ lastif @ @ + ! ; immediate

Forth definitions

: interface ( -- ) \ oof-interface- oof
Create here lastif ! 0 , get-current old-current !
last-interface @ dup IF :inum @ THEN 1 cells - inter# !
get-order wordlist
dup inter-list ! dup set-current swap 1+ set-order
true decl !
0 vars ! :inum cell+ methods ! also interfaces
DOES> @ decl @ IF implement ELSE inter-method, THEN ;

previous previous

oof/oofsampl.fs000064400000000000000000000114701110344243000140040ustar00rootroot00000000000000\ oof.fs Object Oriented FORTH
\ This file is (c) 1996 by Bernd Paysan
\ e-mail: paysan@informatik.tu-muenchen.de
\
\ Please copy and share this program, modify it for your system
\ and improve it as you like. But don't remove this notice.
\
\ Thank you.
\

\ Data structures: data 28nov93py

: place ( addr1 n addr2 -- )
over >r rot over 1+ r> move c! ;

: i! postpone ! ; immediate
: i@ postpone @ ; immediate

object class data \ abstract data class
cell var ref \ reference counter
method ! method @ method .
method null method atom? method #
how: : atom? ( -- flag ) true ;
: # ( -- n ) 0 ;
: null ( -- addr ) new ;
class;

\ Data structures: int 30apr93py

data class int
cell var value
how: : ! value i! ;
: @ value i@ ;
: . @ 0 .r ;
: init ( data -- ) ! ;
: dispose -1 ref +!
ref i@ 0> 0= IF super dispose THEN ;
: null 0 new ;
class;



\ Data structures: list 17nov93py

0 Value nil

data class lists
data ptr first data ptr next
method empty? method ?
how: : null nil ;
: atom? false ;
class;

lists class nil-class

how: : empty? true ;
: dispose ;
: . ." ()" ;
class;

nil-class : (nil (nil self TO nil
nil (nil bind first nil (nil bind next


\ Data structures: list 12mar94py

lists class linked
how: : empty? false ;
: # next # 1+ ;
: ? first . ;
: @ first @ ;
: ! first ! ;
: init ( first next -- )
dup >o 1 ref +! o> bind next
dup >o 1 ref +! o> bind first ;
: . self >o [char] (
BEGIN emit ? next atom? next self o> >o
IF ." . " data . o> ." )" EXIT THEN bl
empty? UNTIL o> drop ." )" ;
: dispose -1 ref +! ref i@ 0> 0=
IF first dispose next dispose super dispose THEN ;
class;

\ Data structures: string 04dec93py

int class string
how: : ! ( addr count -- )
value i@ over 1+ resize throw value i!
value i@ place ;
: @ ( -- addr count ) value i@ count ;
: . @ type ;
: init ( addr count -- )
dup 1+ allocate throw value i! value i@ place ;
: null S" " new ;
: dispose ref i@ 1- 0> 0=
IF value i@ free throw THEN super dispose ;
class;

\ Data sturctures: pointer 17nov93py

data class pointer
data ptr container
method ptr!
how: : ! container ! ;
: @ container @ ;
: . container . ;
: # container # ;
: init ( data -- ) dup >o 1 ref +! o> bind container ;
: ptr! ( data -- ) container dispose init ;
: dispose -1 ref +! ref i@ 0> 0=
IF container dispose super dispose THEN ;
: null nil new ;
class;

\ Data sturctures: array 30apr93py

data class array
data [] container
cell var range
how: : ! container ! ;
: @ container @ ;
: . [char] [
# 0 ?DO emit I container . [char] , LOOP drop ." ]" ;
: init ( data n -- ) range i! bind container ;
: dispose -1 ref +! ref i@ 0> 0=
IF # 0 ?DO I container dispose LOOP
super dispose THEN ;
: null nil 0 new ;
: # range i@ ;
: atom? false ;
class;

\ Data structure utilities 17nov93py

: cons linked new ;
: list nil cons ;
: car >o lists first self o> ;
: cdr >o lists next self o> ;
: print >o data . o> ;
: ddrop >o data dispose o> ;
: make-string string new ;
: $" state @ IF postpone S" postpone make-string exit THEN
[char] " parse make-string ; immediate

\ Examples

$" This" $" is" $" a" list cons $" example" $" list" list cons list cons cons
cr dup print
cr dup car print
cr dup cdr cdr car print
pointer : list1
cr list1 .

1 2 3 3 int new[] 3 array : lotus
cr lotus .
cr 2 lotus @ .
cr 0 lotus @ .
cr 5 1 lotus ! lotus .

\ Interface test

interface bla
method fasel
method blubber
method Hu
how:
: fasel ." Bla Fasel" Hu ;
: blubber ." urps urps" Hu fasel ;
interface;

object class test
bla
method .
how:
: Hu ." ! " ;
: . fasel ;
class;

test : test1
cr test1 fasel
cr test1 blubber
cr test1 .
cr test1 self >o bla blubber o>

\ This should output the following lines:
\
\ (This (is a) (example list))
\ This
\ (example list)
\ (This (is a) (example list))
\ [1,2,3]
\ 3
\ 1
\ [1,5,3]
\ Bla Fasel!
\ urps urps! Bla Fasel!
\ Bla Fasel!
\ urps urps! Bla Fasel!

 
дизайн и разработка: Vladimir Lettiev aka crux © 2004-2005, Andrew Avramenko aka liks © 2007-2008
текущий майнтейнер: Michael Shigorin