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