;Metacircular evaluator for a parallelized Scheme I call Paralisp.
(require-extension srfi-18)

(define (paralisp-eval exp env)
  (define (self-evaluating? exp)
    (or (null? exp) (procedure? exp) (boolean? exp) (string? exp) (number? exp)))
  (define (variable? exp)
    (symbol? exp))
  (define (given-operator? exp operator)
    (and (list? exp) (eq? operator (car exp))))
  (define (quoted? exp)
    (given-operator? exp 'quote))
  (define (text-of-quotation exp)
    (cadr exp))
  (define (assignment? exp)
    (given-operator? exp 'set!))
  (define (definition? exp)
    (given-operator? exp 'define))
  (define (if? exp)
    (given-operator? exp 'if))
  (define (begin? exp)
    (given-operator? exp 'begin))
  (define (cond? exp)
    (given-operator? exp 'cond))
  (define (lambda? exp)
    (given-operator? exp 'lambda))
  (define (cond->if exp)
    (define (chain-ifs exp)
      (define (first-clause exp)
        (car exp))
      (define (rest-clauses exp)
        (cdr exp))
      (if (null? exp)
        '()
	(if (eq? (car (first-clause exp)) 'else)
	  (cadr (first-clause exp))
          (list 'if (car (first-clause exp)) (cadr (first-clause exp)) (chain-ifs (rest-clauses exp))))))
    ;Strip off the 'cond symbol.
    (chain-ifs (cdr exp)))
  (define (and? exp)
    (given-operator? exp 'and))
  (define (or? exp)
    (given-operator? exp 'or))
  (define (lambda-parameters exp)
    (cadr exp))
  (define (lambda-body exp)
    (caddr exp))
  (define (begin-actions exp)
    (cdr exp))
  (define (application? exp)
    (list? exp))
  (cond
    ;These forms evaluate without multiple parallel evaluations.
    ((self-evaluating? exp) exp)
    ((variable? exp) (lookup-variable-value exp env))
    ((quoted? exp) (text-of-quotation exp))
    ((assignment? exp) (eval-assignment exp env))
    ((definition? exp) (eval-definition exp env))
    ((lambda? exp) (make-procedure (lambda-parameters exp) (lambda-body exp) env))
    ;These are special forms that implement their own order of evaluation.
    ((if? exp) (eval-if exp env))
    ((begin? exp) (eval-sequence (begin-actions exp) env))
    ((cond? exp) (paralisp-eval (cond->if exp) env))
    ((and? exp)
      (let ((andf (lambda (exp) (and (paralisp-eval (car exp) env) (andf (cdr exp))))))
        (andf (cdr exp))))
    ((or? exp)
      (let ((orf (lambda (exp) (or (paralisp-eval (car exp) env) (orf (cdr exp))))))
        (orf (cdr exp))))
    ;All normal function applications use parapply to evaluate the operator and arguments.
    ((application? exp)
      (let ((exp (paramap (lambda (val) (paralisp-eval val (copy-environment env))) exp)))
        (if (or (primitive-procedure? (car exp)) (compound-procedure? (car exp)))
	  (paralisp-apply (car exp) (cdr exp))
	  (error "Operator not a function -- EVAL" (car exp)))))
    (else (error "Unknown expression type -- EVAL" exp))))

(define (primitive-procedure? procedure)
  (and (list? procedure) (symbol? (car procedure)) (procedure? (cadr procedure))))
(define (procedure-parameters procedure)
  (car (cdr procedure)))
(define (procedure-body procedure)
  (car (cdr (cdr procedure))))
(define (procedure-environment procedure)
  (car (cdr (cdr (cdr procedure)))))
(define (paralisp-apply procedure arguments)
  (cond
    ((primitive-procedure? procedure) (apply-primitive-procedure procedure arguments))
    ;Procedure bodies are single expressions rather than sequences-by-default. s/eval-sequence/eval
    ((compound-procedure? procedure)
      (paralisp-eval
        (procedure-body procedure)
	(extend-environment (procedure-parameters procedure) arguments (procedure-environment procedure))))
    (else (error "Uknown procedure type -- APPLY" procedure))))

(define (primitive-procedure-objects)
  (list
    (list 'cons cons)
    (list 'car car)
    (list 'cdr cdr)
    (list 'eq? eq?)
    (list 'not not)
    (list 'procedure? procedure?)
    (list 'boolean? boolean?)
    (list 'symbol? symbol?)
    (list 'pair? pair?)
    (list 'string? string?)
    (list 'error error)
    (list 'eval paralisp-eval)
    (list 'apply paralisp-apply)
    (list 'map paramap-wrap)
    (list '+ +)
    (list '- -)
    (list '* *)
    (list '/ /)
    (list '= =)
    (list 'call-with-current-continuation call-with-current-continuation)
    (list 'exit exit)))
(define (primitive-name proc)
 (car proc))
(define (primitive-procedure-names)
  (define (apply-to-all func all)
    (if (null? all)
      '()
      (cons (func (car all)) (apply-to-all func (cdr all)))))
   (apply-to-all primitive-name (primitive-procedure-objects)))

(define (primitive-implementation proc) (cadr proc))
(define (apply-primitive-procedure proc args)
  (apply (primitive-implementation proc) args))
    
(define (eval-if exp env)
  (define (true? exp)
    (not (eq? exp #f)))
  (define (if-predicate exp)
    (car exp))
  (define (if-consequent exp)
    (car (cdr exp)))
  (define (if-alternative exp)
    (car (cdr (cdr exp))))
  (let ((exp (cdr exp)))
    (if (true? (paralisp-eval (if-predicate exp) env))
      (paralisp-eval (if-consequent exp) env)
      (paralisp-eval (if-alternative exp) env))))

;Evaluates a linear sequence of expressions in the given order, returning the value of the last expression.
(define (eval-sequence exps env)
  (define (first-exp exps)
    (car exps))
  (define (rest-exps exps)
    (cdr exps))
  (define (last-exp? exps)
    (null? (rest-exps exps)))
  (if (last-exp? exps)
    (paralisp-eval (first-exp exps) env)
    (begin
      (paralisp-eval (first-exp exps) env)
      (eval-sequence (rest-exps exps) env))))

(define (eval-assignment exp env)
  (define (assignment-variable exp)
    (car (cdr exp)))
  (define (assignment-value exp)
    (car (cdr (cdr exp))))
  (let ((value (paralisp-eval (assignment-value exp) env)))
    (begin
      (set-variable-value! (assignment-variable exp) value env)
      value)))

(define (definition-variable exp)
  (car (cdr exp)))
(define (fdefinition-name exp)
  (car (definition-variable exp)))
(define (fdefinition-arguments exp)
  (cdr (definition-variable exp)))
(define (definition-body exp)
  (car (cdr (cdr exp))))
(define (eval-definition exp env)
  (if (pair? (definition-variable exp))
    ;Syntactic sugar should be expanded and reevaluated rather than processed in hard-coding.
    (paralisp-eval (list 'define (fdefinition-name exp) (list 'lambda (fdefinition-arguments exp) (definition-body exp))) env)
    (let ((value (paralisp-eval (definition-body exp) env)))
      (begin
        (define-variable! (definition-variable exp) value env)
	value))))

(define (make-procedure parameters body env)
  (list 'procedure parameters body env))

(define (compound-procedure? p)
  (and (list? p) (eq? (car p) 'procedure)))

(define (enclosing-environment env) (cdr env))
(define (first-frame env) (car env))
(define the-empty-environment '())

(define (copy-frame frame)
  (define (copy-list l)
    (if (null? l) '() (cons (car l) (copy-list (cdr l)))))
  (make-frame (copy-list (frame-variables frame)) (frame-values frame)))
(define (copy-environment env)
  (if (eq? env the-empty-environment)
    the-empty-environment
    (cons (copy-frame (first-frame env)) (copy-environment (enclosing-environment env)))))

(define (make-frame variables values) (cons variables values))
(define (frame-variables frame) (car frame))
(define (frame-values frame) (cdr frame))

(define (add-binding-to-frame! var val frame)
  (begin
    (set-car! frame (cons var (car frame)))
    (set-cdr! frame (cons val (cdr frame)))))

(define (extend-environment vars vals base-env)
  (if (= (length vars) (length vals))
    (cons (make-frame vars vals) base-env)
    (if (< (length vars) (length vals))
      (error "Too many arguments supplied." vars vals)
      (error "Too few arguments supplied." vars vals))))

(define (lookup-variable-value var env)
  (define (env-loop env)
    (define (scan vars vals)
      (cond
        ((null? vars) (env-loop (enclosing-environment env)))
	((eq? var (car vars)) (car vals))
	(else (scan (cdr vars) (cdr vals)))))
    (if (eq? env the-empty-environment)
      (error "Unbound variable: " var)
      (let ((frame (first-frame env)))
        (scan (frame-variables frame) (frame-values frame)))))
  (env-loop env))

(define (set-variable-value! var val env)
  (define (env-loop env)
    (define (scan vars vals)
      (cond
        ((null? vars) (env-loop (enclosing-environment env)))
	((eq? var (car vars)) (set-car! vals val))
	(else (scan (cdr vars) (cdr vals)))))
    (if (eq? env the-empty-environment)
      (error "Unbound variable -- SET!: " var)
      (let ((frame (first-frame env)))
        (scan (frame-variables frame) (frame-values)))))
  (env-loop env))

(define (define-variable! var val env)
  (let ((frame (first-frame env)))
    (define (scan vars vals)
      (cond
        ((null? vars) (add-binding-to-frame! var val frame))
	((eq? var (car vars)) (set-car! vals val))
	(else (scan (cdr vars) (cdr vals)))))
    (scan (frame-variables frame) (frame-values frame))))

(define (setup-environment)
  (let ((initial-env (extend-environment (primitive-procedure-names) (primitive-procedure-objects) the-empty-environment)))
    (begin
      (define-variable! '#t #t initial-env)
      (define-variable! '#f #f initial-env)
      ;Hack that lets me use paralisp-eval to evaluate eval.
      ;(define-variable! 'initial-env initial-env initial-env)
      ;Definitions within the environment.
      (paralisp-eval
        '(begin
	  (define (null? exp) (eq? exp '()))
	  (define call/cc call-with-current-continuation))
	initial-env)
      initial-env)))

;A main driver of parallelism. Applies the given function to each item of list vals with a separate thread for each, then
;collects the results of those threads into a correctly-ordered list and returns the list.  It has no side-effects and
;matches the semantics of map.  Takes inputs and gives outputs in ordinary Scheme data.
(define (build-thread-list func vals)
  (if (null? vals)
    '()
    (cons (thread-start! (lambda () (func (car vals)))) (build-thread-list func (cdr vals)))))
(define (collect-results threads)
  (if (null? threads)
    '()
    (cons (thread-join! (car threads)) (collect-results (cdr threads)))))
(define (paramap func vals)
  (collect-results (build-thread-list func vals)))
;Wraps up paramap to use ParaLisp functions and data as arguments.
(define (paramap-wrap func vals)
  (paramap (lambda (val) (paralisp-apply func (list val))) vals))

;Driver REPL for the metacircular evaluator.
(define input-prompt ";;; M-Eval input:")
(define output-prompt ";;; M-Eval value:")

(define (driver-loop)
  (prompt-for-input input-prompt)
  (let ((input (read)))
    (let ((output (paralisp-eval input the-global-environment)))
      (announce-output output-prompt)
      (user-print output)))
  (driver-loop))

(define (prompt-for-input string)
  (display string))
(define (announce-output string) (display string) (newline))
(define (user-print object)
  (if (compound-procedure? object)
      (display (list 'compound-procedure
                     (procedure-parameters object)
                     (procedure-body object)
                     '<procedure-env>))
      (display object)))
(define the-global-environment (setup-environment))

;The "main routine" and entry point of the Scheme program.
(driver-loop)