;;; Qlang version 0.1
;;; R5RS Scheme plus getprop, putprop, error

;; queue primitives from SICP pp. 209-212
;; in classical Lisp, called "tconc" representation

(define front-ptr car)
(define rear-ptr cdr)
(define set-front-ptr! set-car!)
(define set-rear-ptr! set-cdr!)

(define (empty-queue? queue) (null? (front-ptr queue)))
(define (make-queue) (cons '() '()))
(define (insert-queue! queue item)
	(let ((new-pair (cons item '())))
		(cond ((empty-queue? queue)
			(set-front-ptr! queue new-pair)
			(set-rear-ptr! queue new-pair))
		      (else
			(set-cdr! (rear-ptr queue) new-pair)
			(set-rear-ptr! queue new-pair)))))

(define (delete-queue! queue)
	(if (empty-queue? queue)
		(error "delete-queue!" "empty queue")
		(let ((front (car (front-ptr queue))))
			(set-front-ptr! queue (cdr (front-ptr queue)))
			front)))

(define queue->list front-ptr)

;; define a Qlang primitive
(define (q-prim sym fn arity)
	(putprop sym 'q-subr fn)
	(putprop sym 'q-arity arity))

;; return the arity of an operator, or -1 if not an operator
(define (q-arity sym)
	(if (symbol? sym)
		(getprop sym 'q-arity -1)
		-1))

;; return the Qlang definition of a symbol
(define (q-def sym) (getprop sym 'q-subr #f))

;; execute Qlang expression encoded as list
(define (q-exec list)
	(let ((queue (make-queue)))
		(for-each (lambda (elem) (insert-queue! queue elem)) list)
		(q-exec-queue queue)))

;; execute Qlang expression encoded as queue
(define (q-exec-queue queue)
	(let* ((item (delete-queue! queue))
	       (arity (q-arity item)))
		(cond ((empty-queue? queue)
			item)
	      	      ((negative? arity)
			(insert-queue! queue item)
			(q-exec-queue queue))
		      ((q-args-available? (queue->list queue) item arity)
			(insert-queue! queue
				(apply (q-def item)
					(q-get-args! queue arity)))
			(q-exec-queue queue))
		      (else
			(insert-queue! queue item)
			(q-exec-queue queue)))))

;; Are the right number of arguments available?
(define (q-args-available? args sym count)
	(cond ((zero? count)
		#t)
	      ((null? args)
		(error (symbol->string sym) "missing arguments"))
	      ((>= (q-arity (car args)) 0)
		#f)
	      (else
		(q-args-available? (cdr args) sym (- count 1)))))

(define (q-get-args! queue count)
	(if (zero? count)
		'()
		(let ((arg (delete-queue! queue)))
			(cons arg (q-get-args! queue (- count 1))))))

;; some primitives
(q-prim '+ + 2)
(q-prim '* * 2)
(q-prim 'pi (lambda () 3.141592653) 0)