Menu
▾
▴
[Win32forth-cvs] win32forth-stc/src/kernel gkernel.f,1.30,1.31
|
From: Alex M. <ale...@us...> - 2007-02-01 23:02:15
|
Update of /cvsroot/win32forth/win32forth-stc/src/kernel In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv10624 Modified Files: gkernel.f Log Message: arm: improve see based on type system Index: gkernel.f =================================================================== RCS file: /cvsroot/win32forth/win32forth-stc/src/kernel/gkernel.f,v retrieving revision 1.30 retrieving revision 1.31 diff -C2 -d -r1.30 -r1.31 *** gkernel.f 24 Jan 2007 23:48:39 -0000 1.30 --- gkernel.f 1 Feb 2007 23:02:02 -0000 1.31 *************** *** 2800,2806 **** ; \ immediate word, compile only - |: (p") ( -- buff ) \ runtime internal for (x") words - "parse new$ dup>r place r> dup +null ; \ uses temp buffer - |: [s"] ( -<string">- -- a1 n1 ) \ compile: generate the string "parse postpone sliteral ; --- 2800,2803 ---- *************** *** 2812,2815 **** --- 2809,2815 ---- here ," 1+ postpone literal ; + |: (p") ( -- buff ) \ runtime internal for (x") words + "parse new$ dup>r place r> dup +null ; \ uses temp buffer + : s" ( -<string">- -- a1 n1 ) (p") count compilation> drop [s"] ; : c" ( -<string">- -- a1 ) (p") compilation> drop [c"] ; *************** *** 4068,4074 **** : rename-file ( adr1 len adr2 len -- ior ) - \ [ maxbuffer maxbuffer + ] literal _localalloc dup>r \ get 2 buffers - \ ascii-z -rot \ addr2 - \ r> maxcounted + ascii-z \ addr1 _mlocalbuff ascii-z -rot _mlocalbuff ascii-z --- 4068,4071 ---- *************** *** 4279,4283 **** (comp-only) \ compile only compilation> ( -- xt ) drop ! branch >mark 2 ; \ jump will get filled in later : if ( c: -- orig ) \ branch on fl=false --- 4276,4280 ---- (comp-only) \ compile only compilation> ( -- xt ) drop ! branch >mark 2 ; 0 0 in/out \ jump will get filled in later : if ( c: -- orig ) \ branch on fl=false *************** *** 4285,4289 **** (comp-only) \ compile only compilation> ( -- xt ) drop ! ?branch >mark 2 ; \ jump will get filled in later : -if ( c: -- orig ) \ branch on fl=false --- 4282,4286 ---- (comp-only) \ compile only compilation> ( -- xt ) drop ! ?branch >mark 2 ; 1 0 in/out \ jump will get filled in later : -if ( c: -- orig ) \ branch on fl=false *************** *** 4291,4305 **** (comp-only) \ compile only compilation> ( -- xt ) drop ! -?branch >mark 2 ; \ jump will get filled in later : then ( c: orig -- ) \ resolve the forward jump (comp-only) \ compile only compilation> ( -- xt ) drop ! 2 ?pairs <resolve ; : endif ( c: orig -- ) \ resolve the forward jump (comp-only) \ compile only compilation> ( -- xt ) drop ! postpone then ; : else ( c: orig1 -- orig2 ) \ resolve the orig --- 4288,4302 ---- (comp-only) \ compile only compilation> ( -- xt ) drop ! -?branch >mark 2 ; 1 1 in/out \ jump will get filled in later : then ( c: orig -- ) \ resolve the forward jump (comp-only) \ compile only compilation> ( -- xt ) drop ! 2 ?pairs <resolve ; 0 0 in/out : endif ( c: orig -- ) \ resolve the forward jump (comp-only) \ compile only compilation> ( -- xt ) drop ! postpone then ; 0 0 in/out : else ( c: orig1 -- orig2 ) \ resolve the orig *************** *** 4307,4321 **** compilation> ( -- xt ) drop postpone ahead 2swap ! postpone then ; : begin ( c: -- dest ) \ label for until/again/repeat (comp-only) \ compile only compilation> ( -- xt ) drop ! >mark 1 ; : again ( c: dest -- ) \ backward jump (comp-only) \ compile only compilation> ( -- xt ) drop ! 1 ?pairs branch >resolve ; : until ( c: dest -- ) \ backward conditional jump --- 4304,4318 ---- compilation> ( -- xt ) drop postpone ahead 2swap ! postpone then ; 0 0 in/out : begin ( c: -- dest ) \ label for until/again/repeat (comp-only) \ compile only compilation> ( -- xt ) drop ! >mark 1 ; 0 0 in/out : again ( c: dest -- ) \ backward jump (comp-only) \ compile only compilation> ( -- xt ) drop ! 1 ?pairs branch >resolve ; 0 0 in/out : until ( c: dest -- ) \ backward conditional jump *************** *** 4323,4327 **** (comp-only) \ compile only compilation> ( -- xt ) drop ! 1 ?pairs ?branch >resolve ; : while ( c: dest -- orig dest ) --- 4320,4324 ---- (comp-only) \ compile only compilation> ( -- xt ) drop ! 1 ?pairs ?branch >resolve ; 1 0 in/out : while ( c: dest -- orig dest ) *************** *** 4329,4333 **** (comp-only) \ compile only compilation> ( -- xt ) drop ! postpone if 2swap ; : repeat ( c: orig dest -- ) --- 4326,4330 ---- (comp-only) \ compile only compilation> ( -- xt ) drop ! postpone if 2swap ; 1 0 in/out : repeat ( c: orig dest -- ) *************** *** 4335,4339 **** compilation> ( -- xt ) drop postpone again ! postpone then ; : recurse ( -- ) \ cause current definition to execute itself --- 4332,4336 ---- compilation> ( -- xt ) drop postpone again ! postpone then ; 0 0 in/out : recurse ( -- ) \ cause current definition to execute itself *************** *** 4366,4370 **** (comp-only) compilation> drop 0 cs-leave spush ! _do (copy-code) >mark 5 ; \ the repeat location gcode _?do-part1 --- 4363,4367 ---- (comp-only) compilation> drop 0 cs-leave spush ! _do (copy-code) >mark 5 ; 2 0 in/out \ the repeat location gcode _?do-part1 *************** *** 4389,4393 **** 0 cs-leave spush _?do-part1 (copy-code) >mark 4 \ for "don't do this loop" ! _?do-part2 (copy-code) >mark 5 ; \ the repeat location gcode _i --- 4386,4390 ---- 0 cs-leave spush _?do-part1 (copy-code) >mark 4 \ for "don't do this loop" ! _?do-part2 (copy-code) >mark 5 ; 2 0 in/out \ the repeat location gcode _i *************** *** 4405,4410 **** ;g ! : i ( -- ) ( r: -- n ) (comp-only) compilation> drop _i (copy-code) ; ! : j ( -- ) ( r: -- n ) (comp-only) compilation> drop _j (copy-code) ; gcode _unloop --- 4402,4407 ---- ;g ! : i ( -- ) ( r: -- n ) (comp-only) compilation> drop _i (copy-code) ; 0 1 in/out ! : j ( -- ) ( r: -- n ) (comp-only) compilation> drop _j (copy-code) ; 0 1 in/out gcode _unloop *************** *** 4414,4422 **** : unloop ( -- ) ( r: n1 n2 -- ) \ removes loop parameters ! (comp-only) compilation> drop _unloop (copy-code) ; : leave ( -- ) \ forward branch to unloop in loop ( r: n1 n2 -- ) ! (comp-only) compilation> drop branch >mark cs-leave spush ; : ?leave ( f -- ) --- 4411,4419 ---- : unloop ( -- ) ( r: n1 n2 -- ) \ removes loop parameters ! (comp-only) compilation> drop _unloop (copy-code) ; 0 0 in/out : leave ( -- ) \ forward branch to unloop in loop ( r: n1 n2 -- ) ! (comp-only) compilation> drop branch >mark cs-leave spush ; 0 0 in/out : ?leave ( f -- ) *************** *** 4425,4429 **** postpone if postpone leave ! postpone then ; gcode _loop --- 4422,4426 ---- postpone if postpone leave ! postpone then ; 1 0 in/out gcode _loop *************** *** 4457,4469 **** : loop ( c: do-sys -- ) ( r: n1 n2 -- ) ! (comp-only) compilation> drop _loop (loop) ; : +loop ( n -- ) ( c: do-sys -- ) ( r: n1 n2 -- ) ! (comp-only) compilation> drop _+loop (loop) ; : -loop ( n -- ) ( c: do-sys -- ) ( r: n1 n2 -- ) ! (comp-only) compilation> drop _-loop (loop) ; \ -------------------- Eaker CASE statement --------------------------------- --- 4454,4466 ---- : loop ( c: do-sys -- ) ( r: n1 n2 -- ) ! (comp-only) compilation> drop _loop (loop) ; 0 0 in/out : +loop ( n -- ) ( c: do-sys -- ) ( r: n1 n2 -- ) ! (comp-only) compilation> drop _+loop (loop) ; 1 0 in/out : -loop ( n -- ) ( c: do-sys -- ) ( r: n1 n2 -- ) ! (comp-only) compilation> drop _-loop (loop) ; 1 0 in/out \ -------------------- Eaker CASE statement --------------------------------- *************** *** 4566,4570 **** then postpone unnest \ generate the ret (needed; may be a branch target) ! ; : ?exit ( f1 -- ) \ conditional exit --- 4563,4567 ---- then postpone unnest \ generate the ret (needed; may be a branch target) ! ; 0 0 in/out : ?exit ( f1 -- ) \ conditional exit *************** *** 4573,4577 **** postpone if postpone exit ! postpone then ; variable csp \ current stack pointer variable --- 4570,4574 ---- postpone if postpone exit ! postpone then ; 1 0 in/out variable csp \ current stack pointer variable *************** *** 4621,4625 **** ['] ;noname is ; \ set the noname ; word (:noname) ! ; : : ( -<name>- -- ) \ forth's primary function defining word --- 4618,4622 ---- ['] ;noname is ; \ set the noname ; word (:noname) ! ; 0 0 in/out : : ( -<name>- -- ) \ forth's primary function defining word *************** *** 4628,4642 **** ['] ;name is ; \ set the named ; word (:noname) ! ; ! ! : compilation> ( -- xt ) \ for alternative compilation semantics ! (comp-only) \ compile only ! compilation> ( -- xt ) drop ! ?csp \ check no rubbish on the stack ! postpone exit \ stop current definition ! 0 to localstk \ can have its own locals ! cs-leave -stack \ clear the stack used for leave addresses ! code-here latestxt @ (compiles-set) \ make the defined word compile this ! ; : as ( 'name' -- ) \ make name an alias of call last winproc --- 4625,4629 ---- ['] ;name is ; \ set the named ; word (:noname) ! ; 0 0 in/out : as ( 'name' -- ) \ make name an alias of call last winproc *************** *** 4698,4701 **** --- 4685,4689 ---- r> ! \ adjust jump part of xt of create tcol tfa! \ last name is now a colon definition + -1 -1 in/out \ stack effects unknown at this point ; *************** *** 4712,4715 **** --- 4700,4713 ---- ; + : compilation> ( -- xt ) \ for alternative compilation semantics + (comp-only) \ compile only + compilation> ( -- xt ) drop + ?csp \ check no rubbish on the stack + postpone exit \ stop current definition + 0 to localstk \ can have its own locals + cs-leave -stack \ clear the stack used for leave addresses + code-here latestxt @ (compiles-set) \ make the defined word compile this + ; + \ -------------------- Error Handler -------------------------------- *************** *** 4736,4740 **** sp! drop r> ! then ; : abort ( -- ) --- 4734,4738 ---- sp! drop r> ! then ; 1 0 in/out : abort ( -- ) *************** *** 4946,4949 **** --- 4944,4968 ---- defer edit-error ' noop is edit-error ( -- ) \ start editor at error + : (viewinfo) ( nfa -- line# addr ) + \ *G Find source for word. + dup >vfa@ swap >ffa@ \ fetch line #, file name + over 1 < \ view < 1 + over -1 = or \ or file = -1 + if drop (file-console) \ must be console + else dup 0= \ if it's a zero, it's kernel + if drop (file-kernel) then + then ; + + : (viewtype) ( line# c-addr -- ) + s" in file " type count type + dup 0<> if + s" at line " type 10. + else drop then ; + + + : .viewinfo ( nfa -- ) + \ *G Print file & line # + (viewinfo) (viewtype) ; + : ctype ( c-str -- ) \ print message if not null count -if type space else 2drop then ; *************** *** 4967,4975 **** if 2 cells+ ctype ptrnull then \ print the message, set ptr 2 null to stop loop repeat ! loading? if ! c" in file" ctype (srcfile) ctype ! c" at line" ctype sourceline# . ! then ! r> base ! \ restore base ; --- 4986,4991 ---- if 2 cells+ ctype ptrnull then \ print the message, set ptr 2 null to stop loop repeat ! loading? if sourceline# (srcfile) (viewtype) ! then r> base ! \ restore base ; |
