; functions.lisp   by Michael Thorpe   2017-05-29

(define (pair? o)
	(eq? (object-type o) 'cons))
(define (quoted? o)
	(eq? (object-type o) 'quote))
(define (word? o)
	(eq? (object-type o) 'word))

(define (not o) (ifelse o #f #t))

(define (get hash item)
	(if hash
		(ifelse (eq? (car (car hash)) item)
			(cdr (car hash))
			(get (cdr hash) item))))

(define (member item list)
	(ifelse list
		(ifelse (pair? list)
			(ifelse (eq? item (car list))
				list
				(member item (cdr list)))
			(ifelse (eq? item list)
				list
				#f))
		#f))

(define (reverse/append straight newtail)
	(#append/reversed newtail straight))

(define (write-newline file)
	(write-char file 10))
(define (write-object file obj)
	(ifelse (eq? obj #t)
		(write-string file "#t")
		(write-string file (->string obj))))
(define (#dprint o)
	(while o
		(write-object #standard-out (car o))
		(set o (cdr o))
		(if o
			(write-char #standard-out 32)))
	(write-newline #standard-out)
	#f)
(macro-define (dprint o)
	`(#dprint ,(cons 'list (cdr o))))

;
; This object is placed in the CAR of a cons to indicate that quasiquote
; should replace the cons with the CDR of the cons (but not quoted).
; For example, if read-object is about to read:
;   ,bar
; it will call macro-comma, which calls read-object, gets bar, and returns:
;   (unquote-identifier . bar)
; where unquote-identifier is the value defined below, and bar is the
; literal atom read.
;
; If read-object is called where the stream starts with:
;   `(foo ,bar baz)
; then the backtick will be read, macro-backtick will call read-object and
; pass the following to quasiquote:
;   (foo (unquote-identifier . bar) baz)
; Then quasiquote will do its thing and return:
;   (list 'foo bar 'baz)
;
; Note that quasiquote needs to be able to handle things like:
;   `(foo bar . ,(car baz))
; turning them into:
;   (cons 'foo (cons 'bar (car baz)))
;
(define unquote-identifier '(unquote . identifier))

(define #character-macros ())
(define (define-character-macro char macro)
	(set #character-macros (cons (cons char macro) #character-macros))
	char)

(define (get-using-= hash item)
	(while hash
		(if (= (car (car hash)) item)
			(exit-loop (cdr (car hash))))
		(set hash (cdr hash))))

(define (expand-string oldstring)
	(let ((i 0)
	      (newstring (new-string (+ 512 (string-length oldstring)))))
		(while (< i (string-length oldstring))
			(put-char newstring i (get-char oldstring i)))
		newstring))

(define (is-space c) ; space, FF, NL, CR, and horizontal and vertical tabs
	(or (= c 32) (and (< 8 c) (< c 14))))
(define (is-ascii c) ; space through tilde
	(and (< 31 c) (< c 127)))

; Returns the value of the hexchar, or #f if it's not a hexchar
(define (hexchar? c)
	(ifelse (and (<= 48 c) (<= c 57))
		(- c 48)
		(ifelse (and (<= 65 c) (<= c 70))
			(- c 55)
			(ifelse (and (<= 97 c) (<= c 102))
				(- c 87)
				#f))))

; Skips whitespace and returns the peek-char of the character after that.
; Skips over comments as if they were whitespace.
(define (skip-whitespace stream)
	(loop 
		(let ((c (peek-char stream)))
			(if (= 59 c) ; Semicolon
				(while (and (<> c 10) (<> c 13))
					(set c (read-char stream)))
				(next-loop))
			(unless (is-space c)
				(exit-loop c))
			(read-char stream))))

(define (macro-singlequote stream)
	(catch 'end-of-file
		(quote (read-object stream))
		(throw 'reader-error stream)))
(define-character-macro 39 macro-singlequote)

; This will be returned by read-object when a close parenthesis is read.
(define close-parenthesis '(close . parenthesis))

(define (submacro-dot stream)
	(catch 'end-of-file
		(let ((o (read-object stream))
		      (c (skip-whitespace stream)))
			(unless (= 41 c)
				(throw 'reader-error stream))
			(read-char stream)
			o)
		(throw 'reader-error stream)))

(define (macro-openparen stream)
	(let ((reverse-list ())
	      (new-list ()))
		(catch 'end-of-file
			(loop
				(let ((o (read-object stream)))
					(ifelse (eq? o close-parenthesis)
						(exit-loop)
						(ifelse (eq? o '.)
							(ifelse reverse-list
								(progn
									(set new-list (submacro-dot stream))
									(exit-loop))
								(throw 'reader-error stream))
							(set reverse-list (cons o reverse-list))))))
			(throw 'reader-error stream))
		(reverse/append reverse-list new-list)))
(define-character-macro 40 macro-openparen)

(define (macro-closeparen stream)
	close-parenthesis)
(define-character-macro 41 macro-closeparen)

(define (macro-comma stream)
	(catch 'end-of-file
		(cons unquote-identifier (read-object stream))
		(throw 'reader-error stream)))
(define-character-macro 44 macro-comma)

(define (macro-semicolon stream)
	(let ((c 0))
		(while (and (<> c 10) (<> c 13))
			(set c (read-char stream))))
	(read-object stream))
(define-character-macro 59 macro-semicolon)

(define (quasiquote obj)
	(ifelse obj
		(ifelse (pair? obj)
			(ifelse (eq? unquote-identifier (car obj))
				(cdr obj)
				(ifelse (member unquote-identifier obj)
					(list 'cons (quasiquote (car obj)) (quasiquote (cdr obj)))
					(cons 'list (map-safe a (quasiquote a) obj))))
			(quote obj))
		obj))

(define (macro-backtick stream)
	(quasiquote
		(catch 'end-of-file
			(read-object stream)
			(throw 'reader-error stream))))
(define-character-macro 96 macro-backtick)

(define (subsubmacro-doublequote-backslash-x stream)
	(let ((c (hexchar? (catch 'end-of-file (peek-char stream) (throw 'reader-error stream)))))
		(unless c (throw 'reader-error stream))
		(read-char stream)
		(catch 'end-of-file
			(let ((c2 (hexchar? (peek-char stream))))
				(if c2
					(read-char stream)
					(set c (+ (* c 16) c2))))
			#f)
		c))

(define (submacro-doublequote-backslash stream)
	(let ((c (catch 'end-of-file (read-char stream) (throw 'reader-error stream))))
		(ifelse (= 120 c) ; x
			(subsubmacro-doublequote-backslash-x stream)
			c)))

(define (macro-doublequote stream)
	(let ((c #f)
	      (i 0)
	      (string (new-string 512)))
		(loop
			(if (= i (string-length string))
				(set string (expand-string string)))
			(set c
				(catch 'end-of-file
					(read-char stream)
					(throw 'reader-error stream)))
			(if (= c 34) ; 34 = ASCII double quote
				(exit-loop))
			(if (= c 92) ; 92 = ASCII backslash
				(set c (submacro-doublequote-backslash stream)))
			(put-char string i c)
			(set i (+ i 1)))
		(substring string 0 i)))
(define-character-macro 34 macro-doublequote)

(define (read-token stream c)
	(let ((buffer (new-string 512))
	      (i 0))
		(loop
			(if (= i (string-length buffer))
				(set buffer (expand-string buffer)))
			(put-char buffer i c)
			(set i (+ i 1))
			(catch 'end-of-file
				(set c (peek-char stream))
				(exit-loop))
			(if (is-space c)
				(exit-loop))
			(unless (is-ascii c)
				(exit-loop))
			(if (get-using-= #character-macros c)
				(exit-loop))
			(set c (read-char stream)))
		(set buffer (substring buffer 0 i))
		(ifelse (string-eqv? buffer "#f")
			()
			(catch 'type-error
				(string->integer buffer)
				(catch 'type-error
					(string->float buffer)
					(string->symbol buffer))))))

(define (read-object stream)
	(let ((c (skip-whitespace stream))
	      (macro #f))
		(unless (is-ascii c)
			(throw 'reader-error stream))
		(read-char stream)
		(set macro (get-using-= #character-macros c))
		(ifelse macro
			(macro stream)
			(read-token stream c))))

(define (cars arg) ; ((1 2) (3 4)) => (1 3)
	(map o (car o) arg))
(define (cdrs arg) ; ((1 2) (3 4)) => ((2) (4))
	(map o (cdr o) arg))
(define (cadrs arg) ; ((1 2) (3 4)) => (2 4)
	(map o (cadr o) arg))

(define (load-file filename)
	(let ((file (open-file filename "r"))
	      (objs #f))
		(loop
			(set objs
				(cons
					(catch 'end-of-file
						(read-object file)
						(exit-loop #f))
					objs)))
		(if objs (set objs (cons 'progn (reverse objs))))
		(set objs (macro-expand objs))
		(set objs (byte-compile #f objs))
		(objs)
		#f))

(define (string-eqv? a b)
	(let ((c (string-length a)))
		(ifelse (= c (string-length b))
			(loop
				(if (= c 0)
					(exit-loop #t))
				(set c (- c 1))
				(if (<> (get-char a c) (get-char b c))
					(exit-loop #f)))
			#f)))
(define (eqv? a b)
	(let ((ot-a (object-type a)))
		(ifelse (eq? a b)
			#t
			(ifelse (neq? ot-a (object-type b))
				#f
				(ifelse (or (eq? ot-a 'integer) (eq? ot-a 'bigint) (eq? ot-a 'float))
					(= a b)
					(ifelse (eq? ot-a 'quote)
						(eqv? (unquote a) (unquote b))
						(ifelse (eq? ot-a 'string)
							(string-eqv? a b)
							(ifelse (eq? ot-a 'cons)
								(and
									(eqv? (car a) (car b))
									(eqv? (cdr a) (cdr b)))
								#f))))))))

(define (concatenate-strings list)
	(let ((l list)
	      (i 0))
		(while l
			(set i (+ i (string-length (car l))))
			(set l (cdr l)))
		(let ((s (new-string i)))
			(set i 0)
			(while list
				(let ((j 0))
					(while (< j (string-length (car list)))
						(put-char s i (get-char (car list) j))
						(set i (+ i 1))
						(set j (+ j 1))))
				(set list (cdr list)))
			s)))
(macro-define (string-concatenate o)
	`(concatenate-strings ,(cons 'list (cdr o))))

(define (string-gt? a b)
	(let ((i 0)
	      (a-len (string-length a))
	      (b-len (string-length b))
	      (a-char #f)
	      (b-char #f))
		(loop
			(if (and (= i a-len) (= i b-len)) (exit-loop #f))
			(if (= i a-len) (exit-loop #f))
			(if (= i b-len) (exit-loop i))
			(set a-char (get-char a i))
			(set b-char (get-char b i))
			(if (< a-char b-char) (exit-loop #f))
			(if (> a-char b-char) (exit-loop i))
			(set i (+ i 1)))))

(define (sort lst)
	(if (and lst (cdr lst))
		(let ((prev #f))
			(while (neq? prev lst)
				(set prev lst)
				(if (string-gt? (->string (car lst)) (->string (cadr lst)))
					(set lst `(,(cadr lst) ,(car lst) . ,(cddr lst))))
				(let ((new (sort (cdr lst))))
					(if (neq? new (cdr lst))
						(set lst (cons (car lst) new)))))))
	lst)

; Return the length of the #f-terminated list
(define (list-length a)
	(let ((len 0))
		(while a
			(set len (+ len 1))
			(set a (cdr a)))
		len))

; Return the n-th item in the list
(define (nth-item list n)
	(while (< 0 n)
		(set list (cdr list))
		(set n (- n 1)))
	(car list))

; Return the index of the first instance of item in the list
(define (list-index list item)
	(let ((i 0))
		(while list
			(if (eq? item (car list))
				(exit-loop i))
			(set i (+ i 1))
			(set list (cdr list)))))
; Return the index of the last instance of item in the list
(define (list-rindex list item)
	(let ((i 0)
	      (pos #f))
		(while list
			(if (eq? item (car list))
				(set pos i))
			(set i (+ i 1))
			(set list (cdr list)))
		pos))

(define (reverse-get-with-eqv? hash item)
	(while hash
		(if (eqv? (cdr (car hash)) item)
			(exit-loop (car (car hash))))
		(set hash (cdr hash))))

;
; switch (takes the place of cond)
;
; Format:
;  (switch key
;  	((value1) stuff1 stuff2)
;  	((value2 value3) stuff3 stuff4 stuff5)
;  	(else stuff6 stuff7))
; else is required to be the last case (and defaults to #f if not present)
;
(define (switch-handle-map var cases)
	(let ((result #f))
		(while cases
			(set result (cons `(eq? ,var ,(car cases)) result))
			(set cases (cdr cases)))
		(reverse result)))
(define (switch-handle var cases)
	(ifelse cases
		(ifelse (eq? 'else (caar cases))
			(cons 'progn (cdar cases))
			(ifelse (caar cases)
				`(ifelse ,(cons 'or (switch-handle-map var (caar cases)))
					,(cons 'progn (cdar cases))
					,(switch-handle var (cdr cases)))
				(switch-handle var (cdr cases))))
		#f))
(macro-define (switch o)
	(let ((var (unique-word)))
		`(progn
			(let ((,var ,(cadr o)))
				,(switch-handle var (cddr o))))))

(define (show-error error errorvalue)
	(write-newline #standard-error)
	(write-string #standard-error "EXCEPTION: ")
	(write-object #standard-error error)
	(write-newline #standard-error)
	(write-string #standard-error "EXCEPTION-VALUE: ")
	(write-object #standard-error errorvalue)
	(write-newline #standard-error))

(define (read-eval-print in out prompt)
	(let ((o #f))
		(loop
			(if prompt (write-string out prompt))
			(set o
				(catch 'end-of-file
					(catch 'reader-error
						(read-object in)
						(progn
							(show-error #exception #exceptionvalue)
							(ifelse prompt (next-loop) (exit-loop #t))))
					(progn (if prompt (write-newline out)) (exit-loop))))
			(set o
				(catch #f
					((byte-compile #f (macro-expand o)))
					(progn
						(show-error #exception #exceptionvalue)
						(ifelse prompt (next-loop) (exit-loop #t)))))
			(if (and prompt o)
				(write-object out o)
				(write-newline out)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Here's what's going to be run initially ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (#init)
; #f is a special word (hardcoded in read-object) so we don't need to define it
	(define #t (not #f))
; Try to load-file all the command-line arguments if the first arg is -l
	(if (and #argv (eqv? "-l" (car #argv)))
		(set #argv (cdr #argv))
		(while #argv
			(let ((file (car #argv)))
				(set #argv (cdr #argv))
				(load-file file))))
; Try to load-file the first command-line argument, and exit
	(ifelse #argv
		(let ((file (car #argv)))
			(set #argv (cdr #argv))
			(load-file file))
		(read-eval-print #standard-in #standard-out (ifelse (isatty #standard-in) "mikelisp> " #f))))