Verified Commit 9c2a55a8 authored by Bernd Paysan's avatar Bernd Paysan
Browse files

Coding style change: No code after stack comment for multi-line definitions... 

Coding style change: No code after stack comment for multi-line definitions (not completely through; some code will stay in the original format, like the one-screen codes
parent 87e737e7

Makefile.in

+0 −2
Original line number Diff line number Diff line
@@ -172,9 +172,7 @@ KERN_SRC = \ 
	kernel/aliases0.fs \

	kernel/aliases.fs \

	kernel/args.fs \

	kernel/cloop.fs \

	kernel/cond.fs \

	kernel/cond-old.fs \

	cross.fs \

	kernel/errore.fs \

	kernel/files.fs \

ansi.fs

+16 −13
Original line number Diff line number Diff line
@@ -75,7 +75,9 @@ decimal 


User Attr   $660 Attr !



: (Attr!)       ( attr -- ) dup Attr @ = IF drop EXIT THEN

: (Attr!) ( attr -- )

    \G set attribute

    dup Attr @ = IF drop EXIT THEN

    dup Attr !

    ESC[    0 pn

    dup FG> ?dup IF $F xor 30 + ;pn THEN
@@ -96,7 +98,8 @@ User Attr $660 Attr ! 
    default-out op-vector !

[THEN]



: BlackSpace    Attr @ dup BG> Black =

: BlackSpace ( -- )

    Attr @ dup BG> Black =

    IF drop space

    ELSE 0 attr! space attr! THEN ;

assert.fs

+8 −6
Original line number Diff line number Diff line
@@ -71,11 +71,12 @@ variable assert-level ( -- a-addr ) \ gforth 


: debug-does>  DOES>  @

    IF ['] noop assert-canary  ELSE  postpone (  THEN ;

: debug: ( -- ) Create false ,

    debug-does>

: debug: ( -- )

    Create false , debug-does>

comp:  >body

    ]] Literal @ IF [[ [: ]] THEN [[ ;] assert-canary ;

: )else(  ]] ) ( [[ ; \ )

: )else( ( --)

    ]] ) ( [[ ; \ )

comp: drop 2>r ]] ELSE [[ 2r> ;

: else( ['] noop assert-canary ; immediate
@@ -85,8 +86,8 @@ comp: drop 2>r ]] ELSE [[ 2r> ; 


Variable debug-eval



: +-? ( addr u -- flag )  0= IF  drop false  EXIT  THEN

    c@ ',' - abs 1 = ; \ ',' is in the middle between '+' and '-'

: +-? ( addr u -- flag )

    0<> swap c@ ',' - abs 1 = and ; \ ',' is in the middle between '+' and '-'



: +debug ( -- )

    BEGIN  argc @ 1 > WHILE
@@ -127,7 +128,8 @@ Variable timer-list 


: !time ( -- ) ntime timer-tick 2! ;

: @time ( -- delta-f ) ntime timer-tick 2@ d- d>f 1n f* ;

: .time ( -- ) @time

: .time ( -- )

    @time

    fdup 1e f>= IF  13 9 0 f.rdp ." s "   EXIT  THEN  1000 fm*

    fdup 1e f>= IF  10 6 0 f.rdp ." ms "  EXIT  THEN  1000 fm*

    fdup 1e f>= IF   7 3 0 f.rdp ." µs "  EXIT  THEN  1000 fm*

complex.fs

+10 −8
Original line number Diff line number Diff line
@@ -110,13 +110,15 @@ previous 
: zln      ( z -- ln[z] ) >polar fswap fln fswap ;



: z0=      ( z -- flag ) f0= >r f0= r> and ;

: zsqrt    ( z -- sqrt[z] ) zdup z0= 0= IF

: zsqrt    ( z -- sqrt[z] )

    zdup z0= 0= IF

	fdup f0= IF  fdrop fsqrt 0e  EXIT  THEN

	zln z2/ zexp  THEN ;

: z**      ( z1 z2 -- z1**z2 ) zswap zln z* zexp ;

\ Test: Fibonacci-Zahlen

1e 5e fsqrt f+ f2/ fconstant g  1e g f- fconstant -h

: zfib     ( z1 -- fib[z1] ) zdup z>r g 0e zswap z**

: zfib     ( z1 -- fib[z1] )

    zdup z>r g 0e zswap z**

    zr> zswap z>r -h 0e zswap z** znegate zr> z+

    [ g -h f- 1/f ] FLiteral zscale ;
@@ -139,8 +141,8 @@ previous 
\ complexe Operationen                                 02mar05py



: zasinh    ( z -- asinh[z] ) zdup 1e f+   zover 1e f-   z* zsqrt z+ pln ;

: zacosh    ( z -- acosh[z] ) zdup 1e x- z2/ zsqrt  zswap 1e x+ z2/ zsqrt z+

  pln z2* ;

: zacosh    ( z -- acosh[z] )

    zdup 1e x- z2/ zsqrt  zswap 1e x+ z2/ zsqrt z+ pln z2* ;

: zatanh    ( z -- atanh[z] ) zdup  1e x+ zln  zswap 1e x- znegate pln  z- z2/ ;

: zacoth    ( z -- acoth[z] ) znegate zdup 1e x- pln  zswap 1e x+ pln   z- z2/ ;

cross.fs

+32 −22
Original line number Diff line number Diff line
@@ -1553,22 +1553,30 @@ variable constflag constflag off 


bigendian

[IF]

   : DS!  ( d addr -- )  tcell bounds swap 1-

    : DS!  ( d addr -- )

	tcell bounds swap 1-

	DO  maxbyte ud/mod rot I c!  -1 +LOOP  2drop ;

   : DS@  ( addr -- d )  >r 0 0 r> tcell bounds

    : DS@  ( addr -- d )

	>r 0 0 r> tcell bounds

	DO  maxbyte * swap maxbyte um* rot + swap I c@ + swap  LOOP ;

   : Sc!  ( n addr -- )  >r s>d r> tchar bounds swap 1-

    : Sc!  ( n addr -- )

	>r s>d r> tchar bounds swap 1-

	DO  maxbyte ud/mod rot I c!  -1 +LOOP  2drop ;

   : Sc@  ( addr -- n )  >r 0 0 r> tchar bounds

    : Sc@  ( addr -- n )

	>r 0 0 r> tchar bounds

	DO  maxbyte * swap maxbyte um* rot + swap I c@ + swap  LOOP d>s ;

[ELSE]

   : DS!  ( d addr -- )  tcell bounds

    : DS!  ( d addr -- )

	tcell bounds

	DO  maxbyte ud/mod rot I c!  LOOP  2drop ;

   : DS@  ( addr -- n )  >r 0 0 r> tcell bounds swap 1-

    : DS@  ( addr -- n )

	>r 0 0 r> tcell bounds swap 1-

	DO  maxbyte * swap maxbyte um* rot + swap I c@ + swap  -1 +LOOP ;

   : Sc!  ( n addr -- )  >r s>d r> tchar bounds

    : Sc!  ( n addr -- )

	>r s>d r> tchar bounds

	DO  maxbyte ud/mod rot I c!  LOOP  2drop ;

   : Sc@  ( addr -- n )  >r 0 0 r> tchar bounds swap 1-

    : Sc@  ( addr -- n )

	>r 0 0 r> tchar bounds swap 1-

	DO  maxbyte * swap maxbyte um* rot + swap I c@ + swap  -1 +LOOP d>s ;

[THEN]
@@ -2010,8 +2018,7 @@ variable ResolveFlag 


\ ?touched                                             11may93jaw



: ?touched ( ghost -- flag ) dup forward? swap >link @

                               0 <> and ;

: ?touched ( ghost -- flag ) dup forward? swap >link @ 0<> and ;



: .forwarddefs ( ghost -- )

  ."  appeared in:"
@@ -2108,7 +2115,8 @@ $20 constant restrict-mask 
X has? f83headerstring [IF]

    : name,  ( "name" -- )  bl word count ht-header, X cfalign ;

[ELSE]

    : name,  ( "name" -- )  bl word count

    : name,  ( "name" -- )

	bl word count

	dup T cell+ cfoddalign H ht-nlstring, X cfalign ;

[THEN]

: view,   ( -- ) ( dummy ) ;
@@ -2906,7 +2914,8 @@ Cond: DOES> 
  Ghost do:ghost!

  :noname postpone gdoes> ;



: vtghost:  ( ghost -- )  Ghost >r

: vtghost:  ( ghost -- )

    Ghost >r

    :noname r> postpone Literal postpone addr, postpone ;

    built >do:ghost @ >exec2 ! ;
@@ -3007,7 +3016,8 @@ End-Struct vtable-struct 
	I @ ,

    cell +LOOP ;



:noname ( -- )  vttemplate @ 0= IF EXIT THEN

:noname ( -- )

    vttemplate @ 0= IF EXIT THEN

    gvtable-list

    BEGIN  @ dup  WHILE

	    dup vttemplate vt= IF