[CONTACT]

[ABOUT]

[POLICY]

let var car stack cdr values

Found at: sdf.org:70/users/lro/phlog/technical/2019-01-09.scm

(define (pop stack)
  (let ((var (car stack))
		(ret-stack (cdr stack)))
	(values var ret-stack)))

(define (push var stack)
  (append (list var) stack))

(define (dup stack)
  (let ((head (car stack)))
	(append (list head) stack)))

(define (fact x)
  (define (fact-iter n current)
	(if (= n 1)
	  current
	  (fact-iter (- n 1) (* n current))))
  (fact-iter x 1))

(define (rpn-func func args stack)
  (if (= args 1)
	(let-values (((var stack) (pop stack)))
	  (push (func var) stack))
	(let*-values (((var1 stack) (pop stack))
				  ((var2 stack) (pop stack)))
	  (push (func var2 var1) stack))))
;;	  (push (func var1 var2) stack))))
	  
(define (insert-into-alist key val alist)
  (let ((mem? (assq key alist)))
	(if mem?
	  (update-alist key val alist)
	  (append alist (list (cons key val))))))

(define (index-in-alist key alist)
  (let loop ((list (list-copy alist))
			 (index 0))
	(if (= (length list) 0)
	  #f
	  (let ((list-head-key (car (car list))))
		(if (eq? list-head-key key)
		  index
		  (loop (cdr list) (+ index 1)))))))

(define (update-alist key new-val alist)
  (let ((index (index-in-alist key alist)))
	(list-set! alist index (cons key new-val))
	alist))

(define (run-func sym dict stack)
  (let ((func (assq sym dict)))
	(if func
	  ((cdr func) stack dict)
	  (begin
		(display "ERROR: symbol not in dictionary: ")
		(display sym)
		(newline)
		stack))))

(define (swap stack)
  (let ((a (car stack))
		 (b (cadr stack)))
	(append (list b) (list a) (cddr stack))))

(define init-dict 
  (list (cons '$ (lambda (stack dict)
				   (let-values (((var stack) (pop stack)))
					 (display var)
					 (newline)
					 stack)))
		(cons '+ (lambda (stack dict) (rpn-func + 2 stack)))
		(cons '- (lambda (stack dict) (rpn-func - 2 stack)))
		(cons '* (lambda (stack dict) (rpn-func * 2 stack)))
		(cons '/ (lambda (stack dict) (rpn-func / 2 stack)))
		(cons '% (lambda (stack dict) (rpn-func modulo 2 stack)))
		(cons '! (lambda (stack dict) (rpn-func fact 1 stack)))
		(cons 'dup (lambda (stack dict) (dup stack)))
		(cons 'swap (lambda (stack dict) (swap stack)))
		(cons 'sin (lambda (stack dict) (rpn-func sin 1 stack)))
		(cons 'cos (lambda (stack dict) (rpn-func cos 1 stack)))
		(cons 'tan (lambda (stack dict) (rpn-func tan 1 stack)))
		(cons 'trunc (lambda (stack dict) (rpn-func truncate 1 stack)))
		(cons 'ceil (lambda (stack dict) (rpn-func ceiling 1 stack)))
		(cons 'floor (lambda (stack dict) (rpn-func floor 1 stack)))
		;; to be added to init-dict
		(cons 'pow (lambda (stack dict) (rpn-func expt 2 stack)))
		(cons 'log_e (lambda (stack dict) (rpn-func log 1 stack)))
		;; for log second argument is base
		(cons 'log (lambda (stack dict) (rpn-func log 2 stack)))
		(cons 'sqrt (lambda (stack dict) (rpn-func sqrt 1 stack)))
		(cons 'D (lambda (stack dict) (begin (display stack) (newline) stack)))
		(cons 'rot (lambda (stack dict) (let*-values (((var1 stack) (pop stack))
											  ((var2 stack) (pop stack))
											  ((var3 stack) (pop stack)))
								  (let* ((stack (push var1 stack))
										 (stack (push var2 stack)))
									(push var3 stack)))))
		))

(define (user-func-from-list func)
  (lambda (stack dict)
	(let loop ((func func)
			   (stack stack))
	  (if (= (length func) 1)
		(if (number? (car func))
		  (push (car func) stack)
		  (run-func (car func) dict stack))
		(if (number? (car func))
		  (loop (cdr func) (push (car func) stack))
		  (loop (cdr func) (run-func (car func) dict stack)))))))

(define (new-func list dictionary)
  (insert-into-alist (car list) (user-func-from-list (cdr list)) dictionary))

(define funcs-file "your-funcs")

(define (list-as-string list)
  (parameterize ((current-output-port (open-output-string)))
	(write list)
	(get-output-string (current-output-port))))

(define (add-user-func list user-funcs file)
  (let ((func-to-add (list-as-string list)))
	(parameterize ((current-output-port (open-output-file file)))
	  (let ((new-user-funcs (string-append user-funcs func-to-add "\n")))
		(display new-user-funcs)
		(close-output-port (current-output-port))
		new-user-funcs))))

(define (load-funcs-from-file-dict file dict)
  (with-input-from-file file
	(lambda ()
	  (let loop ((input (read))
				 (dict dict))
		(if (eof-object? input)
		  dict
		  (loop (read) (new-func input dict)))))))

(define (load-funcs-from-file-str file)
  (with-input-from-file file
	(lambda ()
	  (let loop ((next-str (read-string 10))
				 (str ""))
		(if (eof-object? next-str)
		  str
		  (loop (read-string 10) (string-append str next-str)))))))

(let loop ((input (read)) 
		   (stack '())
		   (dict (load-funcs-from-file-dict funcs-file init-dict))
		   (user-funcs (load-funcs-from-file-str funcs-file)))
  (cond
   ((number? input) (loop (read) (push input stack) dict user-funcs))
   ((list? input) (let ((user-funcs (add-user-func input user-funcs funcs-file)))
					(loop (read) stack (new-func input dict) user-funcs)))
   ((symbol? input) (loop (read) (run-func input dict stack) dict user-funcs))
   (else (begin
		   (display "ERROR not valid input: ")
		   (display input)
		   (newline)
		   (loop (read) stack dict)))))


AD: