Commit 4092edec authored by pazsan's avatar pazsan

primitives: key?, ms and time&date added

engine.c: time.h for ms and time&date included
bugs fixed to run tt.pfe
parent e1e166e6
/*
$Id: engine.c,v 1.1 1994-02-11 16:30:46 anton Exp $
$Id: engine.c,v 1.2 1994-04-20 17:12:00 pazsan Exp $
Copyright 1992 by the ANSI figForth Development Group
*/
......@@ -12,6 +12,7 @@
#include <fcntl.h>
#include <assert.h>
#include <stdlib.h>
#include <time.h>
#include "forth.h"
#include "io.h"
......
......@@ -16,6 +16,9 @@ decimal
: 2r> postpone r> postpone r> ; immediate restrict
: 2r@ postpone 2r> postpone 2dup postpone 2>r ; immediate restrict
: 2Literal swap postpone Literal postpone Literal ;
immediate restrict
\ CASE OF ENDOF ENDCASE 17may93jaw
\ just as described in dpANS5
......@@ -64,7 +67,8 @@ decimal
\ ERASE 17may93jaw
: erase 0 1 chars um/mod nip 0 fill ;
: erase ( 0 1 chars um/mod nip ) 0 fill ;
: blank ( 0 1 chars um/mod nip ) bl fill ;
\ ROLL 17may93jaw
......
......@@ -268,7 +268,7 @@ Defer parser
Defer name ' (name) IS name
Defer notfound
: no.extensions ( string -- ) IF &-13 bounce THEN ;
: no.extensions ( string -- ) IF &-13 bounce THEN ;
' no.extensions IS notfound
......@@ -286,7 +286,7 @@ Defer notfound
: compiler ( name -- ) find ?dup
IF 0> IF execute EXIT THEN compile, EXIT THEN number? dup
IF 0> IF swap postpone Literal THEN postpone Literal
ELSE notfound THEN ;
ELSE drop notfound THEN ;
: [ ['] interpreter IS parser state off ; immediate
: ] ['] compiler IS parser state on ;
......@@ -486,8 +486,8 @@ Create ??? ," ???"
: (Constant) Header reveal [ :docon ] ALiteral cfa, ;
: Constant (Constant) , ;
: AConstant (Constant) A, ;
: 2CONSTANT ( w1 w2 "name" -- ) \ double
(constant) 2, ;
: 2Constant ( w1 w2 "name" -- ) \ double
Create 2, DOES> 2@ ;
\ IS Defer What's Defers TO 24feb93py
......
......@@ -6,18 +6,33 @@ Variable locals here locals ! 100 ( some) cells allot
postpone Literal postpone + ;
: delocal, ( offset -- ) local, postpone rp! ;
: (local DOES> @ local, postpone @ ;
: f>r r> rp@ 1 floats - dup rp! f! >r ;
: (flocal DOES> @ local, postpone f@ ;
: <local ( -- sys1 ) current @ @ loffset @ locals @ ; immediate
: do-nothing ;
: ralign r>
BEGIN rp@ [ 1 floats 1- ] Literal and
WHILE [ ' do-nothing >body ] ALiteral >r
REPEAT >r ;
: <local ( -- sys1 ) current @ @ loffset @ locals @
over 0= IF postpone ralign THEN ; immediate
: local: ( -- ) postpone >r last @ lastcfa @ here locals @ dp !
cell loffset +! Create loffset @ , immediate (local
here locals ! dp ! lastcfa ! last ! ; immediate
: flocal: ( -- ) last @ lastcfa @ here locals @ dp !
BEGIN loffset @ 0 1 floats fm/mod drop WHILE
0 postpone Literal postpone >r 1 cells loffset +! REPEAT
postpone f>r Create loffset @ , immediate (flocal
here locals ! dp ! lastcfa ! last ! ; immediate
: local> ( sys1 -- sys2 ) ; immediate
: local; ( sys2 -- ) locals ! dup delocal,
loffset ! current @ ! ; immediate
: TO >in @ ' dup @ [ ' (local >body cell+ ] ALiteral =
IF >body @ local, postpone ! drop
ELSE drop >in ! postpone to THEN ; immediate
: EXIT loffset @ IF 0 delocal, THEN postpone EXIT ; immediate
ELSE dup @ [ ' (flocal >body cell+ ] ALiteral =
IF >body @ local, postpone f! drop
ELSE drop >in ! postpone to THEN THEN ; immediate
: DO 2 cells loffset +! postpone DO ; immediate restrict
: ?DO 2 cells loffset +! postpone ?DO ; immediate restrict
......@@ -36,6 +51,12 @@ Variable locals here locals ! 100 ( some) cells allot
BEGIN dup 0< 0= WHILE >in ! postpone local: REPEAT drop
r> >in ! postpone local> ; immediate restrict
: F{ postpone <local -1
BEGIN >in @ name dup c@ 1 = swap 1+ c@ '| = and UNTIL
drop >in @ >r
BEGIN dup 0< 0= WHILE >in ! postpone Flocal: REPEAT drop
r> >in ! postpone local> ; immediate restrict
' local; alias } immediate restrict
\ ANS Locals 19aug93py
......@@ -64,6 +85,7 @@ Create inlocal 5 cells allot inlocal off
: ; ?local; postpone ; ; immediate restrict
: DOES> ?local; postpone DOES> ; immediate
: EXIT inlocal @ IF 0 delocal, THEN postpone EXIT ; immediate
: locals|
BEGIN name dup c@ 1 = over 1+ c@ '| = and 0= WHILE
......
/*
$Id: primitives,v 1.1 1994-02-11 16:30:46 anton Exp $
$Id: primitives,v 1.2 1994-04-20 17:12:06 pazsan Exp $
Copyright 1992 by the ANSI figForth Development Group
WARNING: This file is processed by m4. Make sure your identifiers
......@@ -194,6 +194,10 @@ fflush(stdout);
/* !! noecho */
n = key();
key? -- n fig key_q
fflush(stdout);
n = key_query;
cr -- fig
puts("");
......@@ -591,6 +595,25 @@ wfileid=(Cell)popen(pname,mode[n]);
pclose wfileid -- wior own
wior=pclose((FILE *)wfileid);
time&date -- nyear nmonth nday nhour nmin nsec ansi time_and_date
struct timeval time1;
struct timezone zone1;
struct tm *ltime;
gettimeofday(&time1,&zone1);
ltime=localtime(&time1.tv_sec);
nyear =ltime->tm_year+1900;
nmonth=ltime->tm_mon;
nday =ltime->tm_mday;
nhour =ltime->tm_hour;
nmin =ltime->tm_min;
nsec =ltime->tm_sec;
ms n -- ansi
struct timeval timeout;
timeout.tv_sec=n/1000;
timeout.tv_usec=1000*(n%1000);
(void)select(0,0,0,0,&timeout);
allocate u -- a_addr wior memory
a_addr = (Cell *)malloc(u);
wior = a_addr==NULL; /* !! define a return code */
......
......@@ -7,6 +7,7 @@ include float.fs
include search-order.fs
\ include toolsext.fs
include wordinfo.fs
include vt100.fs
\ include colorize.fs
include see.fs
include bufio.fs
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment