;;; Copyright (C) 2019 by David Ireland
;;; BSD 3-Clause License: http://opensource.org/licenses/BSD-3-Clause
;;;
;;; Shen Scheme derived soure code is:
;;; Copyright (c) 2012-2015 Bruno Deferrari.  All rights reserved.


(import
  scheme
  srfi-1
  srfi-69
  chicken.io
  chicken.base
  chicken.port
  chicken.load
  chicken.time
  chicken.file
  chicken.irregex
  chicken.format
  chicken.condition
  chicken.process-context)

;;;   ____ _       _           _
;;;  / ___| | ___ | |__   __ _| |___
;;; | |  _| |/ _ \| '_ \ / _` | / __|
;;; | |_| | | (_) | |_) | (_| | \__ \
;;;  \____|_|\___/|_.__/ \__,_|_|___/

(define *code->char*            (make-hash-table))
(define *char->code*            (make-hash-table))
(define *code->unicode*         (make-hash-table))
(define *shen-globals*          (make-hash-table))
(define *shen-function-arities* (make-hash-table))

;;;  _____                 _   _
;;; |  ___|   _ _ __   ___| |_(_) ___  _ __
;;; | |_ | | | | '_ \ / __| __| |/ _ \| '_ \ 
;;; |  _|| |_| | | | | (__| |_| | (_) | | | |
;;; |_|   \__,_|_| |_|\___|\__|_|\___/|_| |_|
;;;
;;;     _         _ _   _
;;;    / \   _ __(_) |_(_) ___  ___ 
;;;   / _ \ | '__| | __| |/ _ \/ __|
;;;  / ___ \| |  | | |_| |  __/\__ \
;;; /_/   \_\_|  |_|\__|_|\___||___/

(define (register-function-arity name arity)
  (hash-table-set! *shen-function-arities* name arity))

(define (function-arity name)
  (if (and
       (symbol? name)
       (hash-table-exists? *shen-function-arities* name))
      (hash-table-ref *shen-function-arities* name)
      -1))

(define (initialize-arity-table entries)
  (if (null? entries)
      'done
      (let ((name  (caar  entries))
            (arity (cadar entries)))
        (register-function-arity name arity)
        (initialize-arity-table (cdr entries)))))

(define (simple-error msg)
  (error 'shen msg))

(define (guard handler thunk)
  (define tag 'return-exception-handler)
  (let ((test
	 (call/cc
	  (lambda (k)
	    (with-exception-handler
		(lambda (exn)
		  (k `(,tag . ,(lambda () (handler exn)))))
	      thunk)))))
    (if (and (pair?      test)
	     (procedure? (cdr test))
	     (eq?        (car test) tag))
	    ((cdr test))
	    test)))
  
(define (object-type value)
  (cond
   ((string?    value) "<string>")
   ((number?    value) "<number>")
   ((pair?      value) "<pair>")
   ((null?      value) "<null>")
   ((vector?    value) "<vector>")
   ((port?      value) "<port>")
   ((symbol?    value) "<symbol>")
   ((procedure? value) "<closure>")
   (else               "<???>")))

;;; Use s-replace so it doesn't clash with string-replace
(define (s-replace s old new)
  (irregex-replace/all (irregex-quote old) s new))

(define (string-find s regexp)
  (irregex-match-data? (irregex-search regexp s)))

(define (vector=? a b)
  (let ((len (vector-length a)))
    (and (= (vector-length a)
	    (vector-length b))
	 (let loop ((i 0))
	   (if (< i (vector-length a))
	       (if  (kl:= (vector-ref a i)
			  (vector-ref b i))
		    (loop (+ i 1))
		    #f)
	       #t)))))

(define (full-path-for-file filename)
  (string-append
   (kl:value (quote *home-directory*)) "/" filename))

(define (assert-boolean value)
  (if (boolean? value)
      value
      (error 'assert-boolean "expected a boolean, got" value)))

(define (char-code char)
  (if (hash-table-exists? *char->code* char)
      (hash-table-ref *char->code* char)
      (simple-error "can't find code for given character")))
      ;; 63)) ;;; Return ? code if we can't find the char
      

(define (code-char code)
  (if (hash-table-exists? *code->char* code)
      (hash-table-ref *code->char* code)
      (simple-error "can't find character with given code")))
      ;; #\?)) ;;; Return ? if we can't find the char

;;;  _  __     _                    _         _
;;; | |/ /    | |    __ _ _ __ ___ | |__   __| | __ _
;;; | ' /_____| |   / _` | '_ ` _ \| '_ \ / _` |/ _` |
;;; | . \_____| |__| (_| | | | | | | |_) | (_| | (_| |
;;; |_|\_\    |_____\__,_|_| |_| |_|_.__/ \__,_|\__,_|

;;; K-Lambda 1: IF   (Scheme)
;;; K-Lambda 2: AND  (Scheme)
;;; K-Lambda 3: OR   (Scheme)
;;; K-Lambda 4: COND (Scheme)

;;; K-Lambda 5: INTERN
(define (kl:intern name)
  (cond
   ((equal? name "true") #t)
   ((equal? name "false") #f)
   ((string-find name "@") (string->symbol (s-replace name "@" "_scheme_at_")))
   ((string-find name ";") (string->symbol (s-replace name ";" "_scheme_sc_")))
   ((string-find name "$") (string->symbol (s-replace name "$" "_scheme_dl_")))
   (else (string->symbol name))))

;;; K-Lambda 6: POS   (Scheme)
;;; K-Lambda 7: TLSTR 
(define (kl:tlstr str)
  (if (string? str)
      (substring str 1 (string-length str))
      str))

;;; K-Lambda 8: CN    (Scheme)
;;; K-Lambda 9: STR
(define (kl:str value)
  (cond ((eq? value #t) "true")
        ((eq? value #f) "false")
        ((symbol? value)
	 (let ((s (symbol->string value)))
	   (cond
	    ((string-find s "_scheme_at_")
	     (s-replace s "_scheme_at_" "@"))
	    ((string-find s "_scheme_sc_")
	     (s-replace s "_scheme_sc_" ";"))
	    ((string-find s "_scheme_dl_")
	     (s-replace s "_scheme_dl_" "$"))
	    (else s))))
        ((procedure? value) ;; Required for kl:symbol to return false for functions
         (string-append "#" "procedure"))
	((number? value)
	 (number->string value))
        (else
	 (sprintf "~S" value))))

;;; K-Lambda 10: STRING?   (Scheme)
;;; K-Lambda 11: N->STRING 
(define (kl:n->string n)
  (if (hash-table-exists? *code->unicode* n)
      (hash-table-ref *code->unicode* n)
      (make-string 1 (code-char n))))

;;; K-Lambda 12: STRING->N
(define (kl:string->n str)
  (define regex
    (sre->irregex
     (string->sre
      "c#([0-9]|[1-9][0-9]|[0-1][0-2][0-7]);")))
  (if (irregex-match? regex str)
      (string->number
       (substring str 2 (- (string-length str) 1)))
      (char-code (car (string->list str)))))
  
;;; K-Lambda 13: SET
(define (kl:set key val)
  (hash-table-set! *shen-globals* key val)
  val)

;;; K-Lambda 14: VALUE
(define (kl:value key)
  (if (not (hash-table-exists? *shen-globals* key))
      (error 'kl:set "variable has no value: " key))
  (hash-table-ref *shen-globals* key))

;;; K-Lambda 15 SIMPLE-ERROR
;;; K-Lambda 16 TRAP-ERROR

;;; K-Lambda 17: ERROR-TO-STRING
(define (kl:error-to-string e)
  ((condition-property-accessor 'exn 'message) e))

;;; K-Lambda 18: CONS   (Scheme)
;;; K-Lambda 19: HD     (Scheme)
;;; K-Lambda 20: TL     (Scheme)
;;; K-Lambda 21: CONS?  (Scheme)
;;; K-Lambda 22: DEFUN  (Scheme)
;;; K-Lambda 23: LAMBDA (Scheme)
;;; K-Lambda 24: LET    (Scheme)

;;; K-Lambda 25: = 
(define (kl:= a b)
  (cond ((eq?     a b) #t) 
	((equal?  a b) #t)
        ((number? a)
	 (and (number? b)
	      (= a b)))
        ((pair? a)
         (and (pair? b)
	      (kl:= (car a) (car b))
	      (kl:= (cdr a) (cdr b))))
        ((string? a) (and (string? b) (string=? a b)))
        ((vector? a) (and (vector? b) (vector=? a b)))
        (else #f)))

;;; K-Lambda 26: EVAL-KL
(define (kl:eval-kl expr)
  (eval (kl->scheme expr)))

;;; K-Lambda 27: FREEZE (Scheme)

;;; K-Lambda 28: TYPE
;;; (define (kl:type value)
;;;  (type value))

;;; K-Lambda 29: ABSVECTOR  (Scheme)
;;; K-Lambda 30: ADDRESS->  (Scheme)
;;; K-Lambda 31: <-ADDRESS  (Scheme)
;;; K-Lambda 32: ABSVECTOR? (Scheme)

;;; K-Lambda 33: WRITE-BYTE
(define (kl:write-byte byte port)
  (write-byte byte port)
  byte)

;;; K-Lambda 34: READ-BYTE
(define (kl:read-byte port)
  (let ((in (read-byte port)))
    (if (eq? in #!eof) -1 in)))

;;; K-Lambda 35: OPEN
(define (kl:open filename direction)
  (let ((full-path (full-path-for-file filename)))
    (cond
     ((equal? 'in direction)
      (if (file-exists? full-path)
	  (open-input-file full-path)
	  (error 'kl:open "file does not exist" full-path)))
     ((equal? 'out direction)
      (open-output-file full-path))
     (else (error 'kl:open "invalid direction" direction)))))

;;; K-Lambda 36: CLOSE
(define (kl:close port)
  (if (input-port? port)
      (close-input-port  port)
      (close-output-port port))
  (list))

;;; K-Lambda 37: GET-TIME
(define (kl:get-time sym)
  (cond
   ((or (eq? sym 'unix)
	(eq? sym 'UNIX))
    (current-seconds))
   ((or (eq? sym 'run)
	(eq? sym 'RUN))
    (- (current-seconds)
       (kl:value '*program-start*)))
   (else
    (simple-error "invalid symbol"))))

;;; K-Lambda 38: +       (Scheme) 
;;; K-Lambda 39: -       (Scheme)
;;; K-Lambda 40: *       (Scheme)
;;; K-Lambda 41: /       (Scheme)
;;; K-Lambda 42: >       (Scheme)
;;; K-Lambda 43: <       (Scheme)
;;; K-Lambda 44: >=      (Scheme)
;;; K-Lambda 45: <=      (Scheme)
;;; K-Lambda 46: number? (Scheme)

;;;  ____  _
;;; / ___|| |__   ___ _ __
;;; \___ \| '_ \ / _ \ '_ \
;;;  ___) | | | |  __/ | | |
;;; |____/|_| |_|\___|_| |_|

;; TODO (kl:set (quote *os*)              "OpenBSD") 
(kl:set (quote *language*)        "Scheme")
(kl:set (quote *implementation*)  "Chicken")
(kl:set (quote *port*)            "0.1")
(kl:set (quote *porters*)         "David Ireland")
(kl:set (quote *program-start*)   (current-seconds))
(kl:set (quote *sterror*)         (current-error-port))
(kl:set (quote *stinput*)         (current-input-port))
(kl:set (quote *stoutput*)        (current-output-port))
(kl:set (quote *home-directory*)  (current-directory))
(kl:set (quote shen.*initial-home-directory*) (current-directory))

;;;     _    ____   ____ ___ ___      __  _   _       _               _      
;;;    / \  / ___| / ___|_ _|_ _|    / / | | | |_ __ (_) ___ ___   __| | ___ 
;;;   / _ \ \___ \| |    | | | |    / /  | | | | '_ \| |/ __/ _ \ / _` |/ _ \
;;;  / ___ \ ___) | |___ | | | |   / /   | |_| | | | | | (_| (_) | (_| |  __/
;;; /_/   \_\____/ \____|___|___| /_/     \___/|_| |_|_|\___\___/ \__,_|\___|

(define (add-unicode code str)
  (hash-table-set! *code->unicode* code str))

(define (add-ascii code char)
  (hash-table-set! *code->char* code char))

;;; Unicode characters. Codes are defined in the "The Book of Shen" 3rd Edition
;;; page 63 based on Micrsoft's ASCII character table. 
(add-unicode 1  "☺") (add-unicode 2  "☻")  (add-unicode 3  "♥")
(add-unicode 4  "♦") (add-unicode 5  "♣")  (add-unicode 6  "♠")
(add-unicode 11 "♂") (add-unicode 12  "♀") (add-unicode 13 "♪")
(add-unicode 14 "♫") (add-unicode 15 "☼")  (add-unicode 16 "►")
(add-unicode 17 "◄") (add-unicode 18 "↕")  (add-unicode 19 "‼")
(add-unicode 20  "¶") (add-unicode 21 "§") (add-unicode 22 "▬")
(add-unicode 23 "↨") (add-unicode 24  "↑") (add-unicode 25 "↓")
(add-unicode 26 "→")  (add-unicode 28  "∟") (add-unicode 29 "↔")
(add-unicode 30 "▲") (add-unicode 31 "▼")  (add-unicode 127 "⌂")

;;; Control Characters
(add-ascii  8 #\backspace)
(add-ascii  9 #\tab)
(add-ascii 10 #\newline)
(add-ascii 13 #\return)
(add-ascii 27 #\escape) 

;;; ASCII 32 - 63
(add-ascii 32 #\ ) (add-ascii 33 #\!) (add-ascii 34 #\") (add-ascii 35 #\#)
(add-ascii 36 #\$) (add-ascii 37 #\%) (add-ascii 38 #\&) (add-ascii 39 #\')
(add-ascii 40 #\() (add-ascii 41 #\)) (add-ascii 42 #\*) (add-ascii 43 #\+)
(add-ascii 44 #\,) (add-ascii 45 #\-) (add-ascii 46 #\.) (add-ascii 47 #\/)
(add-ascii 48 #\0) (add-ascii 49 #\1) (add-ascii 50 #\2) (add-ascii 51 #\3)
(add-ascii 52 #\4) (add-ascii 53 #\5) (add-ascii 54 #\6) (add-ascii 55 #\7)
(add-ascii 56 #\8) (add-ascii 57 #\9) (add-ascii 58 #\:) (add-ascii 59 #\;)
(add-ascii 60 #\<) (add-ascii 61 #\=) (add-ascii 62 #\>) (add-ascii 63 #\?)

;;; ASCII 64 - 95
(add-ascii 64 #\@) (add-ascii 65 #\A) (add-ascii 66 #\B) (add-ascii 67 #\C)
(add-ascii 68 #\D) (add-ascii 69 #\E) (add-ascii 70 #\F) (add-ascii 71 #\G)
(add-ascii 72 #\H) (add-ascii 73 #\I) (add-ascii 74 #\J) (add-ascii 75 #\K)
(add-ascii 76 #\L) (add-ascii 77 #\M) (add-ascii 78 #\N) (add-ascii 79 #\O)
(add-ascii 80 #\P) (add-ascii 81 #\Q) (add-ascii 82 #\R) (add-ascii 83 #\S)
(add-ascii 84 #\T) (add-ascii 85 #\U) (add-ascii 86 #\V) (add-ascii 87 #\W)
(add-ascii 88 #\X) (add-ascii 89 #\Y) (add-ascii 90 #\Z) (add-ascii 91 #\[)
(add-ascii 92 #\\) (add-ascii 93 #\]) (add-ascii 94 #\^) (add-ascii 95 #\_)

;;; ASCII 96 - 126
(add-ascii 96  #\`) (add-ascii 97  #\a) (add-ascii 98  #\b) (add-ascii 99  #\c)
(add-ascii 100 #\d) (add-ascii 101 #\e) (add-ascii 102 #\f) (add-ascii 103 #\g)
(add-ascii 104 #\h) (add-ascii 105 #\i) (add-ascii 106 #\j) (add-ascii 107 #\k)
(add-ascii 108 #\l) (add-ascii 109 #\m) (add-ascii 110 #\n) (add-ascii 111 #\o)
(add-ascii 112 #\p) (add-ascii 113 #\q) (add-ascii 114 #\r) (add-ascii 115 #\s)
(add-ascii 116 #\t) (add-ascii 117 #\u) (add-ascii 118 #\v) (add-ascii 119 #\w)
(add-ascii 120 #\x) (add-ascii 121 #\y) (add-ascii 122 #\z) (add-ascii 123 #\{)
(add-ascii 124 #\|) (add-ascii 125 #\}) (add-ascii 126 #\~)
(add-ascii 127 #\delete)

;;; Build the reverse table
(hash-table-walk *code->char*
		 (lambda (code char)
		   (hash-table-set! *char->code* char code)))

;;;  __  __ _              _ _
;;; |  \/  (_)___  ___ ___| | | __ _ _ __   ___  ___  _   _ ___
;;; | |\/| | / __|/ __/ _ \ | |/ _` | '_ \ / _ \/ _ \| | | / __|
;;; | |  | | \__ \ (_|  __/ | | (_| | | | |  __/ (_) | |_| \__ \
;;; |_|  |_|_|___/\___\___|_|_|\__,_|_| |_|\___|\___/ \__,_|___/

(define *gensym-counter* 0)

(define (unbound-symbol? maybe-sym scope)
  (and (symbol? maybe-sym)
       (not (memq maybe-sym scope))))

(define (gen-sym prefix)
  (set! *gensym-counter* (+ 1 *gensym-counter*))
  (string->symbol
   (string-append
    prefix (number->string *gensym-counter*))))

(define (string->exprs str)
  (call-with-input-string (string-append "(" str ")") read))

(define (yields-boolean? expr)
  (define *yields-boolean*
    `(or
      <   >
      >=  <=
      eq?         and          pair?
      null?       equal?       =
      string?     vector?      number?
      kl:=        kl:not       kl:tuple?
      kl:empty?   kl:symbol?   kl:boolean?
      kl:element? kl:variable? kl:shen.pvar?))

  (cond
   ((boolean? expr) #t)
   ((pair? expr)
    (or (memq (car expr) *yields-boolean*)
        (and (eq? 'l2r (car expr))
	     (yields-boolean? (car (cdr expr))))))
   (else #f)))

(define (force-boolean expr)
  (if (yields-boolean? expr)
      expr
      `(assert-boolean ,expr)))

(define (prefix-op op)
  (let* ((sop (symbol->string op))
 	 (opl (string-length sop)))
    (cond
     ((and (> opl 5)
	   (string=? "lisp." (substring sop 0 5)))
      (string->symbol (substring sop 5 opl)))
     ((and (> opl 7)
	   (string=? "scheme." (substring sop 0 7)))
      (string->symbol (substring sop 7 opl)))
     (else
      (string->symbol (string-append "kl:" sop))))))

;;;  ____  _               _     __  __                   _
;;; |  _ \(_)_ __ ___  ___| |_  |  \/  | __ _ _ __  _ __ (_)_ __   __ _
;;; | | | | | '__/ _ \/ __| __| | |\/| |/ _` | '_ \| '_ \| | '_ \ / _` |
;;; | |_| | | | |  __/ (__| |_  | |  | | (_| | |_) | |_) | | | | | (_| |
;;; |____/|_|_|  \___|\___|\__| |_|  |_|\__,_| .__/| .__/|_|_| |_|\__, |
;;;                                          |_|   |_|            |___/

(define (unary-op-mapping op)
  (define unary-op-mappings
    ;;; K-Lambda  ->  Scheme
    '((number?      . number?)      ;;; K-Kambda 46
      (string?      . string?)      ;;; K-Lambda 10 
      (symbol?      . symbol?)      ;;; TODO Is this needed? Shen has it's own version!!!!
      (cons?        . pair?)        ;;; K-Lambda 18
      (absvector?   . vector?)      ;;; K-Lambda 29
      (simple-error . simple-error) ;;; K-Lambda 15
      (hd           . car)          ;;; K-Lambda 19
      (tl           . cdr)))        ;;; K-Lambda 20
  (let ((res (assq op unary-op-mappings)))
    (and res (cdr res))))

(define (binary-op-mapping op)
  (define binary-op-mappings
    ;;; K-Lambda  ->  Scheme
    '((+          . +)
      (-          . -)
      (*          . *)
      (>          . >)
      (<          . <)
      (>=         . >=)
      (<=         . <=)
      (cons       . cons)))
  (let ((res (assq op binary-op-mappings)))
    (and res (cdr res))))

;;;   ____                      _ _
;;;  / ___|___  _ __ ___  _ __ (_) | ___ _ __
;;; | |   / _ \| '_ ` _ \| '_ \| | |/ _ \ '__|
;;; | |__| (_) | | | | | | |_) | | |  __/ |
;;;  \____\___/|_| |_| |_| .__/|_|_|\___|_|
;;;                      |_|

(define (compile-expression expr scope)
  (define (unbound? maybe-sym)
    (unbound-symbol? maybe-sym scope))

  (define (ce expr . extra-scope)
    (compile-expression expr (append extra-scope scope)))

  (cond
   ((null? expr)
    '(quote ()))

   ((unbound? expr)
    (if (and (symbol? expr)
	     (equal? expr (string->symbol ",")))
	`(string->symbol ,(symbol->string expr))
	`(quote ,expr)))

   ;;; K-Lambda 1: IF
   ((and (list? expr)
         (= (length expr) 4)
         (eq? (car expr) 'if))
    (let ((test (list-ref expr 1))
	  (then (list-ref expr 2))
	  (else (list-ref expr 3)))
      `(if ,(force-boolean (ce test))
           ,(ce then)
           ,(ce else))))

   ;;; K-Lambda 2: AND
   ((and (pair? expr)
         (= (length expr) 3)
         (eq? (car expr) 'and))
    (let ((expr1 (list-ref expr 1))
	  (expr2 (list-ref expr 2)))
      `(and ,(force-boolean (ce expr1))
	    ,(force-boolean (ce expr2)))))

   ;;; K-Lambda 3: OR
   ((and (pair? expr)
         (= (length expr) 3)
         (eq? (car expr) 'or))
    (let ((expr1 (list-ref expr 1))
	  (expr2 (list-ref expr 2)))
      `(or ,(force-boolean (ce expr1))
           ,(force-boolean (ce expr2)))))

   ;;; K-Lambda 4: COND
   ((and (pair? expr)
         (> (length expr) 1)
         (eq? (car expr) 'cond))
    (emit-cond (cdr expr) scope))

   ;;; K-Lambda 6: POS
   ((and (list? expr)
         (eq? (car expr) 'pos)
         (= (length expr) 3))
    (let ((str (list-ref expr 1))
	  (n (list-ref expr 2)))
      `(make-string 1 (string-ref ,(ce str) ,(ce n)))))
   
   ;;; K-Lambda 8: CN
   ((and (list? expr)
         (eq? (car expr) 'cn)
         (= (length expr) 3))
    (let ((str1 (list-ref expr 1))
	  (str2 (list-ref expr 2)))
      `(string-append ,(ce str1) ,(ce str2))))

   ;;; K-Lambda 16: TRAP-ERROR
   ((and (list? expr)
         (eq? (car expr) 'trap-error)
         (= (length expr) 3)
         (list? (list-ref expr 2))
         (eq? (car (list-ref expr 2)) 'lambda))
    (let* ((expression (list-ref expr 1)) ;;; TRY
	   (fun        (list-ref expr 2)) ;;; Catch (lambda E (....))
	   (args       (list-ref fun 1))  ;;; Args to the catch E 
	   (body       (list-ref fun 2))) ;;; Exception Handler 
      `(guard
	 (lambda (,args) ,(ce body args))
	 (lambda () ,(ce expression)))))

   ((and (list? expr)
	 (eq? (car expr) 'trap-error)
	 (= (length expr) 3))
    (let ((expression (list-ref expr 1))
	  (handler    (list-ref expr 2)))
	  `(guard
              (lambda (e) (,(ce handler) e))
	     ,(ce expression))))

   ;;; K-Lambda 23: LAMBDA
   ((and (pair? expr)
         (= (length expr) 3)
         (eq? (car expr) 'lambda))
    (let ((var  (list-ref expr 1))
	  (body (list-ref expr 2)))
      `(lambda (,var) ,(ce body var))))

   ;;; K-Lambda 24: LET
   ((and (pair? expr)
	 (= (length expr) 4)
	 (eq? (car expr) 'let))
    (let ((var   (list-ref expr 1))
	  (value (list-ref expr 2))
	  (body  (list-ref expr 3)))
      (emit-let var value body (cons var scope))))

   ;;; K-Lambda 25: =
   ((and (list? expr)
         (eq? (car expr) '=)
         (= (length expr) 3))
    (let ((v1 (list-ref expr 1))
	  (v2 (list-ref expr 2)))
      (emit-equality-check v1 v2 scope)))

   ;;; K-Lambda 27: FREEZE
   ((and (list? expr)
         (eq? (car expr) 'freeze)
         (= (length expr) 2))
    (let ((expr1 (list-ref expr 1)))
      `(lambda () ,(ce expr1))))

    ;;; K-Lambda 28: TYPE
   ((and (pair? expr)
         (eq? (car expr) 'type)
         (= (length expr) 3))
    (let ((x    (list-ref expr 1))
	  (type (list-ref expr 2)))
      (ce x)))
   
   ;;; K-Lambda 29: ABSVECTOR
   ((and (list? expr)
         (eq? (car expr) 'absvector)
         (= (length expr) 2))
    (let ((n (list-ref expr 1)))
      `(make-vector ,(ce n) '(quote shen.fail!))))

   ;;; K-Lambda 30: ADDRESS->
   ((and (list? expr)
         (eq? (car expr) 'address->)
         (= (length expr) 4))
    (let ((v (list-ref expr 1))
	  (n (list-ref expr 2))
	  (x (list-ref expr 3)))
      `(let ((_tmp ,(ce v)))
	 (vector-set! _tmp ,(ce n) ,(ce x))
	 _tmp)))

   ;;; K-Lambda 31: <-ADDRESS
   ((and (list? expr)
         (eq? (car expr) '<-address)
         (= (length expr) 3))
    (let ((v (list-ref expr 1))
	  (n (list-ref expr 2)))
      `(vector-ref ,(ce v) ,(ce n))))

   ;;; K-Lambda 41: /
   ((and (list? expr)
         (eq? (car expr) '/)
         (= (length expr) 3))
    (let ((a (list-ref expr 1))
	  (b (list-ref expr 2)))
      `(/ ,(ce a) ,(ce b))))

   ;;; DO
   ((and (list? expr)
         (eq? (car expr) 'do)
         (= (length expr) 3))
    (let ((expr1 (list-ref expr 1))
	  (expr2 (list-ref expr 2)))
      `(begin ,(ce expr1)
	      ,(ce expr2))))

   ;;; FAIL
   ((equal? expr '(fail))
    '(quote shen.fail!))

   ;;; Native Chicken call
   ((and (list? expr)
	 (eq? (car expr) 'scheme.)
	 (= (length expr) 2))
    (car (string->exprs (cadr expr))))
   
   ;;; Evaluate remaining expressions that include K-Lambda
   ;;; primitives and procedures directly mapped to Scheme.
   ((list? expr)
    (emit-application (car expr) (cdr expr) scope))
   (else
    expr)))

(define (emit-let var value body scope)
  `(let ((,var ,(compile-expression value scope)))
     ,(compile-expression body (cons var scope))))

(define (emit-cond clauses scope)
  `(cond ,@(emit-cond-clauses clauses scope)))

(define (emit-cond-clauses clauses scope)
  (cond
   ((null? clauses) '())
   ((and (pair? clauses)
         (pair? (car clauses))
         (= (length (car clauses)) 2))
    (let* ((test (car  (car clauses)))
	   (body (cadr (car clauses)))
	   (rest (cdr clauses))
	   (compiled-test (compile-expression test scope))
           (compiled-body (compile-expression body scope))
           (compiled-rest (emit-cond-clauses rest scope)))
      `((,(force-boolean compiled-test) ,compiled-body)
        ,@compiled-rest)))))

(define (emit-equality-check v1 v2 scope)
  (let ((lhs (compile-expression v1 scope))
	(rhs (compile-expression v2 scope)))
    (cond
     ((or (unbound-symbol? v1 scope)
          (unbound-symbol? v2 scope)
          (equal? '(fail) v1)
          (equal? '(fail) v2))
      `(eq? ,lhs ,rhs))
     ((and (string? lhs) (string? rhs))
      `(string=? ,lhs ,rhs))
     ((and (vector? lhs) (vector? rhs))
      `(vector=? ,lhs ,rhs))
     ((and (number? lhs) (number? rhs))
      `(= ,lhs ,rhs))
     ((or (string? v1) (string? v2))
      `(equal? ,lhs ,rhs))
     ((null? v1)
      `(null? ,(compile-expression v2 scope)))
     ((null? v2)
      `(null? ,(compile-expression v1 scope)))
     (else
      `(kl:= ,lhs ,rhs)))))

(define (emit-application op params scope)
  (let* ((arity (function-arity op))
  	 (partial-call?
	  (not (or
	        (= arity -1)
	        (= arity (length params)))))
	 (args
	  (map
	   (lambda (exp)
	     (compile-expression exp scope))
	   params)))
    (cond
     ((and (<= arity 0)
	   (null? args))
      (cond
       ((pair? op)
	`(,(compile-expression op scope)))
       ((unbound-symbol? op scope)
	`(,(prefix-op op)))
       (else
	`(,op))))
     (partial-call?
      (nest-call (nest-lambda op arity '()) args))
     ((or (pair? op)
	  (not (unbound-symbol? op scope)))
      (nest-call (compile-expression op scope) args))
     (else
      (cond
       ((and (= arity 2)
	     (binary-op-mapping op))
	(cons (binary-op-mapping op) args))
       ((and (= arity 1)
	     (unary-op-mapping op))
	(cons (unary-op-mapping op) args))
       (else
	(let ((op (prefix-op op)))
          (cons op args))))))))

(define (nest-call op args)
  (if (null? args)
      op
      (nest-call (list op (car args)) (cdr args))))

(define (nest-lambda callable arity scope)
  (define (merge-args f arg)
    (if (pair? f)
        (append f (list arg))
        (list f arg)))

  (if (<= arity 0)
      (compile-expression callable scope)
      (let ((aname (gen-sym "Y")))
        `(lambda (,aname)
           ,(nest-lambda (merge-args callable aname)
                         (- arity 1)
                         (cons aname scope))))))
;;;  _  __     _                    _         _
;;; | |/ /    | |    __ _ _ __ ___ | |__   __| | __ _
;;; | ' /_____| |   / _` | '_ ` _ \| '_ \ / _` |/ _` |
;;; | . \_____| |__| (_| | | | | | | |_) | (_| | (_| |
;;; |_|\_\    |_____\__,_|_| |_| |_|_.__/ \__,_|\__,_|
;;;
;;;              _____
;;;             |_   _|__
;;;               | |/ _ \
;;;               | | (_) |
;;;               |_|\___/
;;;
;;;  ____       _
;;; / ___|  ___| |__   ___ _ __ ___   ___
;;; \___ \ / __| '_ \ / _ \ '_ ` _ \ / _ \
;;;  ___) | (__| | | |  __/ | | | | |  __/
;;; |____/ \___|_| |_|\___|_| |_| |_|\___|

(define (kl->scheme expr)
  (cond
   ((and (pair? expr)
	 (eq? (car expr) 'defun))
    (let ((name (list-ref expr 1))
	  (args (list-ref expr 2))
	  (body (list-ref expr 3)))
       ;;; K-Lambda 22: DEFUN
      `(begin
	 (register-function-arity (quote ,name) ,(length args))
	 (define (,(prefix-op name) ,@args) ,(compile-expression body args))
	 (quote ,name))))
   (else
    (compile-expression expr '()))))

(initialize-arity-table
 '((abort               0)
   (absvector?          1)
   (absvector           1)
   (adjoin              2)
   (and                 2)
   (append              2)
   (arity               1)
   (assoc               2)
   (boolean?            1)
   (cd                  1)
   (compile             3)
   (concat              2)
   (cons                2)
   (cons?               1)
   (cn                  2)
   (declare             2)
   (destroy             1)
   (difference          2)
   (do                  2)
   (element?            2)
   (empty?              1)
   (enable-type-theory  1)
   (interror            2)
   (eval                1)
   (eval-kl             1)
   (explode             1)
   (external            1)
   (fail-if             2)
   (fail                0)
   (fix                 2)
   (findall             5)
   (freeze              1)
   (fst                 1)
   (gen-sym             1)
   (get                 3)
   (get-time            1)
   (address->           3)
   (<-address           2)
   (<-vector            2)
   (<                   2)
   (>                   2)
   (>=                  2)
   (<=                  2)
   (=                   2)
   (hd                  1)
   (hdv                 1)
   (hdstr               1)
   (head                1)
   (if                  3)
   (integer?            1)
   (intern              1)
   (identical           4)
   (inferences          0)
   (input               1)
   (input+              2)
   (implementation      0)
   (intersection        2)
   (it                  0)
   (kill                0)
   (language            0)
   (number?             1)
   (read-from-string    1)
   (receive             1)
   (release             0)
   (remove              2)
   (require             3)
   (reverse             1)
   (set                 2)
   (simple-error        1)
   (snd                 1)
   (specialise          1)
   (spy                 1)
   (step                1)
   (stinput             0)
   (stoutput            0)
   (string->n           1)
   (string->symbol      1)
   (string?             1)
   (subst               3)
   (sum                 1)
   (symbol?             1)
   (tail                1)
   (tl                  1)
   (tc                  1)
   (tc?                 0)
   (thaw                1)
   (tlstr               1)
   (track               1)
   (trap-error          2)
   (tuple?              1)
   (type                2)
   (return              3)
   (undefmacro          1)
   (unput               3)
   (unprofile           1)
   (unify               4)
   (unify!              4)
   (union               2)
   (untrack             1)
   (unspecialise        1)
   (undefmacro          1)
   (vector              1)
   (vector->            3)
   (value               1)
   (variable?           1)
   (version             0)
   (write-byte          2)
   (write-to-file       2)
   (y-or-n?             1)
   (+                   2)
   (*                   2)
   (/                   2)
   (-                   2)
   (==                  2)
   (<e>                 1)
   (@p                  2)
   (@v                  2)
   (@s                  2)
   (preclude            1)
   (include             1)
   (preclude-all-but    1)
   (include-all-but     1)
   (where               2)))