core.clvr

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

: --   [ '\n' = ] scan-in   ;   #immediate

-- and now we have comments. Yay!

-- allow aliasing of existing words without adding a
-- layer of indirection
: alias:  #immediate  -- ( xt -- )  ( -- )
	create-immed  ,    -- store the word being aliased
	does        @ ,  -- when called compile the aliased word
;

-- Lets us hide the current definition and call an earlier definition with 
-- the same name...
: #hidden   #immediate   dictionary @ .label   dec-var ;
: #visible  #immediate   dictionary @ .label   inc-var ;

-- make address manipulation more readable...
' cell alias: cells
' -    alias: before
' +    alias: after

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

-- a couple more readability constants...
-1 constant: true
0  constant: false

-- missing arithmetic
: /  /mod drop  ;  #inline

-- Text highlighting
: warning     WarningColour colour ;
: uncoloured  NoColour colour ;

-- now let's implement conditionals
: compile-jump     ,    here    0 ,  ;        --  xt -- addr
: compile-conditional-jump   ' zbranch  compile-jump ;
: compile-unconditional-jump ' branch   compile-jump ;
: jump-target   dup   here swap -   swap !  ;

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

-- exceptions are basically just variables
: exception:   #immediate    create-variable  ;

-- next up nestable block comments
: while-word  --   xt --
	-- consume words until the passed function returns false
	push
	word peek call if 
		pop
		tail: while-word
	else
		trash
	endif
