;;; prim.scm
;;; Copyright Henry S. Thompson 1996, 1997
;;; Version 1.0

;;; Produced at HCRC, Edinburgh with support for the UK Economic and Social
;;;  Research Council and SunSoft

;;; DSSSL expression language primitives
;;; Last edited: Fri Jan  3 16:11:45 1997

(define-macro (d!case key . terms)
  (let* ((else-found #f)
	 (clauses (map (lambda (term)
			 (if (pair? (car term))
			     `((member key (quote ,(car term)))
			       ,@(cdr term))
			   (begin (set! else-found #t)
				  term)))
		       terms)))
    `(let ((key ,key))
       (cond ,@(if else-found
		   clauses
		 (append clauses '((else (dr-error "case key unmatched")))))))))

(define-macro (d!cond . clauses)
  (let ((else-found (let loop ((ptr clauses))
			  (if (pair? ptr)
			      (if (and (pair? (car ptr))
				       (null? (cdr ptr))
				       (eq? (caar ptr) 'else))
				  #t
				(loop (cdr ptr)))
			    #f))))
    `(cond ,@(if else-found
		 clauses
	       (append clauses '((else (dr-error
					"cond unsatisfied"))))))))

(define d!external-procedure
  (lambda (pid)
    (let ((pname #t)
	  (slen 0))
      (if (and (string? pid)
	       (set! slen (string-length pid))
	       (or
		(and
		 (string=? "UNREGISTERED::dsc//R4RS::" (substring pid 0 25))
		 (set! pname (substring pid 25 slen)))
		(and
		 (string=? "UNREGISTERED::dsc//Elk::" (substring pid 0 24))
		 (set! pname (substring pid 24 slen)))))
	  (eval (string->symbol pname))
	(begin
	 (display "full external-procedure not implemented yet: ")
	 (print pid)
	 (lambda x (dr-error "unsupported external-procedure called" pid)))))))

(define *d!chps*
  ;; character property defaults
  '((numeric-equiv . #f)))

(define-macro (d!declare-char-property prop def)
  `(set! *d!chps* (cons (cons ',prop ,def) *d!chps*)))

(define-macro (d!define-language var . ldef)
  `(define ,var (cons 'd!language ',ldef)))

(define d!char-property
  (lambda args
    ;; temporary -- always returns default except for numeric-equiv
    (let ((char (car args))
	  (prop (cadr args)))
      (if (char? char)
	  (if (eq? prop 'numeric-equiv)
	      (char->integer char)
	    (if (pair? (cddr args))
		(caddr args)
	      (let ((ent (assq prop *d!chps*)))
		(if ent (cdr ent) #f))))
	(dr-error "arg not character in d!char-property" char)))))

(define *d!current-language*
  ;; sic
  #f)

(define current-language
  (lambda () *d!current-language*))

(define-macro (d!declare-default-language expr)
  `(set! *d!current-language* ,expr))

(define-macro (d!add-char-properties . body)
  ;; not implemented yet
  #t)

(define-macro (d!with-language lang proc)
  `(let ((d!save-cl *d!current-language*)
	 (d!res #f))
     (set! *d!current-language* ,lang)
     (set! d!res (,proc))
     (set! *d!current-language* d!save-cl)
     d!res))

(define-macro (d!lambda-2 fargs body)
  (let* ((bindings (d!bind-args fargs))
	 (pre-test (if (eq? (caar bindings) 'or)
		       (prog1 (list (car bindings))
			 (set! bindings (cdr bindings)))
		     '())))
    `(lambda d!args
       ,@pre-test
       (let* ,bindings
	 ,@(if (eq? (caar bindings) 'd!used)
	       (list
		'(or (= (length d!args) d!used)
		     (dr-error "too many actual arguments: " bindings)))
	     '())
	 ,body))))

(define prog1
  (lambda (x y) x))

(define d!bind-args
  (lambda (fargs)
    (let ((have-rest (member '(d!d rest) fargs)))
    (let loop ((res (if have-rest '() (list '(d!used 0))))
	       (n 0)
	       (state 'req)
	       (ptr fargs))
;;;	 (display (list res n state ptr))(newline)
	 (if (pair? ptr)
	     (let ((spec (car ptr)))
	       (if (and (pair? spec) (eq? (car spec) 'd!d))
		   ;; named constant, change state
		   (begin
		    (if (and
			 (eq? state 'req)
			 (> n 0))
			(set! res (append!
				   res
				   `((or
				      (>= (length d!args) ,n)
				      (dr-error "too few actual arguments"))))))
		    (loop res n (cadr spec) (cdr ptr)))
		 (case state
		   (req (loop (cons `(,spec (prog1 (car d!args)
					      (set! d!args (cdr d!args))))
				    res)
			      (+ n 1)
			      state
			      (cdr ptr)))
		   (optional (let ((specv (if (pair? spec) (car spec) spec))
				   (def (if (pair? spec)(cadr spec) #f)))
			       (loop
				(cons
				 `(,specv (if (pair? d!args)
					      (prog1 (car d!args)
						(set! d!args (cdr d!args)))
					    ,def))
				 res)
				n
				state
				(cdr ptr))))
		   (rest (loop (cons `(,spec d!args) res) n state (cdr ptr)))
		   (key
		    (let ((specv (if (pair? spec) (car spec) spec))
			  (def (if (pair? spec)(cadr spec) #f)))
		      (loop
		       (cons
			`(,specv (let ((hit (member '(d!k ,specv) d!args)))
				   (if hit
				       ,(if have-rest
					    '(cadr hit)
					  '(begin (set! d!used (+ d!used 2))
						  (cadr hit)))
				     ,def)))
			res)
		       n state (cdr ptr)))))))
	   (reverse! res))))))

;;; note that we define member and assoc because the use d!equal?, which
;;; is NOT the same as equal?

(define d!member
  (lambda (obj list)
    (let loop ((ptr list))
	 (if (pair? ptr)
	     (if (d!equal? obj (car ptr))
		 ptr
	       (loop (cdr ptr)))
	   #f))))

(define d!assoc
  (lambda (obj alist)
    (let loop ((ptr alist))
	 (if (pair? ptr)
	     (if (pair? (car ptr))
		 (if (d!equal? obj (caar ptr))
		     (car ptr)
		   (loop (cdr ptr)))
	       (dr-error "alist elt not a pair" (car ptr)))
	   (if (null? ptr)
	       #f
	     (dr-error "alist not a list" alist))))))

(define dr-error
  (lambda msgs
    (error 'dsc-runtime
	   (let loop ((ptr (cdr msgs))
		      (msg (car msgs)))
		(if (pair? ptr)
		    (loop (cdr ptr)
			  (string-append msg " " (format #f "~s" (car ptr))))
		  msg)))))

(define d!equal?
  (lambda (a b)
    (if (d!quantity? a)
	(and (d!quantity? b)
	     (or (and (d!exact? a)(d!exact? b))
		 (and (d!inexact? a)(d!inexact? b)))
	     (equal? a b))
      (equal? a b))))


(define d!keyword?
  ;; temporary
  (lambda (x)
    (and (pair? x)
	 (list? x)
	 (eq? (car x) 'd!k)
	 (pair? (cdr x)))))

(define-macro  (d!k x)
  ;; temporary
  `'(d!k ,x))

(define d!format-number
  ;; extremely bogus
  (lambda (nn str)
    (if (integer? nn)
	(let ((n (abs nn))
	      (c0 (string-ref str 0)))
	  (let ((res 
	(case c0
	  (#\1 (format #f "~s" n))
	  (#\0 (let ((res (format #f "~s" n))
		     (flen (string-length str)))
		 (let ((rlen (string-length res)))
		   (if (>= rlen flen)
		       res
		     (string-append (make-string (- flen rlen) #\0)
				    res)))))
	  ((#\a #\A) (if (zero? n) "0"
		       (let ((i0 (- (char->ascii c0) 1)))
			 (let loop ((r n)
				    (res ""))
			      (if (< r 27)
				  (string-append (make-string
						  1
						  (integer->char (+ i0 r)))
						 res)
				(loop (quotient r 26)
				      (string-append
				       (make-string
					1 (integer->char (+ i0 (remainder
								r 26))))
				       res)))))))
	  ((#\i #\I) (if (zero? n) "0"
		       ;; slow but simple
		       (let ((tbl (if (eq? c0 #\i)
				      '("i" "iv" "v" "ix" "x" "xl" "l" "xc"
					"c" "cd" "d" "cm" "m")
				    '("I" "IV" "V" "IX" "X" "XL" "L" "XC"
					"C" "CD" "D" "CM" "M"))))
			 (let loop ((cv '(1000 900 500 400 100 90 50 40
					  10 9 5 4 1))
				    (i 12)
				    (r n)
				    (res ""))
			      (if (and (pair? cv) (> r 0))
				  (if (< r (car cv))
				      (loop (cdr cv) (- i 1) r res)
				    (loop cv i (- r (car cv))
					  (string-append
					   res
					   (list-ref tbl i))))
				res)))))
	  (else (dr-error "illegal format arg to format-number" str)))))
	(if (< nn 0)
	    (string-append "-" res)
	  res)))
      (dr-error "non-integer number argument to format-number" n))))

(define d!error
  (lambda (msg)
    (dr-error "Spec. invoked error" msg)))

(define d!c
  (lambda (cname)
    ;; temporary
    (if (= 1 (string-length cname))
	(string-ref cname 0)
      #\254)))
