#lang racket/base
(require "simulator-structs.rkt"
         "compile.rkt"
         racket/math
         (for-syntax racket/base))

(provide lookup-primitive)


(define-syntax (make-lookup stx)
  (syntax-case stx ()
    [(_ #:functions (name ...)
        #:constants (cname ...))
     (with-syntax ([(prim-name ...) (generate-temporaries #'(name ...))]
                   [((name exported-name) ...)
                    (map (lambda (name)
                           (syntax-case name ()
                             [(real-name exported-name)
                              (list #'real-name #'exported-name)]
                             [_ 
                              (identifier? name)
                              (list name name)]))
                         (syntax->list #'(name ...)))])
       (syntax/loc stx
         (let ([prim-name (make-primitive-proc 
                           (lambda (machine return-label . args)
                             (apply name args)))]
               ...)
           (lambda (n)
             (cond
               [(eq? n 'exported-name)
                prim-name]
               ...
               [(eq? n 'cname)
                cname]
               ...
               [else
                (make-undefined)]
               )))))]))

(define call/cc
  (make-closure call/cc-label
                1
                '()
                'call/cc))
(define call-with-current-continuation call/cc)

(define e (exp 1))

(define my-cons (lambda (x y)
                  (make-MutablePair x y)))

(define my-list (lambda args
                   (let loop ([args args])
                     (cond
                       [(null? args)
                        null]
                       [else
                        (make-MutablePair (car args)
                                          (loop (cdr args)))]))))
(define my-car (lambda (x)
                  (MutablePair-h x)))

(define my-cdr (lambda (x)
                  (MutablePair-t x)))

(define my-pair? (lambda (x)
                   (MutablePair? x)))

(define my-box (lambda (x)
                 (vector x)))

(define my-unbox (lambda (x)
                   (vector-ref x 0)))

(define my-set-box! (lambda (x v)
                   (vector-set! x 0 v)))

(define my-vector->list (lambda (v)
                          (apply my-list (vector->list v))))

(define my-list->vector (lambda (l)
                          (apply vector
                          (let loop ([l l])
                            (cond
                              [(null? l)
                               null]
                              [else
                               (cons (MutablePair-h l)
                                     (loop (MutablePair-t l)))])))))
                                

(define my-set-car! (lambda (p v)
                      (set-MutablePair-h! p v)))

(define my-set-cdr! (lambda (p v)
                      (set-MutablePair-t! p v)))


(define lookup-primitive (make-lookup #:functions (+ - * / = < <= > >= 
                                                     sub1
                                                     display newline displayln
                                                     not
                                                     null?
                                                     eq?
                                                     add1
                                                     sub1
                                                     zero?
                                                     abs
                                                     void
                                                     quotient
                                                     remainder
                                                     display
                                                     displayln
                                                     newline
                                                    
                                                     symbol->string
                                                     string-append
                                                     string-length
                                                     
                                                     (my-cons cons)
                                                     (my-list list)
                                                     (my-car car)
                                                     (my-cdr cdr)
                                                     (my-pair? pair?)
                                                     (my-set-car! set-car!)
                                                     (my-set-cdr! set-cdr!)
                                                     
                                                     
                                                     
                                                     (my-box box)
                                                     (my-unbox unbox)
                                                     (my-set-box! set-box!)
                                                     
                                                     vector
                                                     vector-set!
                                                     vector-ref
                                                     (my-vector->list vector->list)
                                                     (my-list->vector list->vector)
                                                     
                                                     
                                                     
                                                     equal?
                                                     
                                                     
                                                    
                                                     
                                                     symbol?)
                                      #:constants (null pi e 
                                                        call/cc
                                                        call-with-current-continuation)))