;
: _nestable-comment   --  n word -- n bool
	1 cell after @     -- skip the word's length count
	stash ')' =    if  -- does the word equal ")"?
		1 -            -- yes, then reduce the depth count
		trash          -- and discard the saved word
	else
		pop '(' =  if 1 + endif  -- else if the word is (, increase the depth
	endif
	dup bool           -- convert the depth to a canonical boolean
;
: (    #immediate    1  ' _nestable-comment while-word    drop ;
( and now we have better comments! ( because they can be
  nested, and can span multiple lines ) )

-- Get and Set with post-increment (@+ is now a prim)
: !+  ( x addr -- addr' )   stash !   pop 1 cell after   ;   #inline
: !-  ( x addr -- addr' )   stash !   pop 1 cell before  ;   #inline
-- : @+  ( addr -- addr' x )   stash 1 cell after   pop @   ;

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

( : unbalanced-rs-error
	UnbalancedRSInBranch   warns
	warning    dictionary @ .label  warns    uncoloured
; )
: ->    #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
;
' dup alias: _

( : forever    #immediate
	here ' lit , , ' push ,
	scratchpad-addr  -- somewhere for repeat to write to
;
: times      #immediate #hidden   ( -- addr )
	' lit , here 0 , ' push ,  -- push the address to return to at end of loop
	' times ,                  -- compile call to previous definition of times
; #visible
: repeat     #immediate
	' return ,
	here swap !
; )

-- Imperative looping
: times      #immediate   ( n -- )
	' push ,					-- push i
	here   ' peek ,				-- this is where we jump back to
	compile-conditional-jump    -- jump out of loop if i==0
	' pop , ' 1- , ' push ,     -- decrement the counter
	swap                        -- leave NoS:exit-jump ToS:start-of-loop
;
: forever    #immediate
	-1 compile-literal
	' push ,   here   ' peek ,
	compile-conditional-jump
	swap
;
: repeat     #immediate    ( exit-jump start-of-loop  --  )
	next-cell -    compile-unconditional-jump   !
	jump-target
	' trash ,
;

-- Now let's get strings...
exception: InvalidEscapeSequence
variable: string-terminator
variable: str-len
: handle-str-esc  ( c -- c )
	'e' -> drop '\e' ;;
	'n' -> drop '\n' ;;
	't' -> drop '\t' ;;
	'0' -> drop   0  ;;
	'"' ->           ;;
	'\' ->           ;;
	_   -> drop drop drop   InvalidEscapeSequence raise ;;
;
: str-compile-char ( c -- ) ,b  str-len inc-var ;
: end-of-string?  ( c -- bool )
	string-terminator @
	    -> drop   0 ,b   align-dp                   true  ;;
	'\' -> drop key handle-str-esc str-compile-char false ;;
	_   -> str-compile-char                         false ;;
;
: compile-string ( char -- str )
	0 str-len !
	string-terminator !
	here stash   0 ,  ' end-of-string? scan-in
	str-len @   swap !
	pop
;

-- Global named strings...
: string:  ( str -- ) ( -- str )  #immediate
	create   here copys   does
;
-- local anonymous strings
: inline-string ( char -- )
	compile-unconditional-jump
	swap compile-string
	swap jump-target
	compile-literal
;
: s"   #immediate   '"' inline-string   ;

: allot  ( n -- )
	here + dp!
	align-dp
;


-- Sleep

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
;


-- buffered output

1000 cells buffer constant: OutputBufferStart
variable: output-buffer
OutputBufferStart output-buffer !
: %s  ( s -- )
	-- copy a string into the output buffer
	dup @ push -- length
	1 cell after   peek   output-buffer @   copy-bytes
	pop   output-buffer @   +   output-buffer !
;

: %c  ( c -- )
	-- copy a char into the output buffer
	output-buffer @ !b
	output-buffer inc-var
;

: _c 
	0 -> drop ;;
	_ -> %c tail: _c ;;
;
: %d  ( n -- )
	-- copy an int into the output buffer
	dup 0 < if
		neg
		'-' %c
	endif
	10 decompose
	_c
;

: %f  ( c -- )
	-- copy a decimal into the output buffer
	dup 0 < if
		neg
		'-' %c
	endif
	decimal-places @ times
		10 /mod swap
	repeat
	%d
	'.' %c
	decimal-places @ times
		'0' + %c
	repeat
;

: clear-output
	OutputBufferStart output-buffer !
;
: flush-output
	0   output-buffer @   ! -- guarantee null-termination
	OutputBufferStart putz
	clear-output
;


-- Date, time and decimal output functions

: leading-zero
	9 <= if   '0' putc   endif
;

: explode-time ( t -- h m s )
	60 /mod push
	60 /mod 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 =  if  1+  endif
	swap    4 *   +
	swap  100 *   +
	swap  400 *   +
	BaseDate +
;
: _make-month-and-day  ( ds -- ms ds )
	stash  31 +   5 *  5Months /   2 +
	pop   over 1+   5Months *   5 /   -   123 +
	push
	dup 13 >= if
		12 -
	endif
	pop
;

: explode-date  ( date -- y m d )
	LilianCorrection 1+ -
	4Centuries /mod 
	4Centuries 1- ->  -- Date is Feb 29th of a 400th year
		drop   1+   400 *   BaseDate +
		2 29
	;;
	1Century /mod
	4Years   /mod   -- 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 /mod    -- ds: 4cs 1c 4ys 1y r
	stash
	5Months /mod  -- 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 /mod swap
	repeat
	putn
	'.' putc
	decimal-places @ times
		'0' + putc
	repeat
;

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

variable: tz

: hour Hour * ;
' hour alias: hours

: GMT ;
: BST  1 hour + ;
: EET  2 hours + ;
: EEST 3 hours + ;

' GMT tz !

: to-unixtime  ( date time -- sec )
	push  UnixEpoch -  SecondsInADay *  pop +
;
: unix-to-lalian ( unix -- date time )
	SecondsInADay /mod push   UnixEpoch +   pop
;
: now ( -- date time )
	-- WARNING: time is UTC.
	0 SysTime syscall1
	tz @ call
	unix-to-lalian
;
: today ( -- date ) now drop ;
: time  ( -- time ) now nip  ;

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

: decimal-places  #hidden
	dup 8 > if
		s" Warning: integers cannot be represented at this precision.\n" warns
	endif
	decimal-places ! 
; #visible

: *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 ;


-- Fixed-point "constants"...
: pi ( -- d )
	s" 3.1415926535898" number drop
;


: %0d
	dup 
	9 <= if   '0' %c   endif
	%d
;
: %date  ( date -- )
	-- copy a date into the output buffer
	explode-date push push
	%d '-' %c
	pop %0d '-' %c
	pop %0d
;

: %time  ( time -- )
	-- copy a time into the output buffer
	explode-time push push
	%0d ':' %c
	pop %0d ':' %c
	pop %0d
;


-- Concatenative style combinators

: dip  ( S x q -- T x )    swap push call pop ;   #inline
: bi   ( x y q -- x' y' )  stash dip pop call ;  -- apply q to x and y
-- : ifte  ( S bool then else -- T ) ? call ;

: i  1 $$ @ ;
: _for
	i
	0 -> drop ;;
	_ -> drop   1 $$ dec-var   0 $$ @ call   tail: _for ;;
;
: for  ( S n lambda -- T )
	-- apply lambda to S n times
	2 locals  _for -- 0 -> lambda  1 -> n 
;
: _while
	0 $$ @ call
	false -> drop ;;
	_     -> drop tail: _while ;;
;
: while ( S lambda -- T )
	1 locals  _while
;
: dip  ( S x lambda -- T x )
	swap 
	1 locals   --  0 -> lambda  1 -> x
	call 
	0 $$ @
;

-- Local variables

: spc  'spc' putc ;

: deflocal
	use-dict defdoes  ( n str -- )
		, ` #immediate
	does
		@ compile-literal  ' $$ ,
;

: s->z  1 cell after ;
45 45 8 shift-up +  constant: '--'

: end-local-scope  ( dict -- )
	dictionary !
	tail: ` ;
;
: local-dict
	here 4096 cells after
;

: v(  #immediate  ( -- dict )
	-- preserve old dictionary
	dictionary @
	-- switch to a temporary dictionary for locals
	here   local-dict dp!
	-- override the defition of ;
	' ` ; .cfa->.label keeps   defword ' end-local-scope , ' endcol , ` #immediate
	-- a count of our temp vars...
	0
	-- pile them on the stack. We need to reverse the
	-- order...
	[  dup s->z @
		'--' ->  drop drop   [ s->z @ ')' <> ] while-word   false ;;
		')'  ->  drop drop false ;;
		_    ->  drop keeps swap 1+ true ;;
	] while-word
	-- the count is on top of the stack...
	1 locals
	-- Because the loop counter counts down we have to do some
	-- mathematicsl gymnastics or variables are assigned in reverse order
	0 $$ @ times    0 $$ @ peek - 1- swap deflocal    repeat
	-- restore the dictionary pointer
	dp!
	-- compile the local stack-frame code
	0 $$ @  compile-literal  ' locals ,
;


-- Structures

: struct: #immediate
	create
		here 0 , 0
	does
		@   -- returns size of structure when called
;
: bytes:  #immediate
	create  ( offs size -- )
		over , +
	does
		@ +
;
: cells:  #immediate
	create  ( offs n -- )
		over ,  cells +
	does
		@ +
;
: cell:   #immediate
	` cells:
;
: end-struct  ` ; swap ! ;  #immediate  -- save the struct size

-- conditional inlining
variable: use-inliner
: ?inline  #immediate
	use-inliner @ if
		` #inline
	endif
;


-- Allow us to run cantilever scripts on unix...

: #!/usr/bin/env   [ '\n' = ] scan-in   ;   #immediate

-- vim:ft=cantilever