;;;; Copyright 2002, Jonathan Bachrach.  See file TERMS.
;;;;
;;;; GOALS
;;;;
;;;; SIMPLEST POSSIBLE
;;;; DYNAMIC ORDER FORM BY FORM
;;;; MINIMIZE OBJECT SYSTEM BOOT OBFUSCATION
;;;; 

;;; Temporary, compile-time-only macros.  These are used by this file only--
;;; we never export them.  The real definitions live in macros.goo.

(dss unless (,test ,@body) `(if (@not ,test) (seq ,@body)))

(dss when (,test ,@body) `(if ,test (seq ,@body)))

(dss or (,@rest)
  (mif ((,x ,@rest) rest)
       (mif (() rest) x `(let ((tmp ,x)) (if tmp tmp (or ,@rest))))
       #f))

(dss and (,@rest)
  (mif ((,x ,@rest) rest)
       (mif (() rest) x `(if ,x (and ,@rest) #f))
       #t))

;; Define the primitives whose code is in prt.c
(dss %define-primitives ()
  `(seq ,@(map (fun (name) `(dl ,name)) primitive-names)))

(ct 
  (dv primitive-names
    '(%eq? %bb %bu
      %i= %i< %i+ %i- %i* %im %ir %it/ %iv %i^ %i& %i! %i?
      %i<< %i>> %i<<< %i>>>
      %eof-object %eof-object?
      %c= %c<
      %object-class %object-class-setter
      %raw-alloc %object-of %clone
      %prop-elt %prop-elt-setter %prop-dat-at
      %elt %elt-setter
      %slen %selt %selt-setter %%sfab %su %sb
      %rlen %relt %relt-setter %%rfab %ru
      %tlen %telt %telt-setter %%tfab %tu
      %fab-code-refs %code-ref
      %app-filename %app-args
      %loc-val %loc-val-setter %invoke-debugger
      %break %binding-name %fun-reg
      %trace-on %trace-off
      %%apply %%mep-apply %next-methods %fapply
      %do-stack-frames 
      %unexec
      %build-runtime-modules %process-module
      %loc-off %loc-off-setter %raw-call %raw-met-call %check-call-types
      %def-regs %set-regs %sp-reg %sp-reg-setter %sp-elt 
      %stack-reg %max-stack-len %stack-check-reg? %stack-check-reg?-setter
      %fp-reg %fp-reg-setter %unlink-stack
      %next-methods-reg-setter
      %new %@class-of %@subclass?
      %fab-dyn-var %dyn-var-val %dyn-var-val-setter
      %vsp %vsp-setter %vfp %vfp-setter 
      %vfn %vfn-setter %vnm %vnm-setter %vpc %vpc-setter
      %vm-box-fab %vm-box-val %vm-box-val-setter
      %vm-fun-env-fab %vm-fun-env-elt %vm-fun-env-elt-setter
      %vm-with-exit %vm-with-cleanup 
      )))

(%define-primitives)

;; (dss poo () (error "POO")) (poo) ;; TRIGGER A COMPILER BLOWOUT

;; (ct (dv cat-sym make-sym))

;; Early definitions, so we at least know false != true
(dv %false (%raw 0)) 
(dv %true  (%raw 1))

(dv %*used-symbols-too-early* (%raw 0))


;;;
;;; BOOT OBJECTS
;;;

;; ALL PROTO'S NEEDED FOR BOOT ARE DEFINED HERE
;; THEY ARE DEFINED AS THEY WOULD BE OUTSIDE BOOT

