From 4cefaf2808701d48e3826b16fdc8c2679a1eb173 Mon Sep 17 00:00:00 2001 From: Lars Brinkhoff Date: Sat, 24 Aug 2013 11:32:55 +0200 Subject: [PATCH] Add FORTRAN and Forth samples. --- samples/FORTRAN/sample1.F | 25 ++++ samples/FORTRAN/sample1.f | 25 ++++ samples/FORTRAN/sample1.for | 25 ++++ samples/FORTRAN/sample2.f | 25 ++++ samples/Forth/core.F | 252 ++++++++++++++++++++++++++++++++++++ samples/Forth/core.f | 252 ++++++++++++++++++++++++++++++++++++ samples/Forth/core.for | 252 ++++++++++++++++++++++++++++++++++++ 7 files changed, 856 insertions(+) create mode 100644 samples/FORTRAN/sample1.F create mode 100644 samples/FORTRAN/sample1.f create mode 100644 samples/FORTRAN/sample1.for create mode 100644 samples/FORTRAN/sample2.f create mode 100644 samples/Forth/core.F create mode 100644 samples/Forth/core.f create mode 100644 samples/Forth/core.for diff --git a/samples/FORTRAN/sample1.F b/samples/FORTRAN/sample1.F new file mode 100644 index 00000000..39ba97cb --- /dev/null +++ b/samples/FORTRAN/sample1.F @@ -0,0 +1,25 @@ +c comment +* comment + + program main + + end + + subroutine foo( i, x, b ) + INTEGER i + REAL x + LOGICAL b + + if( i.ne.0 ) then + call bar( -i ) + end if + + return + end + + double complex function baz() + + baz = (0.0d0,0.0d0) + + return + end diff --git a/samples/FORTRAN/sample1.f b/samples/FORTRAN/sample1.f new file mode 100644 index 00000000..39ba97cb --- /dev/null +++ b/samples/FORTRAN/sample1.f @@ -0,0 +1,25 @@ +c comment +* comment + + program main + + end + + subroutine foo( i, x, b ) + INTEGER i + REAL x + LOGICAL b + + if( i.ne.0 ) then + call bar( -i ) + end if + + return + end + + double complex function baz() + + baz = (0.0d0,0.0d0) + + return + end diff --git a/samples/FORTRAN/sample1.for b/samples/FORTRAN/sample1.for new file mode 100644 index 00000000..39ba97cb --- /dev/null +++ b/samples/FORTRAN/sample1.for @@ -0,0 +1,25 @@ +c comment +* comment + + program main + + end + + subroutine foo( i, x, b ) + INTEGER i + REAL x + LOGICAL b + + if( i.ne.0 ) then + call bar( -i ) + end if + + return + end + + double complex function baz() + + baz = (0.0d0,0.0d0) + + return + end diff --git a/samples/FORTRAN/sample2.f b/samples/FORTRAN/sample2.f new file mode 100644 index 00000000..19538ac7 --- /dev/null +++ b/samples/FORTRAN/sample2.f @@ -0,0 +1,25 @@ + PROGRAM MAIN + + END + +C comment +* comment + + SUBROUTINE foo( i, x, b ) + INTEGER i + REAL x + LOGICAL b + + IF( i.NE.0 ) THEN + CALL bar( -i ) + END IF + + RETURN + END + + DOUBLE COMPLEX FUNCTION baz() + + baz = (0.0d0,0.0d0) + + RETURN + END diff --git a/samples/Forth/core.F b/samples/Forth/core.F new file mode 100644 index 00000000..4a13e217 --- /dev/null +++ b/samples/Forth/core.F @@ -0,0 +1,252 @@ +: immediate lastxt @ dup c@ negate swap c! ; + +: \ source nip >in ! ; immediate \ Copyright 2004, 2012 Lars Brinkhoff + +: char \ ( "word" -- char ) + bl-word here 1+ c@ ; + +: ahead here 0 , ; + +: resolve here swap ! ; + +: ' bl-word here find 0branch [ ahead ] exit [ resolve ] 0 ; + +: postpone-nonimmediate [ ' literal , ' compile, ] literal , ; + +: create dovariable_code header, reveal ; + +create postponers + ' postpone-nonimmediate , + ' abort , + ' , , + +: word \ ( char "string" -- caddr ) + drop bl-word here ; + +: postpone \ ( C: "word" -- ) + bl word find 1+ cells postponers + @ execute ; immediate + +: unresolved \ ( C: "word" -- orig ) + postpone postpone postpone ahead ; immediate + +: chars \ ( n1 -- n2 ) + ; + +: else \ ( -- ) ( C: orig1 -- orig2 ) + unresolved branch swap resolve ; immediate + +: if \ ( flag -- ) ( C: -- orig ) + unresolved 0branch ; immediate + +: then \ ( -- ) ( C: orig -- ) + resolve ; immediate + +: [char] \ ( "word" -- ) + char postpone literal ; immediate + +: (does>) lastxt @ dodoes_code over >code ! r> swap >does ! ; + +: does> postpone (does>) ; immediate + +: begin \ ( -- ) ( C: -- dest ) + here ; immediate + +: while \ ( x -- ) ( C: dest -- orig dest ) + unresolved 0branch swap ; immediate + +: repeat \ ( -- ) ( C: orig dest -- ) + postpone branch , resolve ; immediate + +: until \ ( x -- ) ( C: dest -- ) + postpone 0branch , ; immediate + +: recurse lastxt @ compile, ; immediate + +: pad \ ( -- addr ) + here 1024 + ; + +: parse \ ( char "string" -- addr n ) + pad >r begin + source? if else 0 0 then + while + r@ c! r> 1+ >r + repeat 2drop pad r> over - ; + +: ( \ ( "string" -- ) + [ char ) ] literal parse 2drop ; immediate + \ TODO: If necessary, refill and keep parsing. + +: string, ( addr n -- ) + here over allot align swap cmove ; + +: (s") ( -- addr n ) ( R: ret1 -- ret2 ) + r> dup @ swap cell+ 2dup + aligned >r swap ; + +create squote 128 allot + +: s" ( "string" -- addr n ) + state @ if + postpone (s") [char] " parse dup , string, + else + [char] " parse >r squote r@ cmove squote r> + then ; immediate + +: (abort") ( ... addr n -- ) ( R: ... -- ) + cr type cr abort ; + +: abort" ( ... x "string" -- ) ( R: ... -- ) + postpone if postpone s" postpone (abort") postpone then ; immediate + +\ ---------------------------------------------------------------------- + +( Core words. ) + +\ TODO: # +\ TODO: #> +\ TODO: #s + +: and ( x y -- x&y ) nand invert ; + +: * 1 2>r 0 swap begin r@ while + r> r> swap 2dup dup + 2>r and if swap over + swap then dup + + repeat r> r> 2drop drop ; + +\ TODO: */mod + +: +loop ( -- ) ( C: nest-sys -- ) + postpone (+loop) postpone 0branch , postpone unloop ; immediate + +: space bl emit ; + +: ?.- dup 0 < if [char] - emit negate then ; + +: digit [char] 0 + emit ; + +: (.) base @ /mod ?dup if recurse then digit ; + +: ." ( "string" -- ) postpone s" postpone type ; immediate + +: . ( x -- ) ?.- (.) space ; + +: postpone-number ( caddr -- ) + 0 0 rot count >number dup 0= if + 2drop nip + postpone (literal) postpone (literal) postpone , + postpone literal postpone , + else + ." Undefined: " type cr abort + then ; + +' postpone-number postponers cell+ ! + +: / ( x y -- x/y ) /mod nip ; + +: 0< ( n -- flag ) 0 < ; + +: 1- ( n -- n-1 ) -1 + ; + +: 2! ( x1 x2 addr -- ) swap over ! cell+ ! ; + +: 2* ( n -- 2n ) dup + ; + +\ Kernel: 2/ + +: 2@ ( addr -- x1 x2 ) dup cell+ @ swap @ ; + +\ Kernel: 2drop +\ Kernel: 2dup + +\ TODO: 2over ( x1 x2 x3 x4 -- x1 x2 x3 x4 x1 x2 ) +\ 3 pick 3 pick ; + +\ TODO: 2swap + +\ TODO: <# + +: abs ( n -- |n| ) + dup 0< if negate then ; + +\ TODO: accept + +: c, ( n -- ) + here c! 1 chars allot ; + +: char+ ( n1 -- n2 ) + 1+ ; + +: constant create , does> @ ; + +: decimal ( -- ) + 10 base ! ; + +: depth ( -- n ) + data_stack 100 cells + 'SP @ - /cell / 2 - ; + +: do ( n1 n2 -- ) ( R: -- loop-sys ) ( C: -- do-sys ) + postpone 2>r here ; immediate + +\ TODO: environment? +\ TODO: evaluate +\ TODO: fill +\ TODO: fm/mod ) +\ TODO: hold + +: j ( -- x1 ) ( R: x1 x2 x3 -- x1 x2 x3 ) + 'RP @ 3 cells + @ ; + +\ TODO: leave + +: loop ( -- ) ( C: nest-sys -- ) + postpone 1 postpone (+loop) + postpone 0branch , + postpone unloop ; immediate + +: lshift begin ?dup while 1- swap dup + swap repeat ; + +: rshift 1 begin over while dup + swap 1- swap repeat nip + 2>r 0 1 begin r@ while + r> r> 2dup swap dup + 2>r and if swap over + swap then dup + + repeat r> r> 2drop drop ; + +: max ( x y -- max[x,y] ) + 2dup > if drop else nip then ; + +\ Kernel: min +\ TODO: mod +\ TODO: move + +: (quit) ( R: ... -- ) + return_stack 100 cells + 'RP ! + 0 'source-id ! tib ''source ! #tib ''#source ! + postpone [ + begin + refill + while + interpret state @ 0= if ." ok" cr then + repeat + bye ; + +' (quit) ' quit >body cell+ ! + +\ TODO: s>d +\ TODO: sign +\ TODO: sm/rem + +: spaces ( n -- ) + 0 do space loop ; + +\ TODO: u. + +: signbit ( -- n ) -1 1 rshift invert ; + +: xor ( x y -- x^y ) 2dup nand >r r@ nand swap r> nand nand ; + +: u< ( x y -- flag ) signbit xor swap signbit xor > ; + +\ TODO: um/mod + +: variable ( "word" -- ) + create /cell allot ; + +: ['] \ ( C: "word" -- ) + ' postpone literal ; immediate diff --git a/samples/Forth/core.f b/samples/Forth/core.f new file mode 100644 index 00000000..4a13e217 --- /dev/null +++ b/samples/Forth/core.f @@ -0,0 +1,252 @@ +: immediate lastxt @ dup c@ negate swap c! ; + +: \ source nip >in ! ; immediate \ Copyright 2004, 2012 Lars Brinkhoff + +: char \ ( "word" -- char ) + bl-word here 1+ c@ ; + +: ahead here 0 , ; + +: resolve here swap ! ; + +: ' bl-word here find 0branch [ ahead ] exit [ resolve ] 0 ; + +: postpone-nonimmediate [ ' literal , ' compile, ] literal , ; + +: create dovariable_code header, reveal ; + +create postponers + ' postpone-nonimmediate , + ' abort , + ' , , + +: word \ ( char "string" -- caddr ) + drop bl-word here ; + +: postpone \ ( C: "word" -- ) + bl word find 1+ cells postponers + @ execute ; immediate + +: unresolved \ ( C: "word" -- orig ) + postpone postpone postpone ahead ; immediate + +: chars \ ( n1 -- n2 ) + ; + +: else \ ( -- ) ( C: orig1 -- orig2 ) + unresolved branch swap resolve ; immediate + +: if \ ( flag -- ) ( C: -- orig ) + unresolved 0branch ; immediate + +: then \ ( -- ) ( C: orig -- ) + resolve ; immediate + +: [char] \ ( "word" -- ) + char postpone literal ; immediate + +: (does>) lastxt @ dodoes_code over >code ! r> swap >does ! ; + +: does> postpone (does>) ; immediate + +: begin \ ( -- ) ( C: -- dest ) + here ; immediate + +: while \ ( x -- ) ( C: dest -- orig dest ) + unresolved 0branch swap ; immediate + +: repeat \ ( -- ) ( C: orig dest -- ) + postpone branch , resolve ; immediate + +: until \ ( x -- ) ( C: dest -- ) + postpone 0branch , ; immediate + +: recurse lastxt @ compile, ; immediate + +: pad \ ( -- addr ) + here 1024 + ; + +: parse \ ( char "string" -- addr n ) + pad >r begin + source? if else 0 0 then + while + r@ c! r> 1+ >r + repeat 2drop pad r> over - ; + +: ( \ ( "string" -- ) + [ char ) ] literal parse 2drop ; immediate + \ TODO: If necessary, refill and keep parsing. + +: string, ( addr n -- ) + here over allot align swap cmove ; + +: (s") ( -- addr n ) ( R: ret1 -- ret2 ) + r> dup @ swap cell+ 2dup + aligned >r swap ; + +create squote 128 allot + +: s" ( "string" -- addr n ) + state @ if + postpone (s") [char] " parse dup , string, + else + [char] " parse >r squote r@ cmove squote r> + then ; immediate + +: (abort") ( ... addr n -- ) ( R: ... -- ) + cr type cr abort ; + +: abort" ( ... x "string" -- ) ( R: ... -- ) + postpone if postpone s" postpone (abort") postpone then ; immediate + +\ ---------------------------------------------------------------------- + +( Core words. ) + +\ TODO: # +\ TODO: #> +\ TODO: #s + +: and ( x y -- x&y ) nand invert ; + +: * 1 2>r 0 swap begin r@ while + r> r> swap 2dup dup + 2>r and if swap over + swap then dup + + repeat r> r> 2drop drop ; + +\ TODO: */mod + +: +loop ( -- ) ( C: nest-sys -- ) + postpone (+loop) postpone 0branch , postpone unloop ; immediate + +: space bl emit ; + +: ?.- dup 0 < if [char] - emit negate then ; + +: digit [char] 0 + emit ; + +: (.) base @ /mod ?dup if recurse then digit ; + +: ." ( "string" -- ) postpone s" postpone type ; immediate + +: . ( x -- ) ?.- (.) space ; + +: postpone-number ( caddr -- ) + 0 0 rot count >number dup 0= if + 2drop nip + postpone (literal) postpone (literal) postpone , + postpone literal postpone , + else + ." Undefined: " type cr abort + then ; + +' postpone-number postponers cell+ ! + +: / ( x y -- x/y ) /mod nip ; + +: 0< ( n -- flag ) 0 < ; + +: 1- ( n -- n-1 ) -1 + ; + +: 2! ( x1 x2 addr -- ) swap over ! cell+ ! ; + +: 2* ( n -- 2n ) dup + ; + +\ Kernel: 2/ + +: 2@ ( addr -- x1 x2 ) dup cell+ @ swap @ ; + +\ Kernel: 2drop +\ Kernel: 2dup + +\ TODO: 2over ( x1 x2 x3 x4 -- x1 x2 x3 x4 x1 x2 ) +\ 3 pick 3 pick ; + +\ TODO: 2swap + +\ TODO: <# + +: abs ( n -- |n| ) + dup 0< if negate then ; + +\ TODO: accept + +: c, ( n -- ) + here c! 1 chars allot ; + +: char+ ( n1 -- n2 ) + 1+ ; + +: constant create , does> @ ; + +: decimal ( -- ) + 10 base ! ; + +: depth ( -- n ) + data_stack 100 cells + 'SP @ - /cell / 2 - ; + +: do ( n1 n2 -- ) ( R: -- loop-sys ) ( C: -- do-sys ) + postpone 2>r here ; immediate + +\ TODO: environment? +\ TODO: evaluate +\ TODO: fill +\ TODO: fm/mod ) +\ TODO: hold + +: j ( -- x1 ) ( R: x1 x2 x3 -- x1 x2 x3 ) + 'RP @ 3 cells + @ ; + +\ TODO: leave + +: loop ( -- ) ( C: nest-sys -- ) + postpone 1 postpone (+loop) + postpone 0branch , + postpone unloop ; immediate + +: lshift begin ?dup while 1- swap dup + swap repeat ; + +: rshift 1 begin over while dup + swap 1- swap repeat nip + 2>r 0 1 begin r@ while + r> r> 2dup swap dup + 2>r and if swap over + swap then dup + + repeat r> r> 2drop drop ; + +: max ( x y -- max[x,y] ) + 2dup > if drop else nip then ; + +\ Kernel: min +\ TODO: mod +\ TODO: move + +: (quit) ( R: ... -- ) + return_stack 100 cells + 'RP ! + 0 'source-id ! tib ''source ! #tib ''#source ! + postpone [ + begin + refill + while + interpret state @ 0= if ." ok" cr then + repeat + bye ; + +' (quit) ' quit >body cell+ ! + +\ TODO: s>d +\ TODO: sign +\ TODO: sm/rem + +: spaces ( n -- ) + 0 do space loop ; + +\ TODO: u. + +: signbit ( -- n ) -1 1 rshift invert ; + +: xor ( x y -- x^y ) 2dup nand >r r@ nand swap r> nand nand ; + +: u< ( x y -- flag ) signbit xor swap signbit xor > ; + +\ TODO: um/mod + +: variable ( "word" -- ) + create /cell allot ; + +: ['] \ ( C: "word" -- ) + ' postpone literal ; immediate diff --git a/samples/Forth/core.for b/samples/Forth/core.for new file mode 100644 index 00000000..4a13e217 --- /dev/null +++ b/samples/Forth/core.for @@ -0,0 +1,252 @@ +: immediate lastxt @ dup c@ negate swap c! ; + +: \ source nip >in ! ; immediate \ Copyright 2004, 2012 Lars Brinkhoff + +: char \ ( "word" -- char ) + bl-word here 1+ c@ ; + +: ahead here 0 , ; + +: resolve here swap ! ; + +: ' bl-word here find 0branch [ ahead ] exit [ resolve ] 0 ; + +: postpone-nonimmediate [ ' literal , ' compile, ] literal , ; + +: create dovariable_code header, reveal ; + +create postponers + ' postpone-nonimmediate , + ' abort , + ' , , + +: word \ ( char "string" -- caddr ) + drop bl-word here ; + +: postpone \ ( C: "word" -- ) + bl word find 1+ cells postponers + @ execute ; immediate + +: unresolved \ ( C: "word" -- orig ) + postpone postpone postpone ahead ; immediate + +: chars \ ( n1 -- n2 ) + ; + +: else \ ( -- ) ( C: orig1 -- orig2 ) + unresolved branch swap resolve ; immediate + +: if \ ( flag -- ) ( C: -- orig ) + unresolved 0branch ; immediate + +: then \ ( -- ) ( C: orig -- ) + resolve ; immediate + +: [char] \ ( "word" -- ) + char postpone literal ; immediate + +: (does>) lastxt @ dodoes_code over >code ! r> swap >does ! ; + +: does> postpone (does>) ; immediate + +: begin \ ( -- ) ( C: -- dest ) + here ; immediate + +: while \ ( x -- ) ( C: dest -- orig dest ) + unresolved 0branch swap ; immediate + +: repeat \ ( -- ) ( C: orig dest -- ) + postpone branch , resolve ; immediate + +: until \ ( x -- ) ( C: dest -- ) + postpone 0branch , ; immediate + +: recurse lastxt @ compile, ; immediate + +: pad \ ( -- addr ) + here 1024 + ; + +: parse \ ( char "string" -- addr n ) + pad >r begin + source? if else 0 0 then + while + r@ c! r> 1+ >r + repeat 2drop pad r> over - ; + +: ( \ ( "string" -- ) + [ char ) ] literal parse 2drop ; immediate + \ TODO: If necessary, refill and keep parsing. + +: string, ( addr n -- ) + here over allot align swap cmove ; + +: (s") ( -- addr n ) ( R: ret1 -- ret2 ) + r> dup @ swap cell+ 2dup + aligned >r swap ; + +create squote 128 allot + +: s" ( "string" -- addr n ) + state @ if + postpone (s") [char] " parse dup , string, + else + [char] " parse >r squote r@ cmove squote r> + then ; immediate + +: (abort") ( ... addr n -- ) ( R: ... -- ) + cr type cr abort ; + +: abort" ( ... x "string" -- ) ( R: ... -- ) + postpone if postpone s" postpone (abort") postpone then ; immediate + +\ ---------------------------------------------------------------------- + +( Core words. ) + +\ TODO: # +\ TODO: #> +\ TODO: #s + +: and ( x y -- x&y ) nand invert ; + +: * 1 2>r 0 swap begin r@ while + r> r> swap 2dup dup + 2>r and if swap over + swap then dup + + repeat r> r> 2drop drop ; + +\ TODO: */mod + +: +loop ( -- ) ( C: nest-sys -- ) + postpone (+loop) postpone 0branch , postpone unloop ; immediate + +: space bl emit ; + +: ?.- dup 0 < if [char] - emit negate then ; + +: digit [char] 0 + emit ; + +: (.) base @ /mod ?dup if recurse then digit ; + +: ." ( "string" -- ) postpone s" postpone type ; immediate + +: . ( x -- ) ?.- (.) space ; + +: postpone-number ( caddr -- ) + 0 0 rot count >number dup 0= if + 2drop nip + postpone (literal) postpone (literal) postpone , + postpone literal postpone , + else + ." Undefined: " type cr abort + then ; + +' postpone-number postponers cell+ ! + +: / ( x y -- x/y ) /mod nip ; + +: 0< ( n -- flag ) 0 < ; + +: 1- ( n -- n-1 ) -1 + ; + +: 2! ( x1 x2 addr -- ) swap over ! cell+ ! ; + +: 2* ( n -- 2n ) dup + ; + +\ Kernel: 2/ + +: 2@ ( addr -- x1 x2 ) dup cell+ @ swap @ ; + +\ Kernel: 2drop +\ Kernel: 2dup + +\ TODO: 2over ( x1 x2 x3 x4 -- x1 x2 x3 x4 x1 x2 ) +\ 3 pick 3 pick ; + +\ TODO: 2swap + +\ TODO: <# + +: abs ( n -- |n| ) + dup 0< if negate then ; + +\ TODO: accept + +: c, ( n -- ) + here c! 1 chars allot ; + +: char+ ( n1 -- n2 ) + 1+ ; + +: constant create , does> @ ; + +: decimal ( -- ) + 10 base ! ; + +: depth ( -- n ) + data_stack 100 cells + 'SP @ - /cell / 2 - ; + +: do ( n1 n2 -- ) ( R: -- loop-sys ) ( C: -- do-sys ) + postpone 2>r here ; immediate + +\ TODO: environment? +\ TODO: evaluate +\ TODO: fill +\ TODO: fm/mod ) +\ TODO: hold + +: j ( -- x1 ) ( R: x1 x2 x3 -- x1 x2 x3 ) + 'RP @ 3 cells + @ ; + +\ TODO: leave + +: loop ( -- ) ( C: nest-sys -- ) + postpone 1 postpone (+loop) + postpone 0branch , + postpone unloop ; immediate + +: lshift begin ?dup while 1- swap dup + swap repeat ; + +: rshift 1 begin over while dup + swap 1- swap repeat nip + 2>r 0 1 begin r@ while + r> r> 2dup swap dup + 2>r and if swap over + swap then dup + + repeat r> r> 2drop drop ; + +: max ( x y -- max[x,y] ) + 2dup > if drop else nip then ; + +\ Kernel: min +\ TODO: mod +\ TODO: move + +: (quit) ( R: ... -- ) + return_stack 100 cells + 'RP ! + 0 'source-id ! tib ''source ! #tib ''#source ! + postpone [ + begin + refill + while + interpret state @ 0= if ." ok" cr then + repeat + bye ; + +' (quit) ' quit >body cell+ ! + +\ TODO: s>d +\ TODO: sign +\ TODO: sm/rem + +: spaces ( n -- ) + 0 do space loop ; + +\ TODO: u. + +: signbit ( -- n ) -1 1 rshift invert ; + +: xor ( x y -- x^y ) 2dup nand >r r@ nand swap r> nand nand ; + +: u< ( x y -- flag ) signbit xor swap signbit xor > ; + +\ TODO: um/mod + +: variable ( "word" -- ) + create /cell allot ; + +: ['] \ ( C: "word" -- ) + ' postpone literal ; immediate