foundation.clvr

9  constant: '\t'
10 constant: '\n'
27 constant: '\e'

: end-of-comment? '\n' eq? ;
: -- #immediate ' end-of-comment? scan   drop  ;
-- now we have comments. Yay!

: c: #immediate
	-- compile a (possibly multi-byte) char
	word
	1 cell + @
	compile-literal
;

: spc 'spc' putc ;

: before - ;
: after + ;

-1 constant: true
0  constant: false

: cells cell ;

: kiB  10 bits-up ;
: MiB  20 bits-up ;
: GiB  30 bits-up ;

: div divmod drop ;
: mod divmod nip ;

: prev-cell here 1 cell before ;
: next-cell here 1 cell after ;

: exception: #immediate
	create-variable
;

: compile-jump    ,   here   0 ,  ;   --   instr -- addr
: compile-unconditional-jump   ' branch  compile-jump ;
: compile-conditional-jump     ' zbranch compile-jump ;
: jump-target   dup   here swap -   swap !  ;

variable: if-nesting-depth
: if   compile-conditional-jump   if-nesting-depth inc-var ; #immediate
: else #immediate
	compile-unconditional-jump push
	jump-target
	pop
;
: endif   jump-target   if-nesting-depth dec-var  ; #immediate

-- convert between string types
: s->z  --   str -- zstr len
	dup 1 cell after
	swap @
;
exception: ZStringTransformationNotImplemented
: z->s  --   zstr len -- str
	swap stash
	1 cell before @
	matches? if
		pop 1 cell before
	else
		trash ZStringTransformationNotImplemented raise
	endif
;


	-- TODO: modify c: to use Unicode code points instead of raw UTF-8
	-- TODO: modify putc to support multibyte chars

: debug
	WordBuffer puts spc
	stash putn
	spc
	'(' putc
	'0' putc
	'x' putc
	peek putx
	-- peek toEntry dup if
	-- endif
	peek 31 128 between? if
		spc
		''' putc
		peek putc
		''' putc
	endif
	')' putc
	pop
	report
;

-- macro: : -- replace with debugging version
	-- word words
	-- here debug drop
	-- define
-- ;

: while-word  --  S ( word -> bool ) -> T
	-- consume words until the passed function
	-- returns false
	push
	word peek call if 
		pop
		tail: while-word
	else
		trash
	endif
;

: _nested-comment   --  n word -- n bool
	1 cell after @ 
	stash ')' eq? if
		1 -
		trash
	else
		pop '(' eq? if 1 + endif
	endif
	dup bool
;

: ( #immediate
	1   -- track the depth of the nesting
	' _nested-comment while-word
	drop
;

: scratchpad
	scratchpad-addr @
;

-- let's implement pattern matching
variable: pattern-match-depth
variable: rs-usage

: unbalanced-rs-error
	current-def @ .label 
	UnbalancedRSInBranch 2 warning 
;
: -> #immediate
	' matches? ,
	compile-conditional-jump
	rs-usage @
	pattern-match-depth inc-var
;
: ;; #immediate
	' return ,
	rs-usage @  if   unbalanced-rs-error   endif
	rs-usage !
	jump-target
	pattern-match-depth dec-var
;
-- macro: _ ' dup , ;
: _ #immediate
	word drop   -- consume ->
	scratchpad  -- somewhere for jump-target to write to
	-- this is the last part of the match, so we don't keep rs-usage. Doing so 
	-- would generate spurious unbalanced-rs-error exceptions
	0 -- rs-usage @
	pattern-match-depth inc-var -- because we've dumped the ->
;

( : base-literal  ( n -> n )
	word swap base
	true -> drop ;;
	false ->
		drop drop
		WordBuffer
		NumParse 2 compile-error
	;;
;

: bin:  2 base-literal compile-literal ; #immediate
: oct:  8 base-literal compile-literal ; #immediate
: hex: 16 base-literal compile-literal ; #immediate
)
: nextEntry @ ;


variable: stringTerminator

: handleStringEsc ( c -- )
	'e' -> drop '\e' ;;
	'n' -> drop '\n' ;;
	't' -> drop '\t' ;;
	'0' -> drop   0  ;;
	stringTerminator @
	    ->           ;;
	'\' ->           ;;
	_   -> -- Invalid escape. TODO: proper error handling!
		-- s" \\x" dup   1 cell after   1+  ! -- addr of x in preceding string
		WordBuffer InvalidEsc 2 compile-error 
	;;
;

: _string  ( char bool -- )
	-- boolean indicates whether the next character is 
	-- escaped
	if  ( escape chars. )
		key handleStringEsc ,c false _string
	else
		key 
		stringTerminator @ -> drop ;;
		'\'  -> drop  true _string ;;
		_    -> ,c   false _string ;;
	endif
;

: compileZString ( char -- zstr )
	stringTerminator !
	here
	false _string
	here 1+ align
	0 , 0 ,
	dp!
;

: compileString ( char -- str )
	here push
	0 ,
	compileZString
	lenz peek !
	pop
;

: compileInlineString ( char -- )
	compile-unconditional-jump
	swap compileString
	swap jump-target
	compile-literal
;

: s" #immediate
	'"' compileInlineString
;

: z" #immediate
	compile-unconditional-jump
	'"' compileZString
	swap jump-target
	compile-literal
;

-- empty-string constant
: "" s" " ;

-- dictionary accessor convenience functions
: cfa->entry ( cfa -- entry )
	3 cells before
;
: cfa->label ( cfa -- str )
	2 cells before
;
: cfa->pfa 1 cell after ;


-- Compile-time execution support

variable: close-bracket-behaviour

: unmatchedBracket s" Unmatched ]" 1 compile-error ;

: startImmedCodeBlock  ( -- addr )
	here 
	anon-code-area-addr @ dp!
	DoAddr ,
;
: endImmedCodeBlock  ( oldDp -- ?? )
	' return ,
	dp! anon-code-area-addr @ call
;
: #[  (  -- oldDp prevBehav ) #immediate
	close-bracket-behaviour @
	' endImmedCodeBlock close-bracket-behaviour !
	startImmedCodeBlock swap
	-- report
;

-- anonymous function support
: endAnonCodeBlock ( lambda jaddr -- )
	' return ,
	jump-target
	compile-literal
;
: again #immediate
	anon-code-area-addr @ call
;
: [  ( -- lambda jaddr prevBehav ) #immediate
	-- s" [ " puts report
	compile-unconditional-jump
	here swap
	DoAddr ,
	close-bracket-behaviour @
	' endAnonCodeBlock close-bracket-behaviour !
	-- report
;

-- generic code block closing function
: ]  ( prevBehav -- ) #immediate
	-- report
	close-bracket-behaviour @ push
	close-bracket-behaviour !
	pop call
	-- report c: ] putc nl nl
;

: [] [ ] ;

' unmatchedBracket close-bracket-behaviour !


: times #immediate
	' push ,
	here
	' peek ,
	compile-conditional-jump
	' pop ,
	' 1- ,
	' push ,
	swap
;

: forever #immediate
	-1 compile-literal
	' push ,
	here
	' peek , -- ' debug ,
	compile-conditional-jump
	swap
;

: repeat #immediate
	next-cell -
	compile-unconditional-jump
	!
	jump-target
	' trash ,
;

(
: seeEntry ( entry -- )
	'(' putc .label puts ')' putc nl return
	
	findWord dup if
		':' putc spc 'spc'
	else
		'(' putc ')'
	endif
	pop .label puts
	putc nl
;

: seeWords  words  ' seeEntry each ;
: seeMacros macros ' seeEntry each ;

: see ( cfa -- )
	cfa->entry seeEntry
;
)
: allot ( n -- )
	here + align dp!
;

: not-imlemented
	s"  declared but not implemented."
	peek 5 cells before .label
	2 compile-error
;

: declare: #immediate
	-- allow forward declarations. Provide an implementation
	-- using 'implements:'
	create-word
	' not-imlemented ,
	' return ,
	done-compiling
;

: implements
	-- Warning: complex behaviour! takes the CFA at its return address
	-- and re-writes the PF with the function in ToS
	pop dup 1 cell after push -- skip the next compiled word
	@ 1 cell after stash !
	' return pop 1 cell after !   -- 
;

: prior:  #immediate
	-- compile a word, ignoring the currently in-progress definition
	word dup current-def @ find
	0 -> drop NotFound 2 compile-error ;;
	_ -> .cfa , drop ;;
;
: suppress-macro: #immediate
	word dup words find
	0 -> drop NotFound 2 compile-error ;;
	_ -> .cfa , drop ;;
;


: close ( fh -- )
	prior: close
	0 -> drop ;;
	_ -> drop s" Closing file failed" 1 error ;;
;


-- RS safety checks ------------------------------------------

: stash #immediate
	rs-usage inc-var
	' suppress-macro: stash ,
;
: push #immediate
	rs-usage inc-var
	' suppress-macro: push ,
;
: pop #immediate
	rs-usage dec-var
	' suppress-macro: pop ,
;
: trash #immediate
	rs-usage dec-var
	' suppress-macro: trash ,
;

: _done
	-- this gives us some static error checking on RS usage and nesting of conditionals
	rs-usage @ if 
		current-def @ .label
		s" Possibly unbalanced RS use in definition of " 2 warning
		0 rs-usage !
	endif
	if-nesting-depth @ if
		current-def @ .label
		s" Unmatched if or endif in definition of " 2 warning
		0 if-nesting-depth !
	endif
	pattern-match-depth @ if
		current-def @ .label
		s" Unmatched -> or ;; in definition of " 2 warning
		0 pattern-match-depth !
	endif
	tail: compile-;
; 

: ;  tail: _done ; #immediate

-- structures
: struct: #immediate
	create-word
	' here ,
	' lit ,
	here push 0 ,
	' allot ,
	compile-;
	pop
	0
	-- s" struct: " puts
	-- dup putn 
;
: end #immediate
	-- s" link" findWord putx
	-- dup putn spc
	-- nl
	align swap !
;

: _field  ( n1 n2 -- n )
	create-word
	swap dup compile-literal
	' + ,
	compile-;
	+
	-- spc dup putn
;
: cell: ( tot n -- tot' ) #immediate
	1 cell _field
;
: field: _field ; #immediate

: sizeof: ( -- n ) #immediate
	word findWord .pfa 2 cells after @ align compile-literal
;

: _see-data-stack 
	s"  ds(" puts

	dsp@ push
	ds0 @
	dup
	pop - CellBits bits-down 
	dup putn
	s" ): " puts
	times
		1 cell before
		stash @ stash putn
		s"  0x" puts 
		peek putx
		peek 32 128 between? if
			spc s" '" puts
			peek putc
			''' putc
		endif
		s"   " puts
		spc
		trash pop
	repeat
	drop
	nl
;

: see-data-stack #immediate
	current-def @ .label compile-literal
	' puts ,
	':' compile-literal
	' putc ,
	here current-def @ .pfa - CellBits bits-down compile-literal
	' putn ,
	' spc ,
	' _see-data-stack ,
;


: cons ( elem list -- )
	-- Warning: this presumes the first cell of elem
	-- is reserved for a list pointer
	stash @ ( list-head )  swap  stash !  -- store prev head in link fld of elem
	pop ( elem )   pop ( list )   !       -- store addr of elem in list
;

: uncons  ( list -- elem )
	-- Destructively remove the first elem of list
	dup @ ( list elem )
	push  ( list )
	dup @ @ swap !
	pop
;

-- Date, time and decimal output functions

: leading-zero
	9 le? if   '0' putc   endif
;

: explode-time ( t -- h m s )
	60 divmod push
	60 divmod push
	pop pop
;
: puttime  ( t -- )
	explode-time
	push push
	dup       leading-zero putn   ':' putc
	pop dup   leading-zero putn   ':' putc
	pop dup   leading-zero putn
;

146097 constant: 4Centuries
36524  constant: 1Century
1461   constant: 4Years
365    constant: 1Year
153    constant: 5Months

1600   constant: BaseDate

: _make-year  ( 4cs 1c 4ys 1y 5ms -- ys )
	2 eq?  if  1+  endif
	swap    4 *   +
	swap  100 *   +
	swap  400 *   +
	BaseDate +
;
: _make-month-and-day  ( ds -- ms ds )
	stash  31 +   5 *  5Months div   2 +
	pop   over 1+   5Months *   5 div   -   123 +
	push
	dup 13 ge? if
		12 -
	endif
	pop
;

: explode-date  ( date -- y m d )
	LilianCorrection 1+ -
	4Centuries divmod 
	4Centuries 1- ->  -- Date is Feb 29th of a 400th year
		drop   1+   400 *   BaseDate +
		2 29
	;;
	1Century divmod
	4Years   divmod   -- stack: 4cs 1cs 4ys r
	4Years 1- ->      -- Date is Feb 29th of a 4th year
		drop 
		1+  4 *
		swap   100 *  +     swap   400 *  +     BaseDate +
		2 29
	;;
	1Year divmod    -- ds: 4cs 1c 4ys 1y r
	stash
	5Months divmod  -- ds: 4cs 1c 4ys 1y 5ms r

	drop _make-year   pop _make-month-and-day
;
: putdate  ( date -- )
	explode-date 
	push push            putn   '-' putc
	pop dup leading-zero putn   '-' putc
	pop dup leading-zero putn
;

: putd  ( decimal -- )
	-- TODO: discard low-order zeroes for neatness
	putsign
	decimal-places @ times
		10 divmod swap
	repeat
	putn
	'.' putc
	decimal-places @ times
		'0' + putc
	repeat
;

: pi ( -- d )
	s" 3.1415926535898" number drop
;

60 60 24 * * constant: SecondsInADay
1970-01-01   constant: UnixEpoch

3600 constant: Hour
variable: tz

: hour Hour * ;

: GMT ;
: BST  1 hour + ;

' BST tz !

: now ( -- date time )
	-- WARNING: time is UTC.
	0 SysTime syscall1
	tz @ call
	SecondsInADay divmod push   UnixEpoch +   pop
;
: today ( -- date ) now drop ;
: time  ( -- time ) now nip  ;

: decimal-scaling-factor s" 1.0" number drop ;

: decimal-places
	prior: decimal-places ! 
;

: *d  ( n d -- n )
	-- multiply a number by a decimal, rescaling
	-- the result to the same number of decimal
	-- places as n
	decimal-scaling-factor */
;
: /d   ( n d -- n )
	-- ...same for division
	decimal-scaling-factor swap */
;

2 decimal-places ;

exception: CouldNotSleep

: nsleep ( s ns -- )
	-- sleep for s seconds and ns nanoseconds
	push push
	0 rsp@  SysNanosleep  syscall2
	trash trash
	if raise CouldNotSleep endif
;
: sleep ( n -- ) 
	-- Sleep for n seconds
	0 nsleep
;

: dump-dicts
	[ .label puts spc ] push
	words peek each
	macros pop each
;


: _find-word-for-addr  ( addr dict -- entry )
	0 -> swap drop ;;
	@ push
	dup peek gt? if
		-- macro suppression to prevent spurious return stack 
		-- usage warning. TODO remove suppression when if
		-- blocks perform correct return-stack counting
		-- gymnastics!
		drop suppress-macro: pop return 
	else
		pop tail: _find-word-for-addr
	endif
;

: find-word-for-addr ( addr -- entry? )
	words _find-word-for-addr
;

: trace-line  ( addr -- )
	stash putx spc
	s" in " puts
	peek is-anon? if
		s" <anonymous area>" puts
	else
		peek find-word-for-addr
		dup putx spc
		.label puts
	endif
	trash nl
;
: backtrace
	rsp@
	rs-depth times
		peek putn spc
		dup @ trace-line
		1 cell after
	repeat
;

( The following macros are wrappers that combine the behaviour of the output
functions (put*) with forcing execution of the immediate code area, based on
the observation that the most common use-case in the repl is evaluating an
expression )

: =  ( n -- )  #immediate
	-- output a base 10 number
	' putn , go
;
: =h ( n -- ) #immediate
	-- same for hex
	' putx , go
;
: =o ( n -- ) #immediate
	-- and octal
	8 compile-literal
	' putnumber , go
;
: =b ( n -- ) #immediate
	-- and binary
	2 compile-literal
	' putnumber , go
;
: =d ( d -- ) #immediate
	-- output a decimal
	' putd , go
;
: =date ( date -- ) #immediate
	' putdate , go
;
: =time ( time -- ) #immediate
	' puttime , go
;
: =z ( zstr -- ) #immediate
	' putz , go
;
: =s ( str -- ) #immediate
	' puts , go
;

: cancel #immediate
	ds0 @ dsp!
	reset
;


1 constant: TypeNum
2 constant: TypeXt
3 constant: TypeAddr
4 constant: TypeStr
5 constant: TypeZStr



: is-dict-addr?  ( n -- bool )
	heap-base-addr here between?
;
: is-type-xt?
	dup is-dict-addr? not   if drop false return endif
	dup @
	DoAddr      -> drop drop true ;;
	DoDoesAddr  -> drop drop true ;;
	DoConstAddr -> drop drop true ;;
	_           -> 1 cell before eq? ;;
;

: get-type
	-- heuristically determine the type of value on ToS
	
;

-- vim:ft=cantilever