(define list? proper-list?)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Modules
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define temp-value #f)

;; setup the main modules
(define *texmacs-module* (curlet))
(define *current-module* *texmacs-module*)
(define *module-name* '(texmacs-user))
(define *exports* '())

(define *modules* (make-hash-table))
(set! (*modules* '(texmacs)) *texmacs-module*)

(define (current-module) *current-module*)

(define-macro (export . symbols)
    `(set! *exports* (append ',symbols *exports*)))

(define-macro (with-module-old module . body)
  `(let ((m ,module)) (with-let m
     (let-temporarily (((*texmacs-module* '*current-module*) (curlet)))
     ,@body))))

(define-macro (with-module module . body)
  `(let ((m ,module)) (eval
     `(let-temporarily
        (((*texmacs-module* '*current-module*) (curlet)))
        ,@',body) m)))


(define-macro (define-public head . body)
    `(begin
        (define ,head ,@body)
        (export ,(if (pair? head) (car head) head))))
        
        
(define-macro (provide-public head . body)
  (if (or (and (symbol? head) (not (defined? head)))
	  (and (pair? head) (symbol? (car head)) (not (defined? (car head)))))
      `(define-public ,head ,@body)
      '(noop)))

(define-macro (define-public-macro head . body)
    `(begin
	   (define-macro ,head ,@body)
	   (export ,(if (pair? head) (car head) head))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Module handling
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (module-available? module)
  (if (hash-table-ref *modules* module) #t #f))

(define (list->module module)
  (let* ((aux (lambda (s) (string-append "/" (symbol->string s))))
     (name* (apply string-append (map aux module)))
     (name (substring name* 1 (string-length name*)))
     (u (url-unix "$GUILE_LOAD_PATH" (string-append name ".scm")))
     ;; FIXME: should use %load-path instead of $GUILE_LOAD_PATH
     )
    (url-materialize u "r")))

(define (module-load module)
  (if (list? module)
      (let ((module-file (list->module module))
             (loaded (hash-table-ref *modules* module)))
    (when (not loaded)
        (display "TeXmacs] Loading module ") (display module) (display "\n")
        (with-module (sublet (hash-table-ref *modules* '(texmacs))
                             '*exports* ()
                             '*module-file* module-file)
                (load *module-file* (curlet)))))))

(define (module-provide module)
  (if (not (module-available? module)) (module-load module)))

(define (resolve-module module)
  (module-provide module)
    (hash-table-ref *modules* module))

(define-macro (use-modules . modules)
  `(map (lambda (module)
    (let* ((m (resolve-module module))
           (ex (m '*exports*))
           (exx (map (lambda (entry) (if (member (car entry) ex) entry (values))) m))
           (en (apply inlet exx)))
        (varlet (*texmacs-module* '*current-module*) en)))
      ',modules))

(define-macro (import-from . modules)
  `(use-modules ,@modules))

(define-macro (re-export . symbols)
  `(export ,@symbols))

(define-macro (inherit-modules . which-list)
  (define (module-exports which)
    (let* ((m (resolve-module which)))
        (m '*exports*)))
  (let ((l (apply append (map module-exports which-list))))
    `(begin
       (use-modules ,@which-list)
       (re-export ,@l))))

(define-macro (texmacs-module name . options)
  (define (transform action)
    (cond ((not (pair? action)) (noop))
	  ((equal? (car action) :use) (cons 'use-modules (cdr action)))
	  ((equal? (car action) :inherit) (cons 'inherit-modules (cdr action)))
	  ((equal? (car action) :export)
	   (display "Warning] The option :export is no longer supported\n")
	   (display "       ] Please use tm-define instead\n"))
	  (else '(noop))))
  (let ((l (map transform options)))
    ;;(display "loading ") (display name) (display "\n")
    `(begin
        (define *module-name* ',name)
        (define *exports* ())
        (hash-table-set! *modules* ',name (current-module))
       ,@l)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; On-entry and on-exit macros
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (quit-TeXmacs-scheme) (noop))

(define-macro (on-entry . cmd)
  `(begin ,@cmd))

(define-macro (on-exit . cmd)
  `(set! quit-TeXmacs-scheme (lambda () ,@cmd (,quit-TeXmacs-scheme))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Adaptive hash tables
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define-public make-ahash-table make-hash-table)
(define-public ahash-ref hash-table-ref)
(define-public (ahash-get-handle h s)
  (let ((v  (hash-table-ref h s))) (if v (cons s v) #f)))
(define-public ahash-set! hash-table-set!)
(define-public (ahash-remove! h s) (hash-table-set! h s #f))
(define-public (ahash-table->list h) (map values h))
(define-public (ahash-size h) (lenght h))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Extra routines on adaptive hash tables
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define-public (list->ahash-table l)
  (let ((t (make-ahash-table)))
    (for-each (lambda (x) (ahash-set! t (car x) (cdr x))) l)
    t))

(define-public (list->frequencies l)
  (let ((t (make-ahash-table)))
    (for-each (lambda (x) (ahash-set! t x (+ 1 (or (ahash-ref t x) 0)))) l)
    t))

(define-public-macro (ahash-with t var val . body)
  (let ((old-val (gensym))
	(ret-val (gensym)))
    `(with ,old-val (ahash-ref ,t ,var)
       (ahash-set! ,t ,var ,val)
       (with ,ret-val (begin ,@body)
	 (ahash-set! ,t ,var ,old-val)
	 ,ret-val))))

(define-public (ahash-table-invert t)
  (let* ((l (ahash-table->list t))
	 (u (map (lambda (x) (cons (cdr x) (car x))) l)))
    (list->ahash-table u)))

(define-public (ahash-table-append . tl)
  (with ls (map ahash-table->list tl)
    (list->ahash-table (apply append ls))))

(define-public (ahash-table-difference t1 t2)
  (let ((r (make-ahash-table)))
    (for (x (map car (ahash-table->list t1)))
      (when (not (ahash-ref t2 x))
        (ahash-set! r x (ahash-ref t1 x))))
    r))

(define-public (ahash-table-map fun t)
  (let* ((l (ahash-table->list t))
	 (r (map (lambda (x) (cons (car x) (fun (cdr x)))) l)))
    (list->ahash-table r)))

(define-public (ahash-ref* h var val)
  (or (ahash-ref h var) val))

(define-public (ahash-table-select t l)
  (let ((r (make-ahash-table)))
    (for-each (lambda (x)
                (if (ahash-ref t x) (ahash-set! r x (ahash-ref t x)))) l)
    r))


;;; certain Scheme versions do not define 'filter'
(if (not (defined? 'filter))
    (define-public (filter pred? l)
      (apply append (map (lambda (x) (if (pred? x) (list x) (list))) l))))

;; curried define
(define base-define define)
(define-public-macro (curried-define head . body)
    (if (pair? head)
      `(,curried-define ,(car head) (lambda ,(cdr head) ,@body))
      `(,base-define ,head ,@body)))
;(varlet *texmacs-module* 'define curried-define)

(define-public (noop . l) (if #f #f #f))

(define-public (acons key datum alist) (cons (cons key datum) alist))

(define-public (symbol-append . l)
   (string->symbol (apply string-append (map symbol->string l))))

(define-public (map-in-order . l) (apply map l))

(define-public lazy-catch catch)

(define-public (last-pair lis)
;;  (check-arg pair? lis last-pair)
  (let lp ((lis lis))
    (let ((tail (cdr lis)))
      (if (pair? tail) (lp tail) lis))))


(define-public (seed->random-state seed) (random-state seed))


(define-public (copy-tree tree)
  (let loop ((tree tree))
    (if (pair? tree)
        (cons (loop (car tree)) (loop (cdr tree)))
        tree)))


(define-public (assoc-set! l what val)
  (let ((b (assoc what l)))
    (if b (set! (cdr b) val) (set! l (cons (cons what val) l)))
    l))

;;FIXME: assoc-set! is tricky to use, maybe just get rid in the code
(define-public (assoc-set! l what val)
  (let ((b (assoc what l)))
    (if b (set! (cdr b) val) (set! l (cons (cons what val) l)))
    l))

(define-public (assoc-ref l what)
  (let ((b (assoc what l)))
    (if b (cdr b) #f)))

(define-public (sort l op) (sort! (copy l) op))

(define-public (force-output) (flush-output-port *stdout*))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; FIXME

;getlogin
;string-split
; char-set-adjoin
;make-record-type
;string-index

(define-public (getpid) 1)
(define-public (access? . l) #f)
(define-public R_OK #f)

(define-public (current-time) 100)

(define *default-bound* (- (expt 2 29) 3))

(define (%string-hash s ch-conv bound)
  (let ((hash 31)
    (len (string-length s)))
    (do ((index 0 (+ index 1)))
      ((>= index len) (modulo hash bound))
      (set! hash (modulo (+ (* 37 hash)
                (char->integer (ch-conv (string-ref s index))))
             *default-bound*)))))

(define (string-hash s . maybe-bound)
  (let ((bound (if (null? maybe-bound) *default-bound* (car maybe-bound))))
    (%string-hash s (lambda (x) x) bound)))

(define (string-ci-hash s . maybe-bound)
  (let ((bound (if (null? maybe-bound) *default-bound* (car maybe-bound))))
    (%string-hash s char-downcase bound)))

(define (symbol-hash s . maybe-bound)
  (let ((bound (if (null? maybe-bound) *default-bound* (car maybe-bound))))
    (%string-hash (symbol->string s) (lambda (x) x) bound)))

(define (vector-hash v bound)
  (let ((hashvalue 571)
    (len (vector-length v)))
    (do ((index 0 (+ index 1)))
      ((>= index len) (modulo hashvalue bound))
      (set! hashvalue (modulo (+ (* 257 hashvalue) (hash (vector-ref v index)))
                  *default-bound*)))))

(define-public (hash obj . maybe-bound)
  (let ((bound (if (null? maybe-bound) *default-bound* (car maybe-bound))))
    (cond ((integer? obj) (modulo obj bound))
      ((string? obj) (string-hash obj bound))
      ((symbol? obj) (symbol-hash obj bound))
      ((real? obj) (modulo (+ (numerator obj) (denominator obj)) bound))
      ((number? obj)
       (modulo (+ (hash (real-part obj)) (* 3 (hash (imag-part obj))))
           bound))
      ((char? obj) (modulo (char->integer obj) bound))
      ((vector? obj) (vector-hash obj bound))
      ((pair? obj) (modulo (+ (hash (car obj)) (* 3 (hash (cdr obj))))
                   bound))
      ((null? obj) 0)
      ((not obj) 0)
      ((procedure? obj) (error "hash: procedures cannot be hashed" obj))
      (else 1))))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Dictionaries
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (fill-dictionary-entry d key im)
  (if (nnull? key)
      (begin
	(ahash-set! d (car key) im)
	(fill-dictionary-entry d (cdr key) im))))

(define-public (fill-dictionary d l)
  "Fill hash table @d with list of entries @l"
  ;; Note: depreciated
  (if (nnull? l)
      (begin
	(let* ((r (reverse (car l))))
	  (fill-dictionary-entry d (cdr r) (car r)))
	(fill-dictionary d (cdr l)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Simple definition of hash tables
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define-public (define-table-decls h l)
  (define (insert binding)
    (ahash-set! h (car binding) (cdr binding)))
  (for-each insert l))

(define-public-macro (define-table name . l)
  `(begin
     (when (not (defined? ',name))
       (if (defined? 'tm-define)
           (tm-define ,name (make-ahash-table))
           (define-public ,name (make-ahash-table))))
     (define-table-decls ,name ,(list 'quasiquote l))))

(define-public-macro (extend-table name . l)
  `(define-table-decls ,name ,(list 'quasiquote l)))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Common notations
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define-public == equal?)
(define-public (!= x y) (not (equal? x y)))

(define-public (nsymbol? x) (not (symbol? x)))
(define-public (nstring? x) (not (string? x)))
(define-public (nnull? x) (not (null? x)))
(define-public (npair? x) (not (pair? x)))
(define-public (nlist? x) (not (list? x)))
(define-public (nnot x) (not (not x)))
(define-public-macro (toggle! x) `(set! ,x (not ,x)))
(define-public (safe-car l) (and (pair? l) (car l)))
(define-public (safe-cdr l) (and (pair? l) (cdr l)))

(define-public (list-1? x) (and (pair? x) (null? (cdr x))))
(define-public (nlist-1? x) (not (list-1? x)))
(define-public (list-2? x) (and (list? x) (= (length x) 2)))
(define-public (nlist-2? x) (not (list-2? x)))
(define-public (list-3? x) (and (list? x) (= (length x) 3)))
(define-public (nlist-3? x) (not (list-3? x)))
(define-public (list-4? x) (and (list? x) (= (length x) 4)))
(define-public (nlist-4? x) (not (list-4? x)))
(define-public (list>0? x) (and (pair? x) (list? x)))
(define-public (nlist>0? x) (not (list>0? x)))
(define-public (list>1? x) (and (list? x) (> (length x) 1)))
(define-public (nlist>1? x) (not (list>1? x)))

(define-public (in? x l) (not (not (member x l))))
(define-public (nin? x l) (not (member x l)))
(define-public (cons-new x l) (if (in? x l) l (cons x l)))

(define-public (always? . l) #t)
(define-public (never? . l) #f)
(define-public (root? t) (== (reverse (tree-ip t)) (buffer-path)))
(define-public (nroot? t) (!= (reverse (tree-ip t)) (buffer-path)))
(define-public (leaf? t) (== (tree-ip t) (cdr (reverse (cursor-path)))))
(define-public (nleaf? t) (!= (tree-ip t) (cdr (reverse (cursor-path)))))
(define-public (true? . l) #t)
(define-public (false? . l) #f)

(provide-public (identity x) x)
(provide-public (ignore . l) (noop))
(provide-public (negate pred?) (lambda x (not (apply pred? x))))

(define-public (keyword->string x)
  (symbol->string (keyword->symbol x)))
(define-public (string->keyword x)
  (symbol->keyword (string->symbol x)))
(define-public (keyword->number x)
  (string->number (string-tail (symbol->string (keyword->symbol x)) 1)))
(define-public (number->keyword x)
  (symbol->keyword (string->symbol (string-append "%" (number->string x)))))

(define-public (save-object file value)
  (string-save (with-output-to-string (lambda () (write value)))
       (url-materialize file "")))

(define-public (load-object file)
  (with-input-from-string (string-load (url-materialize file "r")) read))

(define-public (persistent-ref dir key)
  (and (persistent-has? dir key)
       (persistent-get dir key)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Common programming constructs
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define-public-macro (with var val . body)
  (if (pair? var)
      `(apply (lambda ,var ,@body) ,val)
      `(let ((,var ,val)) ,@body)))

(define-public-macro (with-define fun fun-body . body)
  `(let ((,(car fun) (lambda ,(cdr fun) ,fun-body)))
     ,@body))

(define-public-macro (with-global var val . body)
  (let ((old (gensym)) (new (gensym)))
    `(let ((,old ,var))
       (set! ,var ,val)
       (let ((,new (begin ,@body)))
         (set! ,var ,old)
         ,new))))

(define-public-macro (and-with var val . body)
  `(with ,var ,val
     (and ,var (begin ,@body))))

(define-public-macro (with-result result . body)
  `(let* ((return ,result)
          (dummy (begin ,@body)))
     return))

(define (range-list start end delta)
  (if (< start end)
      (cons start (range-list (+ start delta) end delta))
      '()))

(define (range-list* start end delta)
  (if (<= start end)
      (cons start (range-list* (+ start delta) end delta))
      '()))

(define-public (.. start end . delta)
  (if (null? delta)
      (range-list start end 1)
      (range-list start end (car delta))))

(define-public (... start end . delta)
  (if (null? delta)
      (range-list* start end 1)
      (range-list* start end (car delta))))

(define-public-macro (for what . body)
  (let ((n (length what)))
    (cond ((== n 2)
           ;; range over values of a list
           `(for-each (lambda (,(car what)) ,@body)
                      ,(cadr what)))
          ((== n 3)
           ;; range over values from start to end with step 1
           `(do ((,(car what) ,(cadr what) (+ ,(car what) 1)))
                ((>= ,(car what) ,(caddr what)) (noop))
              ,@body))
          ((== n 4)
           ;; range over values from start to end with step
           `(if (> ,(cadddr what) 0)
                (do ((,(car what) ,(cadr what) (+ ,(car what) ,(cadddr what))))
                    ((>= ,(car what) ,(caddr what)) (noop))
                  ,@body)
                (do ((,(car what) ,(cadr what) (+ ,(car what) ,(cadddr what))))
                    ((<= ,(car what) ,(caddr what)) (noop))
                  ,@body)))
          ((== n 5)
           ;; range over values from start to end with step and comparison
           `(do ((,(car what) ,(cadr what) (+ ,(car what) ,(cadddr what))))
                ((not (,(car (cddddr what)) ,(car what) ,(caddr what))) (noop))
              ,@body))
          (else '(noop)))))

(define-public-macro (repeat n . body)
  (let ((x (gensym)))
    `(for (,x 0 ,n) ,@body)))

(define-public-macro (twice . body)
  `(begin ,@body ,@body))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Contextual overloading
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define-public (ctx-add-condition l kind opt)
  ;;(display* "add condition " l ", " opt "\n")
  (append l (list opt)))

(define-public (ctx-insert ctx data conds)
  ;;(display* "insert " ctx ", " data ", " conds "\n")
  (cons (cons conds data) (or ctx '())))

(define-public (ctx-find ctx conds)
  ;;(display* "find " ctx ", " conds "\n")
  (cond ((or (not ctx) (null? ctx)) #f)
        ((== (caar ctx) conds) (cdar ctx))
        (else (ctx-find (cdr ctx) conds))))

(define-public (ctx-remove ctx conds)
  ;;(display* "remove " ctx ", " conds "\n")
  (cond ((or (not ctx) (null? ctx)) '())
        ((== (caar ctx) conds) (ctx-remove (cdr ctx) conds))
        (else (cons (car ctx) (ctx-remove (cdr ctx) conds)))))

(define (and-apply l args)
  (or (null? l)
      (and (apply (car l) (or args '()))
           (and-apply (cdr l) args))))

(define-public (ctx-resolve ctx args)
  ;;(display* "resolve " ctx ", " args "\n")
  (cond ((or (not ctx) (null? ctx)) #f)
        ((and-apply (caar ctx) args) (cdar ctx))
        (else (ctx-resolve (cdr ctx) args))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Global variables and subroutines
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define-public tm-defined-table (make-ahash-table))
(define-public tm-defined-name (make-ahash-table))
(define-public tm-defined-module (make-ahash-table))
(define-public define-option-table (make-hash-table 100))

(define-public cur-conds '())

(define cur-props-table (make-ahash-table))
(define cur-props '())

(define (ca*r x) (if (pair? x) (ca*r (car x)) x))
(define (ca*adr x) (ca*r (cadr x)))

(define (lambda* head body)
  (if (pair? head)
      (lambda* (car head) `((lambda ,(cdr head) ,@body)))
      (car body)))

(define (listify args)
  (if (pair? args)
      (cons (car args) (listify (cdr args)))
      (list args)))

(define (apply* fun head)
  (cond ((list? head)
         `(,(apply* fun (car head)) ,@(cdr head)))
        ((pair? head)
         `(apply ,(apply* fun (car head)) (cons* ,@(listify (cdr head)))))
        (else fun)))

(define (and* conds)
  (if (list-1? conds) (car conds) `(and ,@conds)))

(define (begin* conds)
  (if (list-1? conds) (car conds) `(begin ,@conds)))

(define-public (procedure-name fun) (ahash-ref tm-defined-name fun))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Overloading
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (ctx-add-condition! kind opt)
  (set! cur-conds (ctx-add-condition cur-conds kind opt)))

(define (define-option-mode opt decl)
  (ctx-add-condition! 0 (car opt))
  decl)

(define-public (predicate-option? x)
  (or (and (symbol? x) (string-ends? (symbol->string x) "?"))
      (and (pair? x) (== (car x) 'lambda))))

(define (define-option-match opt decl)
  (cond ((predicate-option? opt) (ctx-add-condition! 3 opt))
	((and (pair? opt) (null? (cdr opt))
	      (predicate-option? (car opt))
	      (list? (cadr decl)) (= (length (cadr decl)) 3))
	 (ctx-add-condition! 3 (car opt)))
	(else (ctx-add-condition! 3 `(lambda args (match? args ',opt)))))
  decl)

(define (define-option-require opt decl)
  (define-option-match
    `(lambda ,(cdadr decl) ,(car opt))
    decl))

(define (define-option-applicable opt decl)
  (with prop `(',(ca*adr decl) :applicable (list (lambda args ,@opt)))
    (set! cur-props (cons prop cur-props))
    ;;(define-option-require opt decl)
    decl))

(ahash-set! define-option-table :mode define-option-mode)
(ahash-set! define-option-table :require define-option-require)
(ahash-set! define-option-table :applicable define-option-applicable)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Properties of overloaded functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (filter-conds l)
  "Remove conditions which depend on arguments from list"
  (cond ((null? l) l)
	((>= (car l) 2) (filter-conds (cddr l)))
	(else (cons (car l) (cons (cadr l) (filter-conds (cddr l)))))))

(define-public (property-set! var prop what conds*)
  "Associate a property to a function symbol under conditions"
  (let* ((key (cons var prop))
	 (conds (filter-conds conds*)))
    (ahash-set! cur-props-table key
		(ctx-insert (ahash-ref cur-props-table key) what conds))))

(define-public (property var prop)
  "Retrieve a property of a function symbol"
  (if (procedure? var) (set! var (procedure-name var)))
  (let* ((key (cons var prop)))
    (ctx-resolve (ahash-ref cur-props-table key) #f)))

(define (property-rewrite l)
  `(property-set! ,@l (list ,@cur-conds)))

(define (define-property which) (lambda (opt decl)
  (set! cur-props (cons `(',(ca*adr decl) ,which ',opt) cur-props))
  decl))

(define (define-property* which) (lambda (opt decl)
  (set! cur-props (cons `(',(ca*adr decl) ,which (list ,@opt)) cur-props))
  decl))

(define (compute-arguments decl)
  (cond ((pair? (cadr decl)) (cdadr decl))
	((and (pair? (caddr decl)) (== (caaddr decl) 'lambda))
	 (cadr (caddr decl)))
	(else
	 (texmacs-error "compute-arguments" "Bad argument documentation"))))

(define (define-option-argument opt decl)
  (let* ((var (ca*adr decl))
	 (args (compute-arguments decl))
	 (arg (list :argument (car opt))))
    (set! cur-props (cons `(',var :arguments ',args) cur-props))
    (set! cur-props (cons `(',var ',arg ',(cdr opt)) cur-props))
    decl))

(define (define-option-default opt decl)
  (let* ((var (ca*adr decl))
	 (arg (list :default (car opt))))
    (set! cur-props (cons `(',var ',arg (lambda () ,@(cdr opt))) cur-props))
    decl))

(define (define-option-proposals opt decl)
  (let* ((var (ca*adr decl))
	 (arg (list :proposals (car opt))))
    (set! cur-props (cons `(',var ',arg (lambda () ,@(cdr opt))) cur-props))
    decl))

(ahash-set! define-option-table :type (define-property :type))
(ahash-set! define-option-table :synopsis (define-property :synopsis))
(ahash-set! define-option-table :returns (define-property :returns))
(ahash-set! define-option-table :note (define-property :note))
(ahash-set! define-option-table :argument define-option-argument)
(ahash-set! define-option-table :default define-option-default)
(ahash-set! define-option-table :proposals define-option-proposals)
(ahash-set! define-option-table :secure (define-property* :secure))
(ahash-set! define-option-table :check-mark (define-property* :check-mark))
(ahash-set! define-option-table :interactive (define-property* :interactive))
(ahash-set! define-option-table :balloon (define-property* :balloon))

(define-public (procedure-sources about)
  (or (and (procedure? about)
           (ahash-ref tm-defined-table (procedure-name about)))
      (and (procedure-source about)
           (list (procedure-source about)))))

(define-public (help about)
  ;; very provisional
  (cond ((property about :synopsis)
	 (property about :synopsis))
	((procedure-documentation about)
	 (procedure-documentation about))
	(else #f)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Overloaded functions with properties
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (unlambda pred?)
  (if (func? pred? 'lambda)
      (caddr pred?)
      (list pred?)))

(define-public (tm-add-condition var head body)
  (if (null? cur-conds) body
      `((if ,(and* (map unlambda cur-conds))
            ,(begin* body)
            ,(apply* 'former head)))))

(define-public-macro (tm-define-overloaded head . body)
  (let* ((var (ca*r head))
         (nbody (tm-add-condition var head body))
         (nval (lambda* head nbody)))
    (if (ahash-ref tm-defined-table var)
        `(let ((former ,var))
           ;;(if (== (length (ahash-ref tm-defined-table ',var)) 1)
           ;;    (display* "Overloaded " ',var "\n"))
           ;;(display* "Overloaded " ',var "\n")
           ;;(display* "   " ',nval "\n")
           (set! temp-value ,nval)
           (eval (list 'set! ',var 'temp-value) *texmacs-module*)
;           (with-module *texmacs-module*
;             (set! ,var temp-value))
           (ahash-set! tm-defined-table ',var
                       (cons ',nval (ahash-ref tm-defined-table ',var)))
           (ahash-set! tm-defined-name ,var ',var)
	   (ahash-set! tm-defined-module ',var
		       (cons *module-name*
			     (ahash-ref tm-defined-module ',var)))
           ,@(map property-rewrite cur-props))
        `(begin
           (when (nnull? cur-conds)
             (display* "warning: conditional master routine " ',var "\n")
             (display* "   " ',nval "\n"))
           ;;(display* "Defined " ',var "\n")
           ;;(if (nnull? cur-conds) (display* "   " ',nval "\n"))
           (set! temp-value
                 (if (null? cur-conds) ,nval
                     ,(list 'let '((former (lambda args (noop)))) nval)))
           (eval (list 'define ',var 'temp-value) *texmacs-module*)
;           (with-module *texmacs-module*
 ;            (define-public ,var temp-value))
           (ahash-set! tm-defined-table ',var (list ',nval))
           (ahash-set! tm-defined-name ,var ',var)
	   (ahash-set! tm-defined-module ',var
                       (list *module-name*))
           ,@(map property-rewrite cur-props)))))

(define-public (tm-define-sub head body)
  (if (and (pair? (car body)) (keyword? (caar body)))
      (let ((decl (tm-define-sub head (cdr body))))
	(if (not (ahash-ref define-option-table (caar body)))
	    (texmacs-error "tm-define-sub" "unknown option ~S" (caar body)))
	((ahash-ref define-option-table (caar body)) (cdar body) decl))
      (cons 'tm-define-overloaded (cons head body))))

(define-public-macro (tm-define head . body)
  (set! cur-conds '())
  (set! cur-props '())
  (tm-define-sub head body))


(let () 

    (let ()
        (tm-define fib (lambda (n) (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2))))))
        )

    (let ((n 40))
        (format *stdout* "(fib ~A) : ~A \n" n (fib n))))