Adding WIP w/ gemini example.
This commit is contained in:
Brad Nelson
131
examples/gemini/arrays.fs
Executable file
131
examples/gemini/arrays.fs
Executable file
@ -0,0 +1,131 @@
|
||||
#! /usr/bin/env ueforth
|
||||
|
||||
vocabulary arrays also internals also arrays definitions
|
||||
|
||||
128 constant stack-depth
|
||||
|
||||
( Stack for arrays )
|
||||
create astack stack-depth cells allot
|
||||
variable ap astack ap !
|
||||
: apush ( a -- ) cell ap +! ap @ ! ;
|
||||
: apop ( -- a ) ap @ @ cell negate ap +! ;
|
||||
: top ( -- a ) ap @ @ ;
|
||||
: under ( -- a ) ap @ cell - @ ;
|
||||
|
||||
( Secondary stack for arrays )
|
||||
create arstack stack-depth cells allot
|
||||
variable arp arstack arp !
|
||||
: >a apop cell arp +! arp @ ! ;
|
||||
: a> arp @ @ cell negate arp +! apush ;
|
||||
|
||||
( Array types )
|
||||
0 constant MIXED
|
||||
1 constant STRING
|
||||
2 constant INTEGER
|
||||
3 constant REAL
|
||||
create array-sizes cell , 1 , cell , 4 ,
|
||||
: >esize ( type -- n ) cells array-sizes + @ ;
|
||||
|
||||
\ ref n ^type data...
|
||||
3 cells constant header-size
|
||||
: >type ( a -- a ) -1 cells + ;
|
||||
: >count ( a -- a ) -2 cells + ;
|
||||
: >ref ( a -- a ) -3 cells + ;
|
||||
|
||||
( Size of array data in bytes )
|
||||
: bytes ( a -- n ) dup >type @ >esize swap >count @ * ;
|
||||
|
||||
( Create an uninitialized array )
|
||||
: array ( n type -- a )
|
||||
2dup >esize * header-size + allocate throw header-size + apush
|
||||
top >type ! top >count ! 0 top >ref ! ;
|
||||
|
||||
( Reference counting for arrays )
|
||||
: ref ( a -- ) 1 over >ref +! ;
|
||||
: unref ( a -- )
|
||||
dup 0= if drop exit then
|
||||
-1 over >ref +!
|
||||
dup >ref @ 0< if
|
||||
dup >type @ MIXED = if
|
||||
dup dup >count @ 0 ?do
|
||||
dup @ recurse cell+
|
||||
loop
|
||||
drop
|
||||
then
|
||||
header-size - free throw exit
|
||||
then drop ;
|
||||
|
||||
( Stack manipulation )
|
||||
: adrop ( a: a -- ) apop unref ;
|
||||
: anip ( a: a b -- b ) apop apop unref apush ;
|
||||
: adup ( a: a -- a a ) top ref apush ;
|
||||
: aswap ( a: a b -- b a ) apop apop swap apush apush ;
|
||||
|
||||
( Index into the top of the stack )
|
||||
: a@ ( n a: a -- a: a ) cells top + @ ref adrop apush ;
|
||||
|
||||
( Raw array creation words )
|
||||
: empty ( -- a: a ) 0 MIXED array ;
|
||||
: box ( a: a -- a ) apop 1 MIXED array top ! ;
|
||||
: _s ( a n -- a: a ) dup STRING array top swap cmove ;
|
||||
: _c ( ch -- a: a ) 1 STRING array top c! ;
|
||||
: _i ( n -- a: a ) 1 INTEGER array top ! ;
|
||||
: _f ( f: n -- a: a ) 1 REAL array top sf! ;
|
||||
: _s" postpone s" state @ if postpone _s else _s then ; immediate
|
||||
|
||||
: aconstant create apop , does> @ ref apush ;
|
||||
|
||||
( Convert integer array to floats )
|
||||
: n>f
|
||||
top >count @ REAL array
|
||||
under top top >count @ 0 ?do over @ s>f dup sf! sfloat+ >r cell+ r> loop 2drop anip ;
|
||||
|
||||
( Force integers to real. )
|
||||
: binuminal
|
||||
top >type @ INTEGER = under >type @ REAL = and if n>f then
|
||||
under >type @ INTEGER = top >type @ REAL = and if apop n>f apush then
|
||||
;
|
||||
|
||||
0 value layer
|
||||
: lst ( a -- )
|
||||
layer spaces
|
||||
dup >type @ case
|
||||
MIXED of
|
||||
." [" cr
|
||||
2 +to layer
|
||||
dup >count @ 0 ?do
|
||||
dup @ recurse cell+ cr
|
||||
loop
|
||||
drop
|
||||
-2 +to layer
|
||||
layer spaces ." ]"
|
||||
endof
|
||||
STRING of dup >count @ type endof
|
||||
INTEGER of dup >count @ 0 ?do dup @ . cell+ loop drop endof
|
||||
REAL of dup >count @ 0 ?do dup sf@ f. sfloat+ loop drop endof
|
||||
endcase
|
||||
;
|
||||
: a. ( a -- ) top lst adrop ;
|
||||
|
||||
: catenate ( a: a a -- a ) ( catenate )
|
||||
binuminal
|
||||
top >type @ under >type @ = if
|
||||
under >count @ top >count @ + top >type @ array apop >r
|
||||
under r@ under bytes cmove
|
||||
top r@ under bytes + top bytes cmove
|
||||
under under bytes 0 fill
|
||||
top top bytes 0 fill
|
||||
r> apush anip anip
|
||||
exit
|
||||
then
|
||||
top >type @ MIXED = if apop box apush recurse exit then
|
||||
under >type @ MIXED = if box recurse exit then
|
||||
apop apop 2 MIXED array top cell+ ! top !
|
||||
;
|
||||
: ,c catenate ;
|
||||
|
||||
( Building arrays on the stack. )
|
||||
: [[ ap @ ;
|
||||
: ]] ap @ swap - cell/ empty for aft aswap box aswap ,c then next ;
|
||||
|
||||
previous previous forth definitions
|
||||
63
examples/gemini/gemini.fs
Executable file
63
examples/gemini/gemini.fs
Executable file
@ -0,0 +1,63 @@
|
||||
#! /usr/bin/env ueforth
|
||||
|
||||
needs arrays.fs
|
||||
needs json.fs
|
||||
needs slurp.fs
|
||||
|
||||
vocabulary gemini also json also arrays also gemini definitions
|
||||
|
||||
: askit { a n -- a }
|
||||
{{
|
||||
[[ _s" contents" [[
|
||||
{{
|
||||
[[ _s" parts" [[
|
||||
{{
|
||||
[[ _s" text" a n _s ]]
|
||||
}}
|
||||
]] ]]
|
||||
}}
|
||||
]] ]]
|
||||
}}
|
||||
;
|
||||
|
||||
s" What's the time?" askit >json a.
|
||||
|
||||
0 [IF]
|
||||
HTTPClient
|
||||
NetworkClientSecure.new constant nclient
|
||||
|
||||
: 2constant create , , does> dup cell+ @ swap @ ;
|
||||
|
||||
: slurp-file ( a n -- a n )
|
||||
r/o open-file throw >r
|
||||
r@ file-size throw ( sz )
|
||||
dup 1+ allocate throw swap ( data sz )
|
||||
2dup r@ read-file throw drop
|
||||
r> close-file throw
|
||||
2dup + 0 swap c!
|
||||
;
|
||||
|
||||
s" /spiffs/gemini_cert" slurp-file drop constant cacert
|
||||
s" /spiffs/gemini_url" slurp-file drop constant url
|
||||
s" /spiffs/question" slurp-file 2constant question
|
||||
|
||||
cacert nclient NetworkClientSecure.setCACert
|
||||
." loaded cert:" cr
|
||||
cacert z>s type cr
|
||||
|
||||
HTTPClient.new constant session
|
||||
." created session" cr
|
||||
." URL: " url z>s type cr
|
||||
url nclient session HTTPClient.beginNC ." beginNC: " . cr
|
||||
1 session HTTPClient.setFollowRedirects
|
||||
10 session HTTPClient.setRedirectLimit
|
||||
." set follow redirects and limit of 10" cr
|
||||
." question: " question type
|
||||
z" POST" question session HTTPClient.sendRequest ." POSTED: " . cr
|
||||
|
||||
session HTTPClient.getStreamPtr constant result
|
||||
result NetworkClient.available ." available: " dup . cr
|
||||
|
||||
[THEN]
|
||||
|
||||
previous previous previous forth definitions
|
||||
154
examples/gemini/json.fs
Executable file
154
examples/gemini/json.fs
Executable file
@ -0,0 +1,154 @@
|
||||
#! /usr/bin/env ueforth
|
||||
|
||||
needs arrays.fs
|
||||
|
||||
vocabulary json also internals also arrays also json definitions
|
||||
|
||||
defer getchar
|
||||
-1 value token
|
||||
: skip getchar to token ;
|
||||
|
||||
variable insource
|
||||
variable inlength
|
||||
: in ( a n -- ) inlength ! insource ! skip ;
|
||||
: ingetchar ( -- n )
|
||||
inlength @ 0= if -1 exit then
|
||||
insource @ c@ 1 insource +! -1 inlength +! ;
|
||||
' ingetchar is getchar
|
||||
|
||||
s" DICTIONARY" _s aconstant DICT
|
||||
: {{ [[ DICT ;
|
||||
: }} ]] ;
|
||||
|
||||
: space? ( ch -- f ) dup 8 = over 10 = or over 13 = or swap 32 = or ;
|
||||
: whitespace begin token space? while skip repeat ;
|
||||
: expect ( a n -- ) for aft dup c@ token = assert 1+ skip then next drop ;
|
||||
: sliteral ( a n -- ) postpone $@ dup , zplace ;
|
||||
: e: bl parse sliteral postpone expect ; immediate
|
||||
|
||||
: escaped
|
||||
e: \
|
||||
token skip case
|
||||
[char] " of [char] " _c catenate endof
|
||||
[char] \ of [char] \ _c catenate endof
|
||||
[char] / of [char] / _c catenate endof
|
||||
[char] b of 8 _c catenate endof
|
||||
[char] n of nl _c catenate endof
|
||||
[char] r of 13 _c catenate endof
|
||||
[char] t of 8 _c catenate endof
|
||||
[char] u of 255 _c catenate skip skip skip skip endof
|
||||
-1 throw
|
||||
endcase
|
||||
;
|
||||
|
||||
: jstring
|
||||
e: " s" " _s
|
||||
begin token [char] " <> while
|
||||
token [char] \ = if
|
||||
escaped
|
||||
else
|
||||
token _c catenate
|
||||
skip
|
||||
then
|
||||
repeat
|
||||
e: "
|
||||
;
|
||||
|
||||
defer jvalue
|
||||
|
||||
: jobject
|
||||
e: { whitespace
|
||||
DICT box
|
||||
begin
|
||||
token [char] } = if skip exit then
|
||||
jstring box whitespace e: : whitespace jvalue box
|
||||
catenate box catenate
|
||||
token [char] } = if skip exit then
|
||||
e: , whitespace
|
||||
again
|
||||
e: }
|
||||
;
|
||||
|
||||
: digit? ( -- f ) token [char] 0 >= token [char] 9 <= and ;
|
||||
: jdigit token [char] 0 - skip ;
|
||||
: jinteger digit? assert jdigit
|
||||
begin digit? while 10 * jdigit + repeat ;
|
||||
: jfraction digit? assert 10 * jdigit + >r 1- r>
|
||||
begin digit? while 10 * jdigit + >r 1- r> repeat ;
|
||||
: jnumber
|
||||
token [char] - = if skip -1 else 1 then
|
||||
token [char] 0 = if skip 0 else jinteger then 0 swap
|
||||
token [char] . = if skip jfraction then
|
||||
swap >r * r>
|
||||
token [char] e = token [char] E = or if
|
||||
skip
|
||||
token [char] - = if
|
||||
skip -1
|
||||
else
|
||||
token [char] + = if skip then 1
|
||||
then
|
||||
jinteger * +
|
||||
then
|
||||
dup if 10e s>f f** s>f f* _f else drop _i then
|
||||
;
|
||||
|
||||
: jarray
|
||||
e: [ whitespace
|
||||
0 MIXED array
|
||||
begin
|
||||
token [char] ] = if skip exit then
|
||||
jvalue box catenate whitespace
|
||||
token [char] ] = if skip exit then
|
||||
e: , whitespace
|
||||
again
|
||||
;
|
||||
|
||||
:noname
|
||||
whitespace
|
||||
token case
|
||||
[char] " of jstring endof
|
||||
[char] { of jobject endof
|
||||
[char] [ of jarray endof
|
||||
[char] t of e: true s" true" _s endof
|
||||
[char] f of e: false s" false" _s endof
|
||||
[char] n of e: null s" null" _s endof
|
||||
jnumber
|
||||
endcase
|
||||
whitespace
|
||||
; is jvalue
|
||||
|
||||
: json> ( a -- a ) top top >count @ in jvalue anip ;
|
||||
|
||||
: butlast? ( n -- f ) top >count @ 1- <> ;
|
||||
|
||||
: >json ( a: a -- a )
|
||||
top >type @ case
|
||||
MIXED of
|
||||
top >count @ 1 > if top @ DICT top @ adrop = else 0 then if
|
||||
_s" {" >a top >count @ 1 ?do
|
||||
adup i a@ 0 a@ recurse _s" :" ,c a> aswap ,c >a
|
||||
adup i a@ 1 a@ recurse a> aswap ,c >a
|
||||
i butlast? if a> _s" ," ,c >a then
|
||||
loop a> _s" }" ,c
|
||||
else
|
||||
_s" [" >a top >count @ 0 ?do
|
||||
adup i a@ recurse a> aswap ,c >a
|
||||
i butlast? if a> _s" ," ,c >a then
|
||||
loop a> _s" ]" ,c
|
||||
then
|
||||
endof
|
||||
STRING of [char] " _c >a top top >count @ a> _s ,c [char] " _c ,c endof
|
||||
INTEGER of
|
||||
_s" " >a
|
||||
top >count @ 0 ?do
|
||||
top i cells + @ <# #s #> a> _s" " ,c _s ,c >a
|
||||
loop a> endof
|
||||
REAL of
|
||||
_s" " >a top >count @ 0 ?do
|
||||
top i sfloats + sf@ <# #fs #> a> _s" " ,c _s ,c >a
|
||||
loop a> endof
|
||||
endcase
|
||||
anip
|
||||
;
|
||||
|
||||
previous previous previous forth definitions
|
||||
8
examples/gemini/slurp.fs
Normal file
8
examples/gemini/slurp.fs
Normal file
@ -0,0 +1,8 @@
|
||||
: slurp-file ( a n -- a n )
|
||||
r/o open-file throw >r
|
||||
r@ file-size throw ( sz )
|
||||
dup 1+ allocate throw swap ( data sz )
|
||||
2dup r@ read-file throw drop
|
||||
r> close-file throw
|
||||
2dup + 0 swap c!
|
||||
;
|
||||
Reference in New Issue
Block a user