(ct (df %boot-defs ()
      '((dc <any>    (<any>))
        (dv nul      (new <any>))
        (dv nul-prop (new <any>))
        (dc <log>    (<any>))
        (dv %true    (new <log>))
        (dv %false   (new <log>))
        (dc <box>    (<any>))
          (dp! box-value (<box> => <any>))
        (dc <mag> (<any>))
        (dc <chr> (<mag>))
        ;; (dc <%chr> (<chr>))
        (dc <src-loc> (<mag>))
          (dp src-loc-line (<src-loc> => <int>))
          (dp src-loc-file (<src-loc> => <str>))
        (dc <num> (<mag>))
        (dc <int> (<num>))
        (dc <fixnum> (<int>))
        (dc <bignum> (<int>))
        ;; (dc <%int> (<fixnum>))
        (dc <flo> (<num>))
        ;; (dc <%flo> (<flo>))
        (dc <loc> (<any>))
        (dc <rep> (<any>))
        (dc <col> (<any>))
        (dc <col.> (<col>))
        (dc <col!> (<col>))
        (dc <seq> (<col>))
        (dc <seq.> (<seq> <col.>))
        (dc <seq!> (<seq> <col!>))
        (dc <lst> (<seq!>))
        (dv nil (new <lst>))
          (dp! head (<lst> => <any>) nil)
          (dp! tail (<lst> => <lst>) nil)
        (dc <flat> (<seq>))
        (dc <tup> (<flat> <seq.>))
        (dc <str> (<flat> <seq.> <mag>))
        (dc <sym> (<mag>))
          (dp sym-name (<sym> => <str>))
        (dc <type> (<any>))
        (dc <class> (<type>))
          (dp! class-prop-len (<class> => <fixnum>)     0)
          (dp class-name (<class> => <sym>))
          (dp! class-parents (<class> => <lst>)         nil)
          (dp! class-direct-props (<class> => <lst>)    nil)
          (dp! class-ancestors (<class> => <lst>)       nil)
          (dp! class-props (<class> => <lst>)           nil)
          (dp! class-children (<class> => <lst>)        nil)
          ;; ULTIMATELY NEED GENS TO BE FLUSHED DURING CLASS REDEF
          ;; KEEP BOTH GENS/METS CAUSE NO MET->GEN MAP
          ;; WANT TO PRUNE OUT UNNECESSARY GENS BASED ON ACTUAL METS
          (dp! class-gens (<class> => <lst>)            nil)
          (dp! class-mets (<class> => <lst>)            nil)
          (dp! class-forward (<class> => <any>)         #f)
          (dp class-id (<class> => <fixnum>)            -1)
          (dp class-row (<class> => <tup>)              nul)
        (dc <singleton> (<type>))
          (dp type-object (<singleton> => <any>))
        (dc <subclass> (<type>))
          (dp type-class (<subclass> => <class>))
        (dc <union> (<type>))
          (dp union-elts (<union> => <lst>)             nil)
        (dc <product> (<type>))
          (dp product-elts (<product> => <tup>))
        (dc <prop> (<any>))
          (dp prop-owner (<prop> => <any>))
          (dp prop-getter (<prop> => <fun>))
          (dp prop-setter (<prop> => <any>)) ;; (T? <FUN>)
          (dp prop-type (<prop> =>  <type>))
          (dp prop-init (<prop> =>  <fun>) (fun (x) nul-prop))
        (dc <gen-cache> (<any>))
          (dp gen-cache-missable? (<gen-cache> => <log>)  #f)
          (dp gen-cache-arg-pos (<gen-cache> => <fixnum>) 0)
          (dp gen-cache-singletons (<gen-cache> => <lst>) nil)
          (dp gen-cache-classes (<gen-cache> => <lst>)    nil)
        (dc <sig> (<any>))
          (dp! sig-specs (<sig> => <lst>) nil)
          (dp! sig-nary? (<sig> => <log>) %false)
          (dp! sig-arity (<sig> => <fixnum>) 0)
          (dp! sig-val   (<sig> => <any>) <any>)
          (dp! sig-unification-vars (<sig> => <lst>) nil)
        (dc <fun-info> (<any>))
          (dp! fun-info-name (<fun-info> => <any>)        %false)
          (dp! fun-info-names (<fun-info> => <lst>)       nil)
          (dp! fun-info-src-loc (<fun-info> => <any>)     %false)
          (dp! fun-info-src (<fun-info> => <any>)         %false)
          (dp! fun-info-count (<fun-info> => <int>)       0)
          (dp! fun-info-inlineable? (<fun-info> => <log>) %false)
        (dc <fun> (<any>))
          (dp fun-code  (<fun> => <any>)   %false)
          (dp! fun-sig  (<fun> => <sig>))
          (dp! fun-info (<fun> => <any>)   %false)
        (dc <met> (<fun>))
          (dp fun-env (<met> => <any>)     %false)
        (dc <gen> (<fun>))
          (dp! fun-mets (<gen> => <lst>)   nil)
          (dp fun-cache (<gen> => <any>)   %false)
    (dc <opts> (<flat> <seq.>))
      (dp opts-location (<opts> => <loc>) 0)
      (dp opts-count (<opts> => <fixnum>) 0)
    (dc <opts-tup> (<opts>))
      (dp opts-tup-storage (<opts-tup> => <tup>) nul)
)))

;; RETURN CLASS DEFS FROM BOOT DEFS

(ct (df %map-boot-classes (f)
      (rep loop ((res '()) (defs (%boot-defs)))
        (if (nul? defs)
            (rev! res)
            (loop (mif ((dc ,name (,@parents)) (head defs))
                       (pair (f name parents) res)
                       res)
                  (tail defs))))))

;; RETURN OBJECTS DEFS FROM BOOT DEFS

(ct (df %map-boot-objects (f)
      (rep loop ((res '()) (defs (%boot-defs)))
        (if (nul? defs)
            (rev! res)
            (loop (mif ((dv ,name (new ,class)) (head defs))
                       (pair (f name class) res)
                       res)
                  (tail defs))))))

;; RETURN PROP DEFS FROM BOOT DEFS

(ct (df %map-boot-props (f)
      (loc ((get-init (maybe-init)
              (if (nul? maybe-init) 'nul-prop (head maybe-init))))
        (rep loop ((res '()) (defs (%boot-defs)))
          (if (nul? defs)
              (rev! res)
              (loop (match (head defs)
                      ((dp ,name (,owner => ,type) ,@maybe-init)
                       (pair (f owner name #f type (get-init maybe-init)) res)) 
                      ((dp! ,name (,owner => ,type) ,@maybe-init)
                       (pair (f owner name #t type (get-init maybe-init)) res))
                      (#t res))
                    (tail defs)))))))

;;;
;;; 1. CONSTRUCTION MACHINERY FOR BUILDING EARLY OBJECTS
;;;

(dl %allocate-stack (num)
  (%def-regs)
  (def ret (%sp-reg))
  (set (%sp-reg) (%i+ (%sp-reg) (%i* (%raw 4) num)))
  ret)

;; STRUCTURES ARE OBJECT TEMPLATES WITH 
;;   PRIMITIVES FOR ACCESSORS AND 
;;   A PRIMITIVE REQUIRED ONLY CONSTRUCTOR

;; DEFINE ACCESSORS NAMED PROP-NAMES AT INCREASING OFFSETS

(dss %define-structure-accessors (,@prop-names)
  (loc ((getter (name offset) 
          `(dl (,(cat-sym "%" name) inline) (x)
             (%prop-elt x (%raw ,offset))))
        (setter (name offset)
          `(dl ,(cat-sym "%" name "-setter") (z x)
             (set (%prop-elt x (%raw ,offset)) z))))
    (rep loop ((res '()) (i 0) (names prop-names))
      (if (== names '())
          `(seq ,@(rev! res))
          (let ((name (head names)))
            (loop (pair (getter name i) (pair (setter name i) res))
                  (+ i 1) (tail names)))))))

;; DEFINE STRUCTURE BASE WITH PREFIX FOR CONSTRUCTOR NAME

(dss %define-structure (,prefix ,class-base-name ,@prop-names)
  (loc ((constructor (name inits)
          (def class-name (cat-sym "<" name ">"))
          `(dl ,(cat-sym prefix name) (,@prop-names) 
             (def class (%object-of ,class-name (%raw ,(len prop-names))))
             ,@inits
             class)))
    (rep loop ((inits '()) (i 0) (names prop-names))
      (if (== names '())
          `(seq (%define-structure-accessors ,@prop-names)
                ,(constructor class-base-name inits))
          (let ((name (head names)))
            (loop (pair `(set (%prop-elt class (%raw ,i)) ,name) inits)
                  (+ i 1) (tail names)))))))

;;;
;;; 2. SETUP EARLY CLASS
;;;

(%define-structure % class
 class-prop-len class-name 
 class-parents class-direct-props
 class-ancestors class-props class-children 
 class-gens class-mets class-forward
 class-id class-row)

(%define-structure % singleton type-object)
(%define-structure % subclass  type-class)
(%define-structure % union     union-elts)
(%define-structure % product   product-elts)

(dv <class> (%object-of (%raw 0) (%raw 10)))

;;;
;;; 3. SETUP EARLY OBJECTS
;;;

;;; PLACE HOLDERS FOR EARLY OBJECTS

(dv <lst>    (%object-of <class> (%raw 10))) ;; PLACE HOLDER
(dv nil      (%object-of <lst> (%raw 2)))    ;; AT LEAST GET SIZE RIGHT
(dv one-nil  nil)                            ;; REMEMBER ORIGINAL NIL

;;;
;;; 4. SETUP EARLY CLASSES
;;;

;;; BUILD CLASS SHELLS POINTING TO INCOMPLETE <CLASS>

(dss %class-shells ()
  `(seq
     ,@(%map-boot-classes
        (fun (name parents)
          `{ (dv ,name (%class nil nil nil nil nil nil nil nil nil nil -1 nil))
             (export ,name) }))))

(%class-shells)

;;; INITIALIZE CLASSES TO BE INSTANCES OF NOW REAL CLASS

(dss %reparent-class-shells ()
  `(seq ,@(%map-boot-classes
            (fun (name parents)
              `(set (%object-class ,name) <class>)))))

(%reparent-class-shells)

;;;
;;; 5. SETUP EARLY OBJECTS
;;;

;;; TODO: NEED SIZES TO BUILD OBJECTS CORRECTLY
;;; TODO: COULD DELAY UNTIL AFTER PROPS

(set (%object-class nil) <lst>)

;;; BUILD BASIC OBJECT HOLDERS

(dss %object-shells ()
  `(seq ,@(%map-boot-objects 
            (fun (name class)
              `(seq (dv ,name (%object-of ,class (%raw 0)))
                    ,(if (== name 'nul) #f `(export ,name)))))))

(%object-shells)

(dv %classes-ready? #f)

;;;
;;; 6. SETUP LIST BASICS
;;;

;;; LST BASICS

(%define-structure % lst head tail)

(dl %pair (head tail) (%lst head tail))

(dl (%nul? inline) (x) (%bb (%eq? x nil)))

(dl %%len (x) 
  (rep loop ((x x) (i (%raw 0)))
    (if (%nul? x) i (loop (%tail x) (%i+ i (%raw 1))))))

(dl %rev! (c)
  (rep loop ((l c) (r '()))
    (if (%nul? l)
        r
        (let ((t (%tail l)))
          (set (%tail l) r)
          (loop t l)))))

(dl %cat2 (x y) 
  (rep colx ((lx nil) (x x))
    (if (%nul? x)
        (rep coly ((lxy lx) (y y))
          (if (%nul? y)
              (%rev! lxy)
              (coly (%pair (%head y) lxy) (%tail y))))
        (colx (%pair (%head x) lx) (%tail x)))))


;;; INITIALIZE NIL

(set nil         one-nil)
(set (%head nil) nil)
(set (%tail nil) nil)

;;; MET BASICS

(%define-structure % sig 
   sig-specs sig-nary? sig-arity sig-val sig-unification-vars)

(%define-structure % src-loc src-loc-line src-loc-file)

(%define-structure % fun-info
   fun-info-name fun-info-names fun-info-src  fun-info-src-loc 
   fun-info-count fun-info-inlineable?)

(%define-structure % met met-code met-sig met-info met-env)

(dv %met-prop-len (%raw 4))

;; NOW FALSE AND TRUE HAVE THEIR PERMANENT VALUES.

(dv %symbols-ready?     #f)  ;; READY TO BUILD SYMBOLS?
(dv %*start-running-at* nil)

;;; 
;;; 8. TAGGED OBJECTS
;;; 

;; TAGGED OBJECTS ARE IMMEDIATE OBJECTS WHOSE TYPE AND DATA
;; ARE ENCODED IN ADDRESS
;; USES TWO TAG BITS WITH ADDRESSES HAVING TAG ZERO

(dv $direct-object-class (%raw-alloc (%raw 4)))

(dss $tag-msk () `(%raw 3))
(dss $tag-len () `(%raw 2))

(dl (%tag-bits inline) (x) (%i& x ($tag-msk)))

(dl (%tag inline) (x t) (%iv (%i<< x ($tag-len)) t))

(dl (%untag inline) (x) (%i>> x ($tag-len)))

(dss $adr-tag () `(%raw 0))

(dl %tag-into (x t) (%tag (%untag x) t))

(dl %untag-into (x) (%tag (%untag x) ($adr-tag)))

(dl %indirect-object? (x) (%i= (%tag-bits x) ($adr-tag)))

(dl (@adr? inline) (x)
  (%bb (%i= (%tag-bits x) ($adr-tag))))

(dl (%class-of inline) (x)
  (def tag (%tag-bits x))
  (if (%bb (%i= tag ($adr-tag)))
      (%object-class x)
      (%elt $direct-object-class tag)))

;; DEFINE EARLY TAGGED CLASS 
;;   WHERE CODE IS ABBREVIATION PREFIX FOR OPS
;;   DEFINES TAG/FAB AND UNTAG OPS
;;   DEFINES TAG2CLASS ENTRY FOR MAP

(dss %define-tagged-structure (,name ,ptag ,puntag ,code ,tag)
  (let ((class-name (cat-sym "<" name ">"))
        (fab-name   (cat-sym "%" name))
        (tag-name   (cat-sym "%" code "b"))
        (untag-name (cat-sym "%" code "u")))
    `(seq (dl (,tag-name inline) (x => ,class-name) (,ptag x (%raw ,tag)))
          (dl (,fab-name inline) (x => ,class-name) (,tag-name x))
          (dl (,untag-name inline) (x) (,puntag x))
          (set (%elt $direct-object-class (%raw ,tag)) ,class-name))))

(%define-tagged-structure fixnum %tag %untag        i 1) ;; INTEGERS
(dl (@int? inline) (x)
  (%bb (%i= (%tag-bits x) (%raw 1))))

(%define-tagged-structure chr %tag %untag           c 2) ;; CHARACTERS

(%define-tagged-structure loc %tag-into %untag-into l 3) ;; LOCATIVES

(dv $num-int-bits (%ib (%i- (%iu 32) ($tag-len))))
(dv $max-int 
  (%ib (%i- (%i<< (%iu 1) (%i- (%iu $num-int-bits) (%iu 1))) (%iu 1))))
(dv $min-int
  (%ib (%i<< (%iu 1) (%i- (%iu $num-int-bits) (%iu 1)))))

;;; 
;;;  9. SETUP REPEATED OBJECTS
;;; 

;; DEF STRUCT'S WITH INDEXED ELEMENTS W/ DATA STORED IN DATA PROP
;;   DEFINING CONSTRUCTORS,ACCESSORS,LEN,BOX/UNBOX'ERS(FOR FFI),

(dss %define-repeated-structure (,name ,elt ,code ,init)
  (let ((class-name (cat-sym "<"  name ">"))
        (nul        (cat-sym "%"  code "nul"))
        (fab        (cat-sym "%"  name))
        (fab!       (cat-sym "%"  name "!"))
        (raw-fab    (cat-sym "%%" code "fab")))
    `(seq (dl ,fab! (len e => ,class-name) (,raw-fab len e))
          (dv (,nul ,class-name) (,fab! (%raw 0) ,init))
          (dl ,fab (len e => ,class-name) 
            (if (%bb (%i= len (%raw 0))) ,nul (,fab! len e))))))

(%define-repeated-structure str <chr> s (%cu #\Space))

(%define-repeated-structure tup <any> t nul) 

(%define-repeated-structure rep <any> r nul) 

(dl %str-eq? (s1 s2)
  (def len (%slen s1))
  (and (%bb (%i= len (%slen s2)))
       (rep loop ((i (%raw 0)))
         (or (%bb (%i= i len))
             (let ((c1 (%selt s1 i)) (c2 (%selt s2 i)))
               (and (%bb (%c= c1 c2))
                    (loop (%i+ i (%raw 1)))))))))

;;;
;;; 7. SETUP HIERARCHY
;;;

;; COMPUTE ALL PARENTS FROM DIRECT PARENTS ASSUMING SIMPLE INHERITANCE

(dl %compute-ancestors (parent)
  (rep loop ((res '()) (parent parent))
    (if (%bb (%eq? parent <any>))
        (%rev! (%pair <any> res))
        (loop (%pair parent res) (%head (%class-parents parent))))))

;; DEFINE CHILD / PARENT RELATIONSHIP

(dv *early-classes* nil)

(dl %define-parents (class parents)
  (set *early-classes* (%pair class *early-classes*))
  (set (%class-prop-len class)     0)    ;; NOW INT'S ARE DEFINED
  (set (%class-forward class)      #f)   ;; NOW #F    IS  DEFINED
  (set (%class-parents class)      parents)
  (set (%class-ancestors class)
       (%pair class (%compute-ancestors (%head parents))))
  (set (%class-children (%head parents))
       (%pair class (%class-children (%head parents)))))

;; DEFINES SINGLE INHERITANCE HIERARCHY FROM TOP TO BOTTOM

(dss %pairize (,@elts)
  (rep pairize ((elts elts))
    (if (nul? elts)
        '()
        `(%pair ,(head elts) ,(pairize (tail elts))))))

(dss %define-hierarchy ()
  `(seq ,@(%map-boot-classes
            (fun (name parents) 
              `(%define-parents ,name (%pairize ,@parents))))))

(%define-hierarchy)

;; PATCH <ANY>'S PARENTS

(set (%class-ancestors <any>) (%pair <any> nil))

;;;
;;; 10. SETUP SYMBOLS
;;;

;; Get symbol fab up ASAP so we don't have to patch the names of
;; a bunch of objects.

(dl %%sym (raw-str)      ;; Called in code generated by compiler
  (if %symbols-ready?
     (fab-sym (%sb raw-str))
     (set %*used-symbols-too-early* #t)
     #f))

(%define-structure % sym sym-nam)

(dv %symbols nil)

;; EARLY VERSION (PRE TAB) OF SYM CONSING USING LST SET
(if (%bb (%eq? %*used-symbols-too-early* #t))
    (%break (%su "Warning: symbols were created in the boot image before the symbol-creation was setup. (Probably from a df or rep)\n")))


;; this first version doesn't have proper symbols, but it works..
(dl %fab-sym (name)
  (rep lookup ((s %symbols))
    (if (%nul? s)
        (let ((sym (%sym name)))
          (set %symbols (%pair sym %symbols))
          sym)
        (let ((sym (%head s)))
          (if (%str-eq? (%sym-nam sym) name)
              sym
              (lookup (%tail s)))))))

(dv fab-sym (fun (name) (%fab-sym name)))

(set %symbols-ready? #t) ;; READY TO CONS SYMBOLS

;; do the same thing, this time the symbols will be filled in
(df fab-sym (name) (%fab-sym name))

;; NEED THIS TO BUILD METS -- COMPUTED FOR REAL BELOW

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; !!! Below here we can use functions !!! ;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; 
;;; 11. BOXED OBJECTS
;;; 

(dss %define-boxed-structure (,name ,code)
  (let ((class-name (cat-sym "<" name ">"))
        (dat-name   (cat-sym name "-dat"))
        (fab-name   (cat-sym "%" name))
        (box-name   (cat-sym "%" code "b"))
        (unbox-name (cat-sym "%" code "u")))
    `(seq (%define-structure % ,name ,dat-name)
          (dl ,box-name (x => ,class-name) (,fab-name x))
          (dl ,unbox-name (x) (%prop-elt x (%raw 0)))
          )))

(%define-boxed-structure flo f)

;; (%define-boxed-structure chr c)

;; (%define-boxed-structure int i)

;; (%define-boxed-structure loc l)

;;; 5.5. Make optional arg stuff
(%define-structure % opts opts-location opts-count)
(%define-structure % opts-tup opts-tup-location opts-tup-count opts-tup-tup)

;;;
;;; 12. MAKE PROPS AND ACCESSORS
;;; 

;; DEF PROP'S

(%define-structure %% prop
  prop-owner prop-getter prop-setter prop-type prop-init)

;; GENERIC DISPATCH CACHES 
;;   USED IN HIERARCHY DECISION TREE
;;   MAP KEYS TO SUBTREES WHERE KEYS ARE EITHER OBJECTS OR CLASS
;;   AND SUBTREES ARE EITHER OTHER CACHES OR METHODS OR PROP OFFSETS

(%define-structure % gen-cache 
   gen-cache-missable? gen-cache-arg-pos gen-cache-singletons gen-cache-classes
   gen-cache-count)

(dv $gen-cache-singletons-offset 2) ;; TODO: USED IN CACHE UPDATE
(dv $gen-cache-classes-offset    3)

;;; DEF GENERIC'S
 
(%define-structure % gen gen-code gen-sig gen-info gen-mets fun-cache)

(df %prop-offset (owner getter)
  (rep loop ((i (%raw 0)) (props (%class-props (%object-class owner))))
    (if (%nul? props)
        (%iu -1)
        (let ((prop (%head props)))
          (if (%bb (%eq? (%prop-getter prop) getter))
              i
              (loop (%i+ i (%raw 1)) (%tail props)))))))

;; &LISTIFY CONSTRUCTS CODE THAT BUILDS A LIST OF GIVEN ARGS WITH CALLS TO %PAIR

(ct (df &listify (args)
      (if (nul? args)
          'nil
          `(%pair ,(head args) ,(&listify (tail args))))))

;; EARLY DISPATCH ERRORS OUT

(df %early-dispatch (args|...)
  (def gen (%fun-reg))
  (%break (%su "ERROR: Generic function dispatch called before it existed.")))

(df %add-met (gen met)
  (set (%gen-mets gen) (%pair met (%gen-mets gen))))

;; DEFINE EARLY GENERIC METHOD FOR ACCESSORS

(dl %fab-sig (specs nary? arity val unis)
  (%sig specs nary? arity val unis))

(dl %fab-gen/code (code sig name names src-loc)
  (let ((info (%fun-info name names src-loc #f 0 #f)))
    (%gen (%gen-code code) sig info '() #f)))

(dl %fab-gen (sig name names src-loc)
  (%fab-gen/code %dispatch sig name names src-loc))

(dl %fab-met-inlineable (code sig name names src-loc src)
  (%met code sig (%fun-info name names src-loc src 0 #t) #f))

(dl %fab-met (code sig name names src-loc src)
  (%met code sig (%fun-info name names src-loc src 0 #f) #f))

(ct (df &params (sig)
      (if (or (nul? sig) (== (head sig) '=>))
          '()
          (pair (head sig) (&params (tail sig))))))

(dss %define-accessor (,name (,@sig) ,@body)
  (let ((params  (&params sig))
        (specs   (&listify (map (always '<any>) params))))
    `(seq (dv ,name 
            (%fab-gen/code
             %early-dispatch (%sig ,specs #f ,(len params) <any> '())
             ',name '() #f))
          (export ,name)
          (let ((accessor (fun (,@sig) ,@body)))
            (%add-met ,name accessor)
            (set (%fun-info-name (%met-info accessor))        ',name)
            (set (%fun-info-inlineable? (%met-info accessor)) #t)
            accessor))))

(dss %define-getter (,name ,owner ,type)
  `(%define-accessor ,name ((x ,owner) => ,type)
      (%prop-elt x (%prop-offset ,owner ,name))))

(dss %define-setter (,name ,owner ,type)
  `(%define-accessor ,(cat-sym name "-setter") ((z ,type) (x ,owner))
     (set (%prop-elt x (%prop-offset ,owner ,name)) z)))

;; EARLY ADD-PROP JUST ADDS PROP TO DIRECT-PROPS

(df %add-prop (class prop)
  (set (%class-direct-props class)
       (%pair prop (%class-direct-props class))))

;; DEF GETTER/SETTER/PROPS FOR ALL BOOT CLASS PROPS
;; N.B. PROP METHODS CLOSE OVER PROP

(dss %define-props ()
  `(seq ,@(%map-boot-props 
            (fun (owner name setter? type init) 
              (def setter-name (and setter? (cat-sym name "-setter")))
              `(let ((getter 
                      (%define-getter ,name ,owner ,type))
                     ;; TODO: X FROM OWNER VAR
                     (setter 
                      ,(and setter? `(%define-setter ,name ,owner ,type)))
                     (prop
                      (%%prop ,owner ,name  ,setter-name ,type {x\,init})))
                 (set (%met-env getter) prop)
                 ,(when setter? `(set (%met-env setter) prop))
                 (%add-prop ,owner prop))))))

(%define-props)

;;;
;;; 7. FINALIZE PROPS
;;;

;; NEED TO SET ALL PROPS CLASS PROP

(df %collect-direct-props (class)
  (def parent (%head (%class-parents class)))
  (%cat2 (%class-props parent) (%class-direct-props class)))

(df %finalize-props! (name class)
  (set (%class-name class)         name)
  (set (%class-direct-props class) (%rev! (%class-direct-props class)))
  (set (%class-props class)        (%collect-direct-props class))
  (set (%class-prop-len class)     (%ib (%%len (%class-props class))))
  class)

(dss %finalize-props ()
  `(seq ,@(%map-boot-classes
           (fun (name parent) `(%finalize-props! ',name ,name)))))

(%finalize-props)

;;;
;;; 11. FUNCTION PREP
;;; 

;; NEED TO DEF A SLEW OF MONOVARIANT FUN'S 
;;   PRE GENERICS AND IN ORDER TO AVOID CIRCULARITIES
;;   USE PRIMITIVES FOR SPEED FOR NOW

(dl (@head inline) (x|<lst> => <any>) (%head x))

(dl @head-setter (z x|<lst>) (set (%head x) z))

(dl (@tail inline) (x|<lst> => <lst>) (%tail x))

(dl @tail-setter (z|<lst> x|<lst>) (set (%tail x) z))

(dl (@= inline) (x|<fixnum> y|<fixnum> => <log>)
;; optimization based on knowing the tag bits for two ints are always the same
  (%bb (%i= x y)))
;;  (%bb (%i= (%iu x) (%iu y))))

(dl (@< inline) (x|<fixnum> y|<fixnum> => <log>)
  (%bb (%i< (%iu x) (%iu y))))

(dl (@+ inline) (x|<fixnum> y|<fixnum> => <fixnum>)
  (%ib (%i+ (%iu x) (%iu y))))

(dl (@== inline) (x|<any> y|<any> => <log>) (%bb (%eq? x y)))

(df @@== (x|<any> y|<any> => <log>) (%bb (%eq? x y)))

(df (not inline) (x|<any> => <log>) (%bb (%eq? x #f)))

(dl (@not inline) (x|<any> => <log>) (%bb (%eq? x #f)))

(dl (@nul? inline) (x|<lst> => <log>) (%nul? x))

(df @@nul? (x|<lst> => <log>) (%nul? x))

(df @rev! (x|<lst> => <lst>) (%rev! x))

(dl @len (x|<lst> => <fixnum>) (%ib (%%len x)))

(dl (@oelt inline) (x|<opts> i|<fixnum>)
  (%loc-off (%opts-location x) (%i- (%raw 0) (%iu i))))
(dl (@oelt-setter inline) (z x|<opts> i|<fixnum>) 
  (set (%loc-off (%opts-location x) (%i- (%raw 0) (%iu i))) z))
(dl (@olen inline) ((x <opts>) => <fixnum>) (%opts-count x))

(df @all? (test|<fun> c|<lst> => <log>)
  (rep fnd ((p c))
    (if (@nul? p) #t (if (test (@head p)) (fnd (@tail p)) #f))))

(df @all2? (test|<fun> x|<lst> y|<lst> => <log>)
  (rep fnd ((px x) (py y))
    (if (@nul? px) 
        (@nul? py)
        (if (@nul? py)
            #f
            (if (test (@head px) (@head py)) 
                (fnd (@tail px) (@tail py))
                #f)))))

(df @elt (x|<lst> key|<fixnum> => <any>)
  (rep fnd ((count|<fixnum> 0) (x|<lst> x))
    (if (@== x '())
        nul
        (if (@= count key) (@head x) (fnd (@+ count 1) (@tail x))))))

(df @fill (x|<lst> f|<fun> => <lst>)
  (rep loop ((p x))
    (if (@nul? p) x (seq (set (@head p) f) (loop (@tail p))))))

(df @any? (test|<fun> c|<lst> => <any>) ;; TODO: => <log>
  (rep fnd ((p c))
    (if (@nul? p) #f (or (test (@head p)) (fnd (@tail p))))))

(dl @pair (h|<any> t|<lst> => <lst>) (%pair h t))
(df fab-pair (h|<any> t|<lst> => <lst>) (%pair h t))

(dl @add (c|<lst> e|<any> => <lst>) (@pair e c))

(dl @add-new (c|<lst> e|<any> => <lst>) 
  (if (@mem? c e) c (@pair e c)))

(df @map (f|<fun> x|<lst> => <lst>)
  (rep do ((x x) (res '()))
    (if (@nul? x)
        (@rev! res)
        (do (@tail x) (@pair (f (@head x)) res)))))

(df @pick (f|<fun> x|<lst> => <lst>)
  (rep do ((x x) (res '()))
    (if (@nul? x)
        (@rev! res)
        (let ((h (@head x))) (do (@tail x) (if (f h) (@pair h res) res))))))

(df @do (f|<fun> x|<lst>)
  (rep do ((x x))
    (if (@nul? x)
        #f
        (seq (f (@head x)) (do (@tail x))))))

(df @alter (dst|<lst> src|<lst> => <lst>)
  (rep in ((ds dst) (ss src))
    (if (or (@nul? ds) (@nul? ss))
        dst
        (seq (set (@head ds) (@head ss))
             (in (@tail ds) (@tail ss))))))

(df @fab (x|<lst> s|<fixnum> => <lst>)
  (rep fab (((i <fixnum>) s) ((res <lst>) '()))
    (if (@< i 0) res (fab (@+ i -1) (@pair nul res)))))

(df @fold (combine|<fun> init|<any> c|<lst> => <lst>)
  (rep red ((res init) (c c))
    (if (@nul? c)
        res
        (red (combine res (@head c)) (@tail c)))))

(df @rev ((x <lst>) => <lst>)
  (rep loop ((l x) (r '()))
    (if (@nul? l)
        r
        (loop (@tail l) (@pair (@head l) r)))))

(df @cat2 (x|<lst> y|<lst> => <lst>)
  (%cat2 x y))

(df @find (f|<fun> c|<lst> => <any>) ;; TODO: => <fixnum>
  (rep fnd ((c c) (i 0))
    (if (@nul? c)
        nul
        (if (f (@head c))
            i
            (fnd (@tail c) (@+ i 1))))))

(df @mem? (c|<lst> x|<any> => <log>)
  (not (@== (@find (fun (y) (@== x y)) c) nul)))

;; added rev! since it was returning the list backwards. TODO: make it more
;; efficient.
(df @del-dups (x|<lst> => <lst>)
  (@rev! (@fold (fun (s e) (if (@mem? s e) s (@pair e s))) '() x)))

(df @opts-as-lst (x|<opts> => <lst>)
  (rep loop ((i (@+ (@olen x) -1)) (l '()))
    (if (@== i -1) l (loop (@+ i -1) (@pair (@oelt x i) l)))))

(df @lst (x|...)
  (rep loop ((i (@+ (@olen x) -1)) (l '()))
    (if (@== i -1) l (loop (@+ i -1) (@pair (@oelt x i) l)))))

(dl (@tlen inline) (x|<tup> => <fixnum>)
  (%ib (%tlen x)))

(dl (@telt inline) (x|<tup> i|<fixnum> => <any>)
  (%telt x (%iu i)))

(dl (@telt-setter inline) (z x|<tup> i|<fixnum>)
  (set (%telt x (%iu i)) z))

(df @tany? (test|<fun> c|<tup> => <log>)
  (rep fnd ((i (@+ (@tlen c) -1)))
    (if (@< i 0) #f (or (test (@telt c i)) (fnd (@+ i -1))))))

(df @tall2? (test|<fun> c1|<tup> c2|<tup> => <log>)
  (and (@== (@tlen c1) (@tlen c2))
       (rep fnd ((i (@+ (@tlen c1) -1)))
         (or (@< i 0) (and (test (@telt c1 i) (@telt c2 i)) (fnd (@+ i -1)))))))

(dl (%to-tup inline) (args|<opts>)
  (def l (@olen args))
  (def t (%tup (%iu l) nul))
  (if (@= l 2) ;; MOST FREQUENT CASE AND SPEED CRITICAL
      (seq (set (@telt t 0) (@oelt args 0))
           (set (@telt t 1) (@oelt args 1)))
      (rep into ((k (@+ l -1)))
        (unless (@= k -1)
          (set (@telt t k) (@oelt args k))
          (into (@+ k -1)))))
  t)

(df @tup (args|...) (%to-tup args))

(dv tup @tup)

(df t* (args|...) (%product (%to-tup args)))

;; TODO: DEF SUBTYPE METHODS

(df @type-equal? (t1 t2 => <log>)
  (or (@== t1 t2)
      (and (not (@== (%class-of t1) <class>)) (not (@== (%class-of t2) <class>))
           (@subtype? t1 t2) (@subtype? t2 t1))))

(dl (@subclass? inline) (c1 c2 => <log>)
  (%bb (%i= (%selt (%class-row c1) (%iu (%class-id c2))) (%iu 1)))
  ;; (or (@== c2 <any>) (@== c1 c2)
  ;;     (@class-in? c2 (%class-ancestors c1)))
  )

(dl (@class-isa? inline) (o c => <log>)
  (@subclass? (%class-of o) c))

(df @subtype? (t1 t2 => <log>)
  (if (and (@== (%class-of t2) <class>) (@== (%class-of t1) <class>))
      (@subclass? t1 t2)
      (subtype? t1 t2)))
  
(df @may-isa? (c|<class> t|<type> => (tup some?|<log> all?|<log>))
  (if (@== (%class-of t) <class>)
      (if (@subclass? c t) (@tup #t #t) (@tup #f #f))
      (may-isa? c t)))

;; (dl @class-in? (c cs => <log>)
;;   (or (@== (%head cs) c) ; at least one ancestor
;;       (let ((next-cs (%tail cs)))
;;         (if (%nul? next-cs)
;;             #f
;;             (@class-in? c next-cs)))))

(dl @singleton-isa? (o t => <log>)
  ;; TODO: FIX UP TO DO PROPER ==
  (@== (%type-object t) o))

(dl (@isa? inline) (o t => <log>)
  (if (@== (%class-of t) <class>)
      (@class-isa? o t)
      (isa? o t)))

(dv *restarts-ok?* #f)

(df unexec (name|<str> fun|<fun>)
  (set %*start-running-at* fun)
  (%unexec (%su name)))

(df %patch-early-generic (generic|<gen>)
  (set (%gen-code generic) (%met-code %dispatch)))

(dss %def-patch-early-generics ()
  `(dl %patch-early-generics ()
     ,@(%map-boot-props 
        (fun (owner name setter? type init) 
          `(seq 
             (%patch-early-generic ,name)
             ,(when setter? 
               `(%patch-early-generic ,(cat-sym name "-setter"))))))))

(%def-patch-early-generics)

;;; LOW-LEVEL FUNCTION CALLING SUPPORT AND TYPE CHECKS

(set (%class-prop-len <met>) (%ib %met-prop-len)) 

(dl (@raw-nul? inline) (x) (@== x (%raw 0)))

(dl %cons-args ()
  (%def-regs)
  (def n (%sp-elt (%raw -2)))
  (def b (%i- (%raw -2) n))
  (rep loop ((r '()) (i (%raw 0)))
    (if (%bb (%i< i n))
        (loop (%pair (%sp-elt (%i+ b i)) r) (%i+ i (%raw 1)))
        r)))

(dl (%check-arity inline-c) (fn sig n)
  (def arity (%iu (%sig-arity sig)))
  (def nary? (%sig-nary? sig))
  (if nary?
      (when (%bb (%i< n arity))
        (narity-error fn (%cons-args)))
      (if (%bb (%i= n arity))
          #t
          (arity-error fn (%cons-args)))))

(dl (%arg-check-type inline-c) (res type fn)
  (if (@== type <any>)
      #t
      (if (@isa? res type)
          res
          (argument-type-error fn res type (%cons-args)))))

(dl %fun-val-check-type (regs res fn)
  (%set-regs regs)
  (def type (%sig-val (%met-sig fn)))
  (if %classes-ready?
      (if (@isa? res type)
          res
          (return-type-error fn res type (%cons-args)))))

(dl %check-type (regs res type)
  (%set-regs regs)
  (if %classes-ready?
      (if (@isa? res type)
          res
          (type-error res type))))

(dss %stack-overflow-lim ()
  `(%i- (%max-stack-len) (%raw 1000)))

(dl (%stack-check inline-c) (regs)
  (%set-regs regs)
  (if (%bb (%i< (%stack-overflow-lim) (%i- (%sp-reg) (%stack-reg))))
      (when (%bb (%stack-check-reg?))
        (set (%stack-check-reg?) (%raw 0))
        (stack-overflow-error))
      (if (%bb (%stack-check-reg?))
          #f
          (set (%stack-check-reg?) (%raw 1)))))

(dl %%check-call-types (regs)
  (%set-regs regs)
  (def fn
    (%sp-elt (%raw -1)))
  (def class
    (if (@raw-nul? fn) (%raw 0) (if (@adr? fn) (%class-of fn) (%raw 0))))
  (def n
    (%sp-elt (%raw -2)))
  (%stack-check regs)
  (if (@== class <met>)
      (let ((sig (%met-sig fn)))
        (%check-arity fn sig n)
        (when %classes-ready? 
          (rep loop ((i (%raw 0)) (specs (%sig-specs sig)))
            (if (@== specs '())
                #f
                {(%arg-check-type (%sp-elt (%i- (%raw -3) i)) (%head specs) fn)
                 (loop (%i+ i (%raw 1)) (%tail specs))}))))
      (if (@== class <gen>)
          (%check-arity fn (%gen-sig fn) n)
          (if (@== unknown-function-error (%raw 0))
              (%break (%su "Tried to call an unbound function, but the function error\nhandler is itself unbound. Exiting."))
              (unknown-function-error (if (@raw-nul? fn) #f fn) (%cons-args)))))
  #f)

;;;
;;; 14. MACROS
;;;

(dv *boot-macro-module-names* '())
(dv *boot-macro-names*        '())
(dv *boot-macro-expanders*    '())
(dv *macros-ok?*              #f)  ;; ENOUGH OF WORLD BOOTED TO DEFINE MACROS?

(dl %macro (modname name expander)
  (if *macros-ok?*
      (%%macro modname name expander #f) ;; DEFINED IN AST
      (seq ;; REMEMBER NAMES/EXPANDERS FOR LATER INSTALLATION
        (set *boot-macro-module-names*
             (@pair modname *boot-macro-module-names*))
        (set *boot-macro-names*     (@pair name     *boot-macro-names*))
        (set *boot-macro-expanders* (@pair expander *boot-macro-expanders*))))
  #f)

;;;
;;; 14. APPLICATION
;;;

(df app-filename () (%app-filename))

(df app-args () (%app-args))

(export app-filename app-args)

;;;
;;; xx. COMPILER SUPPORT
;;;

(dl %lit (n) (@lit (%ib n)))

;;;
;;; 15. EXPORTS
;;;

;; Some functions are called directly from prt.c.  For now, we generate
;; artificial free bindings for these symbols in the boot module--and
;; export them--so that other modules will define them under the
;; correct C names.  Please feel free to redesign this if you wish.
;; TODO - It might be worth dumping (mangle-runtime-name ...) in
;; g2c and using this mechanism instead.
(dss force-names-into-boot-module (,@names)
  (if (nul? names)
      #f
      `(seq (if #f ,(head names))
            (export ,(head names))
            (force-names-into-boot-module ,@(tail names)))))

(force-names-into-boot-module
  @lit
  %dispatch
  %with-monitor
  tup
  subtype?
  isa?
  may-isa?
  order-specs
  update-instance-for-changed-class
  @new
  new
  prop-offset
  props-of
  %prop-unbound-error
  %%macro
  lst
  error
  property-unbound-error
  property-not-found-error
  property-type-error
  cpl-error
  unknown-function-error
  stack-overflow-error
  file-opening-error
  type-error
  argument-type-error
  return-type-error
  internal-error
  arity-error narity-error
  ambiguous-method-error
  no-applicable-methods-error
  syntax-error
  range-error
  keyboard-interrupt
  file-opening-error
  no-next-methods-error
  assert-error
  as-error
  arithmetic-error
)

;; Forward references.
;; TODO - These would normally be defined using need-implementation, but we
;; haven't defined that yet.
(export
  error
  )

;; Compiler magic.
(export
  c-ment
  c-expr
  use
  use/export
  use/mangle
  use/library
  use/include
  export
  mif
  macro-expand
  quasiquote
  dl
  ct
  ct-also
  try
  fin
  esc
  rep
  loc
  let
  def
  bound?
  fun
  df
  dg
  dm
  dss
  ds
  dv
  d. 
  dc
  dp
  dp!
  set
  quote
  %raw
  seq
  if
  ddv
  )

;; Primitives used in other modules.
(export
  %app-args
  %app-filename
  %bb
  %bu
  %binding-name
  %build-runtime-modules %process-module
  %c<
  %c=
  %do-stack-frames
  %eof-object %eof-object?
  %eq?
  %i!
  %i&
  %i*
  %i+
  %i-
  %i<
  %i<<
  %i<<<
  %i=
  %i>>
  %i>>>
  %i?
  %i^
  %im
  %invoke-debugger
  %it/
  %iv
  %loc-val
  %loc-val-setter
  %next-methods
  %pair 
  %%sym
  %check-call-types
  ;;; FOR DECISION TREE CODE
  %gen-code %gen-code-setter 
  ;;; FOR OPTIMIZE
  %met-code %met-code-setter 
  %fun-reg
  %unlink-stack
  %src-loc
  %fab-met %fab-met-inlineable
  %met %met-env-setter
  %vsp %vsp-setter %vfp %vfp-setter %vpc %vpc-setter 
  %vfn %vfn-setter %vnm %vnm-setter 
  %vm-box-fab %vm-box-val %vm-box-val-setter
  %vm-fun-env-fab %vm-fun-env-elt %vm-fun-env-elt-setter
  %vm-with-exit %vm-with-cleanup 
  %allocate-stack
)

(export
  $max-int
  $min-int
  t*
  fab-sym
  not

  %symbols
  unexec
)

;; Regular exports.
(export
  ;; tagged structures
  %cb
  %cu
  %fb
  %fu
  %ib
  %iu
  %lb
  %lu
  %untag

  ;; repeated structures
  %sb
  %selt
  %selt-setter
  %slen
  %snul
  %str
  %su
  %tup %to-tup
  %telt
  %telt-setter
  %tlen
  %tnul
  %rep
  %relt
  %relt-setter
  %rlen
  %rnul


  %raw-call %raw-met-call
  %loc-off %loc-off-setter
  %sp-reg-setter %sp-reg %next-methods-reg-setter
  %class-of @subclass?
  %@class-of %@subclass?
  %fab-dyn-var %dyn-var-val %dyn-var-val-setter
  %patch-early-generics
  %class-id-setter
  %class-props
  %class
  %classes-ready?
  %class-gens
  %class-forward-setter
  %class-ancestors-setter
  %class-props-setter
  %class-id
  %class-prop-len-setter
  %fun-cache-setter
  %prop-type
  %class-direct-props-setter
  %class-direct-props
  %class-row-setter
  %class-children-setter
  %class-children
  %class-prop-len
  %prop-getter
  %clone
  %object-of
  %class-parents
  %class-forward
  %class-ancestors
  %sig-nary?
  %sig-arity
  %set-regs
  %def-regs
  %gen-cache
  %met-env
  %sig-unification-vars
  %class-prop-len-setter
  %fun-cache-setter
  %stack-check-reg?
  %gen-cache-singletons
  %prop-dat-at
  %type-object
  %gen-mets-setter
  %class-mets-setter
  %gen-cache-arg-pos-setter
  %union-elts
  %class-mets
  %tail
  %sig-val
  %met-sig
  %met-info
  %gen-info
  %gen-mets
  %sig-specs
  %singleton
  %prop-elt
  %gen-cache-singletons-setter
  %stack-check-reg?-setter
  %gen-cache-arg-pos
  %prop-init
  %met-prop-len
  %gen-sig
  %gen-cache-classes-setter
  %stack-reg
  %prop-getter
  %gen-cache-classes
  %max-stack-len
  %gen-cache-missable?
  %fun-info-names       %fun-info-names-setter
  %fun-info-name        %fun-info-name-setter
  %fun-info-src         %fun-info-src-setter
  %fun-info-src-loc     %fun-info-src-loc-setter
  %fun-info-count       %fun-info-count-setter
  %fun-info-inlineable? %fun-info-inlineable?-setter
  %class-forward
  %object-class
  %fun-cache
  %class-ancestors
  %opts-tup
  %type-class
  %product-elts
  %sp-elt
  %head
  %prop-elt-setter
  %class-gens-setter
  %break
  %fun-val-check-type
  %%check-call-types
  %macro
)

(export
  @isa?
  @lst
  @len
  @all2?
  @oelt
  @any?
  @olen
  @telt @tlen
  @+
  @<
  @==
  @not ;; hygiene
  $direct-object-class ;; hygiene/inlining
  @opts-as-lst ;; booting
  @map
  @cat2
  @rev
  @add-new
  @type-equal?
  @=
  @pair 
  fab-pair ;; hygiene construction
  @tail
  @head
  @fold
  @add
  @all?
  @all2?
  @del-dups
  *early-classes*
  @rev!
  @do
  @nul?
  @@nul?
  @mem?
  @subtype?
  @singleton-isa?
  @tany?
  @class-isa?
  @@==
  @adr?
  @int?
  @telt-setter
  @oelt-setter
  @tup
  @tail-setter
  @tall2?
  @may-isa?
  @elt
  @pick
)

(export
  *restarts-ok?*
  *macros-ok?*
  *boot-macro-expanders*
  *boot-macro-names*    
  *boot-macro-module-names*
)

