mirror of
https://github.com/justinethier/cyclone.git
synced 2025-07-14 00:07:36 +02:00
Move library code to corresponding sld files
This commit is contained in:
Justin Ethier
parent
f85a8d6b64
commit
618fe9a59f
5 changed files with 998 additions and 1005 deletions
2
Makefile
2
Makefile
|
|
@ -63,7 +63,6 @@ bootstrap: icyc
|
|||
cp include/cyclone/types.h $(BOOTSTRAP_DIR)/include/cyclone
|
||||
cp include/cyclone/runtime-main.h $(BOOTSTRAP_DIR)/include/cyclone
|
||||
cp include/cyclone/runtime.h $(BOOTSTRAP_DIR)/include/cyclone
|
||||
cp scheme/*.scm $(BOOTSTRAP_DIR)/scheme
|
||||
cp scheme/*.sld $(BOOTSTRAP_DIR)/scheme
|
||||
cp scheme/cyclone/*.sld $(BOOTSTRAP_DIR)/scheme/cyclone
|
||||
cp runtime.c $(BOOTSTRAP_DIR)
|
||||
|
|
@ -122,7 +121,6 @@ install:
|
|||
$(MKDIR) $(DESTDIR)$(DATADIR)/scheme/cyclone
|
||||
$(INSTALL) -m0644 libcyclone.a $(DESTDIR)$(LIBDIR)/
|
||||
$(INSTALL) -m0644 include/cyclone/*.h $(DESTDIR)$(INCDIR)/
|
||||
$(INSTALL) -m0644 scheme/*.scm $(DESTDIR)$(DATADIR)/scheme
|
||||
$(INSTALL) -m0644 scheme/*.sld $(DESTDIR)$(DATADIR)/scheme
|
||||
$(INSTALL) -m0644 scheme/*.o $(DESTDIR)$(DATADIR)/scheme
|
||||
$(INSTALL) -m0644 scheme/cyclone/*.sld $(DESTDIR)$(DATADIR)/scheme/cyclone
|
||||
|
|
|
|||
530
scheme/eval.scm
530
scheme/eval.scm
|
|
@ -1,529 +1 @@
|
|||
;; Cyclone Scheme
|
||||
;; Copyright (c) 2014, Justin Ethier
|
||||
;; All rights reserved.
|
||||
;;
|
||||
;; The Cyclone interpreter, based on the meta-circular evaluator from SICP 4.1:
|
||||
;; http://mitpress.mit.edu/sicp/full-text/book/book-Z-H-26.html#%_sec_4.1
|
||||
;;
|
||||
;; The code in this module is used both by the compiler and at runtime, so
|
||||
;; when bootstrapping from a Scheme, keep in mind the code in this module
|
||||
;; cannot use features that are not also provided by Cyclone.
|
||||
;;
|
||||
|
||||
(define (eval exp . env)
|
||||
(if (null? env)
|
||||
((analyze exp) *global-environment*)
|
||||
((analyze exp) (car env))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Expression handling helper functions
|
||||
(define (self-evaluating? exp)
|
||||
(cond ((number? exp) #t)
|
||||
((boolean? exp) #t)
|
||||
((string? exp) #t)
|
||||
((vector? exp) #t)
|
||||
((char? exp) #t)
|
||||
((port? exp) #t)
|
||||
((eof-object? exp) #t)
|
||||
(else #f)))
|
||||
|
||||
(define (variable? exp) (symbol? exp))
|
||||
|
||||
(define (quoted? exp)
|
||||
(tagged-list? 'quote exp))
|
||||
|
||||
(define (quasiquoted? exp)
|
||||
(tagged-list? 'quasiquote exp))
|
||||
|
||||
(define (assignment? exp)
|
||||
(tagged-list? 'set! exp))
|
||||
(define (assignment-variable exp) (cadr exp))
|
||||
(define (assignment-value exp) (caddr exp))
|
||||
|
||||
(define (definition? exp)
|
||||
(tagged-list? 'define exp))
|
||||
(define (definition-variable exp)
|
||||
(if (symbol? (cadr exp))
|
||||
(cadr exp)
|
||||
(caadr exp)))
|
||||
(define (definition-value exp)
|
||||
(if (symbol? (cadr exp))
|
||||
(caddr exp)
|
||||
(make-lambda (cdadr exp) ; formal parameters
|
||||
(cddr exp)))) ; body
|
||||
|
||||
(define (lambda-parameters exp) (cadr exp))
|
||||
(define (lambda-body exp) (cddr exp))
|
||||
|
||||
(define (make-lambda parameters body)
|
||||
(cons 'lambda (cons parameters body)))
|
||||
|
||||
(define (if-predicate exp) (cadr exp))
|
||||
(define (if-consequent exp) (caddr exp))
|
||||
(define (if-alternative exp)
|
||||
(if (not (null? (cdddr exp))) ;; TODO: add (not) support
|
||||
(cadddr exp)
|
||||
#f))
|
||||
(define (make-if predicate consequent alternative)
|
||||
(list 'if predicate consequent alternative))
|
||||
|
||||
(define (begin-actions exp) (cdr exp))
|
||||
(define (last-exp? seq) (null? (cdr seq)))
|
||||
(define (first-exp seq) (car seq))
|
||||
(define (rest-exps seq) (cdr seq))
|
||||
|
||||
(define (sequence->exp seq)
|
||||
(cond ((null? seq) seq)
|
||||
((last-exp? seq) (first-exp seq))
|
||||
(else (make-begin seq))))
|
||||
(define (make-begin seq) (cons 'begin seq))
|
||||
|
||||
(define (application? exp) (pair? exp))
|
||||
(define (operator exp) (car exp))
|
||||
(define (operands exp) (cdr exp))
|
||||
;(define (no-operands? ops) (null? ops))
|
||||
;(define (first-operand ops) (car ops))
|
||||
;(define (rest-operands ops) (cdr ops))
|
||||
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Evaluator data structures
|
||||
|
||||
(define procedure-tag 'procedure)
|
||||
(define (make-procedure parameters body env)
|
||||
(list procedure-tag parameters body env))
|
||||
(define (compound-procedure? p)
|
||||
(tagged-list? procedure-tag p))
|
||||
(define (procedure-parameters p) (cadr p))
|
||||
(define (procedure-body p) (caddr p))
|
||||
(define (procedure-environment p) (cadddr p))
|
||||
|
||||
;; Environments
|
||||
(define (enclosing-environment env) (cdr env))
|
||||
(define (first-frame env) (car env))
|
||||
(define the-empty-environment '())
|
||||
|
||||
(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)
|
||||
(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))
|
||||
(cond-expand
|
||||
(cyclone
|
||||
(Cyc-get-cvar (car vals)))
|
||||
(else
|
||||
(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))
|
||||
(cond-expand
|
||||
(cyclone
|
||||
(if (Cyc-cvar? (car vals))
|
||||
(Cyc-set-cvar! (car vals) val)
|
||||
(set-car! vals val)))
|
||||
(else
|
||||
(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 frame)))))
|
||||
(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))
|
||||
;; TODO: update compiled var
|
||||
;; cond-expand
|
||||
;; if cvar
|
||||
;; set-cvar
|
||||
(set-car! vals val))
|
||||
(else (scan (cdr vars) (cdr vals)))))
|
||||
(scan (frame-variables frame)
|
||||
(frame-values frame))))
|
||||
|
||||
(define (primitive-procedure? proc)
|
||||
(tagged-list? 'primitive proc))
|
||||
|
||||
(define (primitive-implementation proc) (cadr proc))
|
||||
|
||||
(define primitive-procedures
|
||||
(list
|
||||
(list 'call/cc call/cc)
|
||||
(list 'call-with-values call-with-values)
|
||||
(list 'Cyc-global-vars Cyc-global-vars)
|
||||
(list 'Cyc-get-cvar Cyc-get-cvar)
|
||||
(list 'Cyc-set-cvar! Cyc-set-cvar!)
|
||||
(list 'Cyc-cvar? Cyc-cvar?)
|
||||
(list 'Cyc-has-cycle? Cyc-has-cycle?)
|
||||
(list 'Cyc-default-exception-handler Cyc-default-exception-handler)
|
||||
(list 'Cyc-current-exception-handler Cyc-current-exception-handler)
|
||||
(list '+ +)
|
||||
(list '- -)
|
||||
(list '* *)
|
||||
(list '/ /)
|
||||
(list '= =)
|
||||
(list '> >)
|
||||
(list '< <)
|
||||
(list '>= >=)
|
||||
(list '<= <=)
|
||||
(list 'apply apply)
|
||||
(list '%halt %halt)
|
||||
(list 'exit exit)
|
||||
(list 'Cyc-installation-dir Cyc-installation-dir)
|
||||
(list 'system system)
|
||||
(list 'command-line-arguments command-line-arguments)
|
||||
(list 'error error)
|
||||
(list 'cons cons)
|
||||
(list 'cell-get cell-get)
|
||||
(list 'set-global! set-global!)
|
||||
(list 'set-cell! set-cell!)
|
||||
(list 'cell cell)
|
||||
(list 'eq? eq?)
|
||||
(list 'eqv? eqv?)
|
||||
(list 'equal? equal?)
|
||||
(list 'assoc assoc)
|
||||
(list 'assq assq)
|
||||
(list 'assv assv)
|
||||
(list 'memq memq)
|
||||
(list 'memv memv)
|
||||
(list 'member member)
|
||||
(list 'length length)
|
||||
(list 'set-car! set-car!)
|
||||
(list 'set-cdr! set-cdr!)
|
||||
(list 'car car)
|
||||
(list 'cdr cdr)
|
||||
(list 'caar caar)
|
||||
(list 'cadr cadr)
|
||||
(list 'cdar cdar)
|
||||
(list 'cddr cddr)
|
||||
(list 'caaar caaar)
|
||||
(list 'caadr caadr)
|
||||
(list 'cadar cadar)
|
||||
(list 'caddr caddr)
|
||||
(list 'cdaar cdaar)
|
||||
(list 'cdadr cdadr)
|
||||
(list 'cddar cddar)
|
||||
(list 'cdddr cdddr)
|
||||
(list 'caaaar caaaar)
|
||||
(list 'caaadr caaadr)
|
||||
(list 'caadar caadar)
|
||||
(list 'caaddr caaddr)
|
||||
(list 'cadaar cadaar)
|
||||
(list 'cadadr cadadr)
|
||||
(list 'caddar caddar)
|
||||
(list 'cadddr cadddr)
|
||||
(list 'cdaaar cdaaar)
|
||||
(list 'cdaadr cdaadr)
|
||||
(list 'cdadar cdadar)
|
||||
(list 'cdaddr cdaddr)
|
||||
(list 'cddaar cddaar)
|
||||
(list 'cddadr cddadr)
|
||||
(list 'cdddar cdddar)
|
||||
(list 'cddddr cddddr)
|
||||
(list 'char->integer char->integer)
|
||||
(list 'integer->char integer->char)
|
||||
(list 'string->number string->number)
|
||||
(list 'string-cmp string-cmp)
|
||||
(list 'string-append string-append)
|
||||
(list 'list->string list->string)
|
||||
(list 'string->symbol string->symbol)
|
||||
(list 'symbol->string symbol->string)
|
||||
(list 'number->string number->string)
|
||||
(list 'string-length string-length)
|
||||
(list 'string-ref string-ref)
|
||||
(list 'string-set! string-set!)
|
||||
(list 'substring substring)
|
||||
(list 'make-vector make-vector)
|
||||
(list 'list->vector list->vector)
|
||||
(list 'vector-length vector-length)
|
||||
(list 'vector-ref vector-ref)
|
||||
(list 'vector-set! vector-set!)
|
||||
(list 'boolean? boolean?)
|
||||
(list 'char? char?)
|
||||
(list 'eof-object? eof-object?)
|
||||
(list 'null? null?)
|
||||
(list 'number? number?)
|
||||
(list 'real? real?)
|
||||
(list 'integer? integer?)
|
||||
(list 'pair? pair?)
|
||||
(list 'port? port?)
|
||||
(list 'procedure? procedure?)
|
||||
(list 'vector? vector?)
|
||||
(list 'string? string?)
|
||||
(list 'symbol? symbol?)
|
||||
(list 'open-input-file open-input-file)
|
||||
(list 'open-output-file open-output-file)
|
||||
(list 'close-port close-port)
|
||||
(list 'close-input-port close-input-port)
|
||||
(list 'close-output-port close-output-port)
|
||||
(list 'file-exists? file-exists?)
|
||||
(list 'delete-file delete-file)
|
||||
(list 'read-char read-char)
|
||||
(list 'peek-char peek-char)
|
||||
(list 'Cyc-read-line Cyc-read-line)
|
||||
(list 'Cyc-write-char Cyc-write-char)
|
||||
(list 'Cyc-write Cyc-write)
|
||||
(list 'Cyc-display Cyc-display)))
|
||||
|
||||
(define (primitive-procedure-names)
|
||||
(map car
|
||||
primitive-procedures))
|
||||
|
||||
(define (primitive-procedure-objects)
|
||||
(map (lambda (proc) (list 'primitive (cadr proc)))
|
||||
primitive-procedures))
|
||||
|
||||
(define (apply-primitive-procedure proc args)
|
||||
(apply ;apply-in-underlying-scheme
|
||||
(primitive-implementation proc) args))
|
||||
|
||||
;; TODO: temporary testing
|
||||
;; also, it would be nice to pass around something other than
|
||||
;; symbols for primitives. could the runtime inject something into the env?
|
||||
;; of course that is a problem for stuff like make_cons, that is just a
|
||||
;; C macro...
|
||||
;; (define (primitive-procedure? proc)
|
||||
;; (equal? proc 'cons))
|
||||
|
||||
(define (setup-environment)
|
||||
(let ((initial-env
|
||||
(extend-environment (primitive-procedure-names)
|
||||
(primitive-procedure-objects)
|
||||
the-empty-environment)))
|
||||
(cond-expand
|
||||
(cyclone
|
||||
;; Also include compiled variables
|
||||
(extend-environment
|
||||
(map (lambda (v) (car v)) (Cyc-global-vars))
|
||||
(map (lambda (v) (cdr v)) (Cyc-global-vars))
|
||||
initial-env))
|
||||
(else initial-env))))
|
||||
(define *global-environment* (setup-environment))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Derived expressions
|
||||
;; TODO: longer-term, this would be replaced by a macro system
|
||||
(define (cond? exp) (tagged-list? 'cond exp))
|
||||
(define (cond-clauses exp) (cdr exp))
|
||||
(define (cond-else-clause? clause)
|
||||
(eq? (cond-predicate clause) 'else))
|
||||
(define (cond-predicate clause) (car clause))
|
||||
(define (cond-actions clause) (cdr clause))
|
||||
(define (cond->if exp)
|
||||
(expand-clauses (cond-clauses exp)))
|
||||
|
||||
(define (expand-clauses clauses)
|
||||
(if (null? clauses)
|
||||
#f ; no else clause
|
||||
(let ((first (car clauses))
|
||||
(rest (cdr clauses)))
|
||||
(if (cond-else-clause? first)
|
||||
(if (null? rest)
|
||||
(sequence->exp (cond-actions first))
|
||||
(error "ELSE clause isn't last -- COND->IF"
|
||||
clauses))
|
||||
(make-if (cond-predicate first)
|
||||
(sequence->exp (cond-actions first))
|
||||
(expand-clauses rest))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Improvement from section 4.1.7 - Separate syntactic analysis from execution
|
||||
;;
|
||||
;; TODO: need to finish this section
|
||||
;; TODO: see 4.1.6 Internal Definitions
|
||||
;;
|
||||
(define (analyze exp)
|
||||
(cond ((self-evaluating? exp)
|
||||
(analyze-self-evaluating exp))
|
||||
((quoted? exp) (analyze-quoted exp))
|
||||
((quasiquoted? exp) (analyze-quasiquoted exp))
|
||||
((variable? exp) (analyze-variable exp))
|
||||
((assignment? exp) (analyze-assignment exp))
|
||||
((definition? exp) (analyze-definition exp))
|
||||
((if? exp) (analyze-if exp))
|
||||
((lambda? exp) (analyze-lambda exp))
|
||||
;; TODO: ideally, macro system would handle these next three
|
||||
((tagged-list? 'let exp)
|
||||
(let ((vars (map car (cadr exp))) ;(let->bindings exp)))
|
||||
(args (map cadr (cadr exp))) ;(let->bindings exp))))
|
||||
(body (cddr exp)))
|
||||
(analyze
|
||||
(cons
|
||||
(cons 'lambda (cons vars body))
|
||||
args))))
|
||||
((begin? exp) (analyze-sequence (begin-actions exp)))
|
||||
((cond? exp) (analyze (cond->if exp)))
|
||||
;; END derived expression processing
|
||||
|
||||
;; experimenting with passing these back to eval
|
||||
((compound-procedure? exp)
|
||||
(lambda (env) exp)) ;; TODO: good enough? update env?
|
||||
;; END experimental code
|
||||
|
||||
((procedure? exp)
|
||||
(lambda (env) exp))
|
||||
((application? exp) (analyze-application exp))
|
||||
(else
|
||||
(error "Unknown expression type -- ANALYZE" exp))))
|
||||
;(lambda () 'TODO-unknown-exp-type)))) ; JAE - this is a debug line
|
||||
|
||||
(define (analyze-self-evaluating exp)
|
||||
(lambda (env) exp))
|
||||
|
||||
(define (analyze-quoted exp)
|
||||
(let ((qval (cadr exp)))
|
||||
(lambda (env) qval)))
|
||||
|
||||
(define (analyze-quasiquoted exp)
|
||||
(error "quasiquote not supported yet by eval"))
|
||||
|
||||
(define (analyze-variable exp)
|
||||
(lambda (env) (lookup-variable-value exp env)))
|
||||
|
||||
(define (analyze-assignment exp)
|
||||
(let ((var (assignment-variable exp))
|
||||
(vproc (analyze (assignment-value exp))))
|
||||
(lambda (env)
|
||||
(set-variable-value! var (vproc env) env)
|
||||
'ok)))
|
||||
|
||||
(define (analyze-definition exp)
|
||||
(let ((var (definition-variable exp))
|
||||
(vproc (analyze (definition-value exp))))
|
||||
(lambda (env)
|
||||
(define-variable! var (vproc env) env)
|
||||
'ok)))
|
||||
|
||||
(define (analyze-if exp)
|
||||
(let ((pproc (analyze (if-predicate exp)))
|
||||
(cproc (analyze (if-consequent exp)))
|
||||
(aproc (analyze (if-alternative exp))))
|
||||
(lambda (env)
|
||||
(if (pproc env)
|
||||
(cproc env)
|
||||
(aproc env)))))
|
||||
|
||||
(define (analyze-lambda exp)
|
||||
(let ((vars (lambda-parameters exp))
|
||||
(bproc (analyze-sequence (lambda-body exp))))
|
||||
(lambda (env) (make-procedure vars bproc env))))
|
||||
|
||||
(define (analyze-sequence exps)
|
||||
(define (sequentially proc1 proc2)
|
||||
(lambda (env) (proc1 env) (proc2 env)))
|
||||
(define (loop first-proc rest-procs)
|
||||
(if (null? rest-procs)
|
||||
first-proc
|
||||
(loop (sequentially first-proc (car rest-procs))
|
||||
(cdr rest-procs))))
|
||||
(let ((procs (map analyze exps)))
|
||||
(if (null? procs)
|
||||
(error "Empty sequence -- ANALYZE"))
|
||||
(loop (car procs) (cdr procs))))
|
||||
|
||||
(define (analyze-application exp)
|
||||
(let ((fproc (analyze (operator exp)))
|
||||
(aprocs (map analyze (operands exp))))
|
||||
(lambda (env)
|
||||
(execute-application (fproc env)
|
||||
(map (lambda (aproc) (aproc env))
|
||||
aprocs)))))
|
||||
(define (execute-application proc args)
|
||||
(cond ((primitive-procedure? proc)
|
||||
(apply-primitive-procedure proc args))
|
||||
((compound-procedure? proc)
|
||||
((procedure-body proc)
|
||||
(extend-environment (procedure-parameters proc)
|
||||
args
|
||||
(procedure-environment proc))))
|
||||
((procedure? proc)
|
||||
(apply
|
||||
proc
|
||||
(map
|
||||
(lambda (a)
|
||||
(cond
|
||||
;; "unwrap" objects before passing to runtime
|
||||
((primitive-procedure? a)
|
||||
(primitive-implementation a))
|
||||
(else a)))
|
||||
args)))
|
||||
(else
|
||||
(error
|
||||
"Unknown procedure type -- EXECUTE-APPLICATION"
|
||||
proc))))
|
||||
|
||||
;(define (analyze-application exp)
|
||||
; (let ((fproc (analyze (operator exp)))
|
||||
; (aprocs (operands exp))) ; TODO: (map analyze (operands exp))))
|
||||
; (lambda (env)
|
||||
; (execute-application (fproc env)
|
||||
;; TODO: (map (lambda (aproc) (aproc env))
|
||||
; aprocs)))) ;; TODO: temporary testing w/constants
|
||||
;; TODO: aprocs)))))
|
||||
;(define (execute-application proc args)
|
||||
; (cond ((primitive-procedure? proc)
|
||||
; (apply proc args))
|
||||
; ;(apply-primitive-procedure proc args))
|
||||
;;; TODO:
|
||||
;; ;((compound-procedure? proc)
|
||||
;; ; ((procedure-body proc)
|
||||
;; ; (extend-environment (procedure-parameters proc)
|
||||
;; ; args
|
||||
;; ; (procedure-environment proc))))
|
||||
; (else
|
||||
;#f))) ;; TODO: this is a temporary debug line
|
||||
;; (error
|
||||
;; "Unknown procedure type -- EXECUTE-APPLICATION"
|
||||
;; proc))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; JAE - Testing, should work both with cyclone and other compilers (husk, chicken, etc)
|
||||
;; although, that may not be possible with (app) and possibly other forms.
|
||||
;(write (eval 2 *global-environment*))
|
||||
;(write (eval ''(1 2) *global-environment*))
|
||||
;(write (eval ''(1 . 2) *global-environment*))
|
||||
;(write (eval '(if #t 'test-ok 'test-fail) *global-environment*))
|
||||
;(write (eval '(if 1 'test-ok) *global-environment*))
|
||||
;(write (eval '(if #f 'test-fail 'test-ok) *global-environment*))
|
||||
;(write (eval '((lambda (x) (cons x 2) (cons #t x)) 1) *global-environment*))
|
||||
;;(write (eval '((lambda () (cons 1 2) (cons #t #f))) *global-environment*))
|
||||
;;(write (eval '(cons 1 2) *global-environment*)) ; TODO
|
||||
;;(write (eval '(+ 1 2) *global-environment*)) ; TODO
|
||||
|
||||
;(define (loop)
|
||||
; (display (eval (read) *global-environment*))
|
||||
; (display (newline))
|
||||
; (loop))
|
||||
;(loop)
|
||||
#f
|
||||
|
|
|
|||
530
scheme/eval.sld
530
scheme/eval.sld
|
|
@ -1,3 +1,10 @@
|
|||
;; Cyclone Scheme
|
||||
;; Copyright (c) 2014, Justin Ethier
|
||||
;; All rights reserved.
|
||||
;;
|
||||
;; The Cyclone interpreter, based on the meta-circular evaluator from SICP 4.1:
|
||||
;; http://mitpress.mit.edu/sicp/full-text/book/book-Z-H-26.html#%_sec_4.1
|
||||
;;
|
||||
(define-library (scheme eval)
|
||||
(import
|
||||
(scheme cyclone util)
|
||||
|
|
@ -8,5 +15,524 @@
|
|||
(export
|
||||
eval
|
||||
)
|
||||
(include "eval.scm")
|
||||
(begin))
|
||||
(begin
|
||||
|
||||
(define (eval exp . env)
|
||||
(if (null? env)
|
||||
((analyze exp) *global-environment*)
|
||||
((analyze exp) (car env))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Expression handling helper functions
|
||||
(define (self-evaluating? exp)
|
||||
(cond ((number? exp) #t)
|
||||
((boolean? exp) #t)
|
||||
((string? exp) #t)
|
||||
((vector? exp) #t)
|
||||
((char? exp) #t)
|
||||
((port? exp) #t)
|
||||
((eof-object? exp) #t)
|
||||
(else #f)))
|
||||
|
||||
(define (variable? exp) (symbol? exp))
|
||||
|
||||
(define (quoted? exp)
|
||||
(tagged-list? 'quote exp))
|
||||
|
||||
(define (quasiquoted? exp)
|
||||
(tagged-list? 'quasiquote exp))
|
||||
|
||||
(define (assignment? exp)
|
||||
(tagged-list? 'set! exp))
|
||||
(define (assignment-variable exp) (cadr exp))
|
||||
(define (assignment-value exp) (caddr exp))
|
||||
|
||||
(define (definition? exp)
|
||||
(tagged-list? 'define exp))
|
||||
(define (definition-variable exp)
|
||||
(if (symbol? (cadr exp))
|
||||
(cadr exp)
|
||||
(caadr exp)))
|
||||
(define (definition-value exp)
|
||||
(if (symbol? (cadr exp))
|
||||
(caddr exp)
|
||||
(make-lambda (cdadr exp) ; formal parameters
|
||||
(cddr exp)))) ; body
|
||||
|
||||
(define (lambda-parameters exp) (cadr exp))
|
||||
(define (lambda-body exp) (cddr exp))
|
||||
|
||||
(define (make-lambda parameters body)
|
||||
(cons 'lambda (cons parameters body)))
|
||||
|
||||
(define (if-predicate exp) (cadr exp))
|
||||
(define (if-consequent exp) (caddr exp))
|
||||
(define (if-alternative exp)
|
||||
(if (not (null? (cdddr exp))) ;; TODO: add (not) support
|
||||
(cadddr exp)
|
||||
#f))
|
||||
(define (make-if predicate consequent alternative)
|
||||
(list 'if predicate consequent alternative))
|
||||
|
||||
(define (begin-actions exp) (cdr exp))
|
||||
(define (last-exp? seq) (null? (cdr seq)))
|
||||
(define (first-exp seq) (car seq))
|
||||
(define (rest-exps seq) (cdr seq))
|
||||
|
||||
(define (sequence->exp seq)
|
||||
(cond ((null? seq) seq)
|
||||
((last-exp? seq) (first-exp seq))
|
||||
(else (make-begin seq))))
|
||||
(define (make-begin seq) (cons 'begin seq))
|
||||
|
||||
(define (application? exp) (pair? exp))
|
||||
(define (operator exp) (car exp))
|
||||
(define (operands exp) (cdr exp))
|
||||
;(define (no-operands? ops) (null? ops))
|
||||
;(define (first-operand ops) (car ops))
|
||||
;(define (rest-operands ops) (cdr ops))
|
||||
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Evaluator data structures
|
||||
|
||||
(define procedure-tag 'procedure)
|
||||
(define (make-procedure parameters body env)
|
||||
(list procedure-tag parameters body env))
|
||||
(define (compound-procedure? p)
|
||||
(tagged-list? procedure-tag p))
|
||||
(define (procedure-parameters p) (cadr p))
|
||||
(define (procedure-body p) (caddr p))
|
||||
(define (procedure-environment p) (cadddr p))
|
||||
|
||||
;; Environments
|
||||
(define (enclosing-environment env) (cdr env))
|
||||
(define (first-frame env) (car env))
|
||||
(define the-empty-environment '())
|
||||
|
||||
(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)
|
||||
(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))
|
||||
(cond-expand
|
||||
(cyclone
|
||||
(Cyc-get-cvar (car vals)))
|
||||
(else
|
||||
(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))
|
||||
(cond-expand
|
||||
(cyclone
|
||||
(if (Cyc-cvar? (car vals))
|
||||
(Cyc-set-cvar! (car vals) val)
|
||||
(set-car! vals val)))
|
||||
(else
|
||||
(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 frame)))))
|
||||
(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))
|
||||
;; TODO: update compiled var
|
||||
;; cond-expand
|
||||
;; if cvar
|
||||
;; set-cvar
|
||||
(set-car! vals val))
|
||||
(else (scan (cdr vars) (cdr vals)))))
|
||||
(scan (frame-variables frame)
|
||||
(frame-values frame))))
|
||||
|
||||
(define (primitive-procedure? proc)
|
||||
(tagged-list? 'primitive proc))
|
||||
|
||||
(define (primitive-implementation proc) (cadr proc))
|
||||
|
||||
(define primitive-procedures
|
||||
(list
|
||||
(list 'call/cc call/cc)
|
||||
(list 'call-with-values call-with-values)
|
||||
(list 'Cyc-global-vars Cyc-global-vars)
|
||||
(list 'Cyc-get-cvar Cyc-get-cvar)
|
||||
(list 'Cyc-set-cvar! Cyc-set-cvar!)
|
||||
(list 'Cyc-cvar? Cyc-cvar?)
|
||||
(list 'Cyc-has-cycle? Cyc-has-cycle?)
|
||||
(list 'Cyc-default-exception-handler Cyc-default-exception-handler)
|
||||
(list 'Cyc-current-exception-handler Cyc-current-exception-handler)
|
||||
(list '+ +)
|
||||
(list '- -)
|
||||
(list '* *)
|
||||
(list '/ /)
|
||||
(list '= =)
|
||||
(list '> >)
|
||||
(list '< <)
|
||||
(list '>= >=)
|
||||
(list '<= <=)
|
||||
(list 'apply apply)
|
||||
(list '%halt %halt)
|
||||
(list 'exit exit)
|
||||
(list 'Cyc-installation-dir Cyc-installation-dir)
|
||||
(list 'system system)
|
||||
(list 'command-line-arguments command-line-arguments)
|
||||
(list 'error error)
|
||||
(list 'cons cons)
|
||||
(list 'cell-get cell-get)
|
||||
(list 'set-global! set-global!)
|
||||
(list 'set-cell! set-cell!)
|
||||
(list 'cell cell)
|
||||
(list 'eq? eq?)
|
||||
(list 'eqv? eqv?)
|
||||
(list 'equal? equal?)
|
||||
(list 'assoc assoc)
|
||||
(list 'assq assq)
|
||||
(list 'assv assv)
|
||||
(list 'memq memq)
|
||||
(list 'memv memv)
|
||||
(list 'member member)
|
||||
(list 'length length)
|
||||
(list 'set-car! set-car!)
|
||||
(list 'set-cdr! set-cdr!)
|
||||
(list 'car car)
|
||||
(list 'cdr cdr)
|
||||
(list 'caar caar)
|
||||
(list 'cadr cadr)
|
||||
(list 'cdar cdar)
|
||||
(list 'cddr cddr)
|
||||
(list 'caaar caaar)
|
||||
(list 'caadr caadr)
|
||||
(list 'cadar cadar)
|
||||
(list 'caddr caddr)
|
||||
(list 'cdaar cdaar)
|
||||
(list 'cdadr cdadr)
|
||||
(list 'cddar cddar)
|
||||
(list 'cdddr cdddr)
|
||||
(list 'caaaar caaaar)
|
||||
(list 'caaadr caaadr)
|
||||
(list 'caadar caadar)
|
||||
(list 'caaddr caaddr)
|
||||
(list 'cadaar cadaar)
|
||||
(list 'cadadr cadadr)
|
||||
(list 'caddar caddar)
|
||||
(list 'cadddr cadddr)
|
||||
(list 'cdaaar cdaaar)
|
||||
(list 'cdaadr cdaadr)
|
||||
(list 'cdadar cdadar)
|
||||
(list 'cdaddr cdaddr)
|
||||
(list 'cddaar cddaar)
|
||||
(list 'cddadr cddadr)
|
||||
(list 'cdddar cdddar)
|
||||
(list 'cddddr cddddr)
|
||||
(list 'char->integer char->integer)
|
||||
(list 'integer->char integer->char)
|
||||
(list 'string->number string->number)
|
||||
(list 'string-cmp string-cmp)
|
||||
(list 'string-append string-append)
|
||||
(list 'list->string list->string)
|
||||
(list 'string->symbol string->symbol)
|
||||
(list 'symbol->string symbol->string)
|
||||
(list 'number->string number->string)
|
||||
(list 'string-length string-length)
|
||||
(list 'string-ref string-ref)
|
||||
(list 'string-set! string-set!)
|
||||
(list 'substring substring)
|
||||
(list 'make-vector make-vector)
|
||||
(list 'list->vector list->vector)
|
||||
(list 'vector-length vector-length)
|
||||
(list 'vector-ref vector-ref)
|
||||
(list 'vector-set! vector-set!)
|
||||
(list 'boolean? boolean?)
|
||||
(list 'char? char?)
|
||||
(list 'eof-object? eof-object?)
|
||||
(list 'null? null?)
|
||||
(list 'number? number?)
|
||||
(list 'real? real?)
|
||||
(list 'integer? integer?)
|
||||
(list 'pair? pair?)
|
||||
(list 'port? port?)
|
||||
(list 'procedure? procedure?)
|
||||
(list 'vector? vector?)
|
||||
(list 'string? string?)
|
||||
(list 'symbol? symbol?)
|
||||
(list 'open-input-file open-input-file)
|
||||
(list 'open-output-file open-output-file)
|
||||
(list 'close-port close-port)
|
||||
(list 'close-input-port close-input-port)
|
||||
(list 'close-output-port close-output-port)
|
||||
(list 'file-exists? file-exists?)
|
||||
(list 'delete-file delete-file)
|
||||
(list 'read-char read-char)
|
||||
(list 'peek-char peek-char)
|
||||
(list 'Cyc-read-line Cyc-read-line)
|
||||
(list 'Cyc-write-char Cyc-write-char)
|
||||
(list 'Cyc-write Cyc-write)
|
||||
(list 'Cyc-display Cyc-display)))
|
||||
|
||||
(define (primitive-procedure-names)
|
||||
(map car
|
||||
primitive-procedures))
|
||||
|
||||
(define (primitive-procedure-objects)
|
||||
(map (lambda (proc) (list 'primitive (cadr proc)))
|
||||
primitive-procedures))
|
||||
|
||||
(define (apply-primitive-procedure proc args)
|
||||
(apply ;apply-in-underlying-scheme
|
||||
(primitive-implementation proc) args))
|
||||
|
||||
;; TODO: temporary testing
|
||||
;; also, it would be nice to pass around something other than
|
||||
;; symbols for primitives. could the runtime inject something into the env?
|
||||
;; of course that is a problem for stuff like make_cons, that is just a
|
||||
;; C macro...
|
||||
;; (define (primitive-procedure? proc)
|
||||
;; (equal? proc 'cons))
|
||||
|
||||
(define (setup-environment)
|
||||
(let ((initial-env
|
||||
(extend-environment (primitive-procedure-names)
|
||||
(primitive-procedure-objects)
|
||||
the-empty-environment)))
|
||||
(cond-expand
|
||||
(cyclone
|
||||
;; Also include compiled variables
|
||||
(extend-environment
|
||||
(map (lambda (v) (car v)) (Cyc-global-vars))
|
||||
(map (lambda (v) (cdr v)) (Cyc-global-vars))
|
||||
initial-env))
|
||||
(else initial-env))))
|
||||
(define *global-environment* (setup-environment))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Derived expressions
|
||||
;; TODO: longer-term, this would be replaced by a macro system
|
||||
(define (cond? exp) (tagged-list? 'cond exp))
|
||||
(define (cond-clauses exp) (cdr exp))
|
||||
(define (cond-else-clause? clause)
|
||||
(eq? (cond-predicate clause) 'else))
|
||||
(define (cond-predicate clause) (car clause))
|
||||
(define (cond-actions clause) (cdr clause))
|
||||
(define (cond->if exp)
|
||||
(expand-clauses (cond-clauses exp)))
|
||||
|
||||
(define (expand-clauses clauses)
|
||||
(if (null? clauses)
|
||||
#f ; no else clause
|
||||
(let ((first (car clauses))
|
||||
(rest (cdr clauses)))
|
||||
(if (cond-else-clause? first)
|
||||
(if (null? rest)
|
||||
(sequence->exp (cond-actions first))
|
||||
(error "ELSE clause isn't last -- COND->IF"
|
||||
clauses))
|
||||
(make-if (cond-predicate first)
|
||||
(sequence->exp (cond-actions first))
|
||||
(expand-clauses rest))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Improvement from section 4.1.7 - Separate syntactic analysis from execution
|
||||
;;
|
||||
;; TODO: need to finish this section
|
||||
;; TODO: see 4.1.6 Internal Definitions
|
||||
;;
|
||||
(define (analyze exp)
|
||||
(cond ((self-evaluating? exp)
|
||||
(analyze-self-evaluating exp))
|
||||
((quoted? exp) (analyze-quoted exp))
|
||||
((quasiquoted? exp) (analyze-quasiquoted exp))
|
||||
((variable? exp) (analyze-variable exp))
|
||||
((assignment? exp) (analyze-assignment exp))
|
||||
((definition? exp) (analyze-definition exp))
|
||||
((if? exp) (analyze-if exp))
|
||||
((lambda? exp) (analyze-lambda exp))
|
||||
;; TODO: ideally, macro system would handle these next three
|
||||
((tagged-list? 'let exp)
|
||||
(let ((vars (map car (cadr exp))) ;(let->bindings exp)))
|
||||
(args (map cadr (cadr exp))) ;(let->bindings exp))))
|
||||
(body (cddr exp)))
|
||||
(analyze
|
||||
(cons
|
||||
(cons 'lambda (cons vars body))
|
||||
args))))
|
||||
((begin? exp) (analyze-sequence (begin-actions exp)))
|
||||
((cond? exp) (analyze (cond->if exp)))
|
||||
;; END derived expression processing
|
||||
|
||||
;; experimenting with passing these back to eval
|
||||
((compound-procedure? exp)
|
||||
(lambda (env) exp)) ;; TODO: good enough? update env?
|
||||
;; END experimental code
|
||||
|
||||
((procedure? exp)
|
||||
(lambda (env) exp))
|
||||
((application? exp) (analyze-application exp))
|
||||
(else
|
||||
(error "Unknown expression type -- ANALYZE" exp))))
|
||||
;(lambda () 'TODO-unknown-exp-type)))) ; JAE - this is a debug line
|
||||
|
||||
(define (analyze-self-evaluating exp)
|
||||
(lambda (env) exp))
|
||||
|
||||
(define (analyze-quoted exp)
|
||||
(let ((qval (cadr exp)))
|
||||
(lambda (env) qval)))
|
||||
|
||||
(define (analyze-quasiquoted exp)
|
||||
(error "quasiquote not supported yet by eval"))
|
||||
|
||||
(define (analyze-variable exp)
|
||||
(lambda (env) (lookup-variable-value exp env)))
|
||||
|
||||
(define (analyze-assignment exp)
|
||||
(let ((var (assignment-variable exp))
|
||||
(vproc (analyze (assignment-value exp))))
|
||||
(lambda (env)
|
||||
(set-variable-value! var (vproc env) env)
|
||||
'ok)))
|
||||
|
||||
(define (analyze-definition exp)
|
||||
(let ((var (definition-variable exp))
|
||||
(vproc (analyze (definition-value exp))))
|
||||
(lambda (env)
|
||||
(define-variable! var (vproc env) env)
|
||||
'ok)))
|
||||
|
||||
(define (analyze-if exp)
|
||||
(let ((pproc (analyze (if-predicate exp)))
|
||||
(cproc (analyze (if-consequent exp)))
|
||||
(aproc (analyze (if-alternative exp))))
|
||||
(lambda (env)
|
||||
(if (pproc env)
|
||||
(cproc env)
|
||||
(aproc env)))))
|
||||
|
||||
(define (analyze-lambda exp)
|
||||
(let ((vars (lambda-parameters exp))
|
||||
(bproc (analyze-sequence (lambda-body exp))))
|
||||
(lambda (env) (make-procedure vars bproc env))))
|
||||
|
||||
(define (analyze-sequence exps)
|
||||
(define (sequentially proc1 proc2)
|
||||
(lambda (env) (proc1 env) (proc2 env)))
|
||||
(define (loop first-proc rest-procs)
|
||||
(if (null? rest-procs)
|
||||
first-proc
|
||||
(loop (sequentially first-proc (car rest-procs))
|
||||
(cdr rest-procs))))
|
||||
(let ((procs (map analyze exps)))
|
||||
(if (null? procs)
|
||||
(error "Empty sequence -- ANALYZE"))
|
||||
(loop (car procs) (cdr procs))))
|
||||
|
||||
(define (analyze-application exp)
|
||||
(let ((fproc (analyze (operator exp)))
|
||||
(aprocs (map analyze (operands exp))))
|
||||
(lambda (env)
|
||||
(execute-application (fproc env)
|
||||
(map (lambda (aproc) (aproc env))
|
||||
aprocs)))))
|
||||
(define (execute-application proc args)
|
||||
(cond ((primitive-procedure? proc)
|
||||
(apply-primitive-procedure proc args))
|
||||
((compound-procedure? proc)
|
||||
((procedure-body proc)
|
||||
(extend-environment (procedure-parameters proc)
|
||||
args
|
||||
(procedure-environment proc))))
|
||||
((procedure? proc)
|
||||
(apply
|
||||
proc
|
||||
(map
|
||||
(lambda (a)
|
||||
(cond
|
||||
;; "unwrap" objects before passing to runtime
|
||||
((primitive-procedure? a)
|
||||
(primitive-implementation a))
|
||||
(else a)))
|
||||
args)))
|
||||
(else
|
||||
(error
|
||||
"Unknown procedure type -- EXECUTE-APPLICATION"
|
||||
proc))))
|
||||
|
||||
;(define (analyze-application exp)
|
||||
; (let ((fproc (analyze (operator exp)))
|
||||
; (aprocs (operands exp))) ; TODO: (map analyze (operands exp))))
|
||||
; (lambda (env)
|
||||
; (execute-application (fproc env)
|
||||
;; TODO: (map (lambda (aproc) (aproc env))
|
||||
; aprocs)))) ;; TODO: temporary testing w/constants
|
||||
;; TODO: aprocs)))))
|
||||
;(define (execute-application proc args)
|
||||
; (cond ((primitive-procedure? proc)
|
||||
; (apply proc args))
|
||||
; ;(apply-primitive-procedure proc args))
|
||||
;;; TODO:
|
||||
;; ;((compound-procedure? proc)
|
||||
;; ; ((procedure-body proc)
|
||||
;; ; (extend-environment (procedure-parameters proc)
|
||||
;; ; args
|
||||
;; ; (procedure-environment proc))))
|
||||
; (else
|
||||
;#f))) ;; TODO: this is a temporary debug line
|
||||
;; (error
|
||||
;; "Unknown procedure type -- EXECUTE-APPLICATION"
|
||||
;; proc))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; JAE - Testing, should work both with cyclone and other compilers (husk, chicken, etc)
|
||||
;; although, that may not be possible with (app) and possibly other forms.
|
||||
;(write (eval 2 *global-environment*))
|
||||
;(write (eval ''(1 2) *global-environment*))
|
||||
;(write (eval ''(1 . 2) *global-environment*))
|
||||
;(write (eval '(if #t 'test-ok 'test-fail) *global-environment*))
|
||||
;(write (eval '(if 1 'test-ok) *global-environment*))
|
||||
;(write (eval '(if #f 'test-fail 'test-ok) *global-environment*))
|
||||
;(write (eval '((lambda (x) (cons x 2) (cons #t x)) 1) *global-environment*))
|
||||
;;(write (eval '((lambda () (cons 1 2) (cons #t #f))) *global-environment*))
|
||||
;;(write (eval '(cons 1 2) *global-environment*)) ; TODO
|
||||
;;(write (eval '(+ 1 2) *global-environment*)) ; TODO
|
||||
|
||||
;(define (loop)
|
||||
; (display (eval (read) *global-environment*))
|
||||
; (display (newline))
|
||||
; (loop))
|
||||
;(loop)
|
||||
|
||||
))
|
||||
|
|
|
|||
|
|
@ -1,470 +1 @@
|
|||
;; Cyclone Scheme
|
||||
;; Copyright (c) 2014, Justin Ethier
|
||||
;; All rights reserved.
|
||||
;;
|
||||
;; This module contains the s-expression parser and supporting functions.
|
||||
;;
|
||||
;; The code in this module is used both by the compiler and at runtime, so
|
||||
;; when bootstrapping from a Scheme, keep in mind the code in this module
|
||||
;; cannot use features that are not also provided by Cyclone.
|
||||
;;
|
||||
|
||||
;; Extended information for each input port
|
||||
(define *in-port-table* '())
|
||||
(define (reg-port fp)
|
||||
(let ((r (assoc fp *in-port-table*)))
|
||||
(cond
|
||||
((not r)
|
||||
;(write `(ADDED NEW ENTRY TO in port table!!))
|
||||
(set! r
|
||||
(list fp
|
||||
#f ; Buffered char, if any
|
||||
1 ; Line number
|
||||
0)) ; Char number
|
||||
(set! *in-port-table* (cons r *in-port-table*))
|
||||
r)
|
||||
(else r))))
|
||||
;; TODO: unreg-port - delete fp entry from *in-port-table*
|
||||
;; would want to do this when port is closed
|
||||
|
||||
(define (in-port:read-buf! ptbl)
|
||||
(let ((result (cadr ptbl)))
|
||||
(in-port:set-buf! ptbl #f)
|
||||
result))
|
||||
(define (in-port:get-buf ptbl) (cadr ptbl))
|
||||
(define (in-port:set-buf! ptbl buf) (set-car! (cdr ptbl) buf))
|
||||
(define (in-port:get-lnum ptbl) (caddr ptbl))
|
||||
(define (in-port:set-lnum! ptbl lnum) (set-car! (cddr ptbl) lnum))
|
||||
(define (in-port:get-cnum ptbl) (cadddr ptbl))
|
||||
(define (in-port:set-cnum! ptbl cnum) (set-car! (cdddr ptbl) cnum))
|
||||
;; END input port table
|
||||
|
||||
;; Helper functions
|
||||
(define (add-tok tok toks)
|
||||
(cons tok toks))
|
||||
|
||||
;; Get completed list of tokens
|
||||
(define (get-toks tok toks)
|
||||
(if (null? tok)
|
||||
toks
|
||||
(add-tok (->tok tok) toks)))
|
||||
|
||||
;; Add a token to the list, quoting it if necessary
|
||||
(define (->tok lst)
|
||||
(parse-atom (reverse lst)))
|
||||
|
||||
;; Did we read a dotted list
|
||||
(define (dotted? lst)
|
||||
(and (> (length lst) 2)
|
||||
(equal? (cadr (reverse lst)) (string->symbol "."))))
|
||||
|
||||
;; Convert a list read by the reader into an improper list
|
||||
(define (->dotted-list lst)
|
||||
(cond
|
||||
((null? lst) '())
|
||||
((equal? (car lst) (string->symbol "."))
|
||||
(cadr lst))
|
||||
(else
|
||||
(cons (car lst) (->dotted-list (cdr lst))))))
|
||||
|
||||
(define (parse-error msg lnum cnum)
|
||||
(error
|
||||
(string-append
|
||||
"Error (line "
|
||||
(number->string lnum)
|
||||
", char "
|
||||
(number->string cnum)
|
||||
"): "
|
||||
msg)))
|
||||
|
||||
;; Add finished token, if there is one, and continue parsing
|
||||
(define (parse/tok fp tok toks all? comment? parens ptbl curr-char)
|
||||
(cond
|
||||
((null? tok)
|
||||
(parse fp '() toks all? comment? parens ptbl))
|
||||
(all?
|
||||
(parse fp '()
|
||||
(add-tok (->tok tok) toks)
|
||||
all?
|
||||
comment?
|
||||
parens
|
||||
ptbl))
|
||||
(else
|
||||
;; Reached a terminating char, return current token and
|
||||
;; save term char for the next (read).
|
||||
;; Note: never call set-buf! if in "all?" mode, since
|
||||
;; that mode builds a list of tokens
|
||||
(in-port:set-buf! ptbl curr-char)
|
||||
;(write `(DEBUG ,tok ,ptbl))
|
||||
;(write "\n")
|
||||
(car (add-tok (->tok tok) toks)))))
|
||||
|
||||
;; Parse input from stream
|
||||
;;
|
||||
;; Input:
|
||||
;; - Port object
|
||||
;; - Current token
|
||||
;; - List of tokens read (if applicable)
|
||||
;; - Bool - Read-all mode, or just read the next object?
|
||||
;; - Bool - Are we inside a comment?
|
||||
;; - Level of nested parentheses
|
||||
;; - Entry in the in-port table for this port
|
||||
;;
|
||||
;; Output: next object, or list of objects (if read-all mode)
|
||||
;;
|
||||
(define (parse fp tok toks all? comment? parens ptbl)
|
||||
(in-port:set-cnum! ptbl
|
||||
(+ 1 (in-port:get-cnum ptbl)))
|
||||
|
||||
(let ((c (if (in-port:get-buf ptbl)
|
||||
(in-port:read-buf! ptbl) ;; Already buffered
|
||||
(read-char fp))))
|
||||
;; DEBUGGING
|
||||
;(write `(DEBUG read ,tok ,c))
|
||||
;(write (newline))
|
||||
;; END DEBUG
|
||||
(cond
|
||||
((eof-object? c)
|
||||
(if (> parens 0)
|
||||
(parse-error "missing closing parenthesis"
|
||||
(in-port:get-lnum ptbl)
|
||||
(in-port:get-cnum ptbl)))
|
||||
(if all?
|
||||
(reverse (get-toks tok toks))
|
||||
(let ((last (get-toks tok toks)))
|
||||
(if (> (length last) 0)
|
||||
(car last)
|
||||
c)))) ;; EOF
|
||||
(comment?
|
||||
(if (eq? c #\newline)
|
||||
(begin
|
||||
(in-port:set-lnum! ptbl
|
||||
(+ 1 (in-port:get-lnum ptbl)))
|
||||
(in-port:set-cnum! ptbl 0)
|
||||
(parse fp '() toks all? #f parens ptbl))
|
||||
(parse fp '() toks all? #t parens ptbl)))
|
||||
((char-whitespace? c)
|
||||
(if (equal? c #\newline)
|
||||
(in-port:set-lnum! ptbl
|
||||
(+ 1 (in-port:get-lnum ptbl))))
|
||||
(if (equal? c #\newline)
|
||||
(in-port:set-cnum! ptbl 0))
|
||||
(parse/tok fp tok toks all? #f parens ptbl c))
|
||||
((eq? c #\;)
|
||||
(parse/tok fp tok toks all? #t parens ptbl c))
|
||||
((eq? c #\')
|
||||
(cond
|
||||
((and (not all?) (not (null? tok)))
|
||||
;; Reached a terminal char, read out previous token
|
||||
;; TODO: would also need to do this if previous char was
|
||||
;; not a quote!
|
||||
;; EG: 'a'b ==> (quote a) (quote b), NOT (quote (quote b))
|
||||
(in-port:set-buf! ptbl c)
|
||||
(car (add-tok (->tok tok) toks)))
|
||||
(else
|
||||
;; Read the next expression and wrap it in a quote
|
||||
(let ((sub
|
||||
(parse fp
|
||||
'()
|
||||
'()
|
||||
#f ;all?
|
||||
#f ;comment?
|
||||
0 ;parens
|
||||
ptbl)))
|
||||
(define new-toks
|
||||
(add-tok
|
||||
(list
|
||||
'quote
|
||||
sub)
|
||||
;(if (and (pair? sub) (dotted? sub))
|
||||
; (->dotted-list sub)
|
||||
; sub))
|
||||
(get-toks tok toks)))
|
||||
;; Keep going
|
||||
(if all?
|
||||
(parse fp '() new-toks all? #f parens ptbl)
|
||||
(car new-toks))))))
|
||||
((eq? c #\`)
|
||||
;; TODO: should consolidate this with above
|
||||
(cond
|
||||
((and (not all?) (not (null? tok)))
|
||||
;; Reached a terminal char, read out previous token
|
||||
(in-port:set-buf! ptbl c)
|
||||
(car (add-tok (->tok tok) toks)))
|
||||
(else
|
||||
;; Read the next expression and wrap it in a quote
|
||||
(let ((sub (parse fp '() '() #f #f 0 ptbl)))
|
||||
(define new-toks
|
||||
(add-tok
|
||||
(list 'quasiquote sub)
|
||||
(get-toks tok toks)))
|
||||
;; Keep going
|
||||
(if all?
|
||||
(parse fp '() new-toks all? #f parens ptbl)
|
||||
(car new-toks))))))
|
||||
((eq? c #\,)
|
||||
(cond
|
||||
((and (not all?) (not (null? tok)))
|
||||
;; Reached a terminal char, read out previous token
|
||||
(in-port:set-buf! ptbl c)
|
||||
(car (add-tok (->tok tok) toks)))
|
||||
(else
|
||||
;; TODO:
|
||||
; buffer must be empty now since it is only 1 char, so
|
||||
; call read-char. then:
|
||||
; - @ - unquote-splicing processing
|
||||
; - eof - error
|
||||
; - otherwise, add char back to buffer and do unquote processing
|
||||
|
||||
;; Read the next expression and wrap it in a quote
|
||||
(letrec ((sub #f)
|
||||
(next-c (read-char fp))
|
||||
(unquote-sym (if (equal? next-c #\@) 'unquote-splicing 'unquote))
|
||||
(new-toks #f))
|
||||
|
||||
;; Buffer read-ahead char, if unused
|
||||
(cond
|
||||
((eof-object? next-c)
|
||||
(parse-error "unexpected end of file"
|
||||
(in-port:get-lnum ptbl)
|
||||
(in-port:get-cnum ptbl)))
|
||||
((not (equal? next-c #\@))
|
||||
(in-port:set-buf! ptbl next-c))
|
||||
(else #f))
|
||||
|
||||
(set! sub (parse fp '() '() #f #f 0 ptbl))
|
||||
(set! new-toks
|
||||
(add-tok
|
||||
(list unquote-sym sub)
|
||||
(get-toks tok toks)))
|
||||
|
||||
;; Keep going
|
||||
(if all?
|
||||
(parse fp '() new-toks all? #f parens ptbl)
|
||||
(car new-toks))))))
|
||||
((eq? c #\()
|
||||
(cond
|
||||
((and (not all?) (not (null? tok)))
|
||||
;; Reached a terminal char, read out previous token
|
||||
(in-port:set-buf! ptbl c)
|
||||
(car (add-tok (->tok tok) toks)))
|
||||
(else
|
||||
(let ((sub ;(_cyc-read-all fp (+ parens 1)))
|
||||
(parse fp '() '() #t #f (+ parens 1) ptbl))
|
||||
(toks* (get-toks tok toks)))
|
||||
(define new-toks (add-tok
|
||||
(if (and (pair? sub) (dotted? sub))
|
||||
(->dotted-list sub)
|
||||
sub)
|
||||
toks*))
|
||||
;(write `(DEBUG incrementing paren level ,parens ,sub))
|
||||
(if all?
|
||||
(parse fp '() new-toks all? #f parens ptbl)
|
||||
(car new-toks))))))
|
||||
((eq? c #\))
|
||||
(cond
|
||||
((and (not all?) (not (null? tok)))
|
||||
;; Reached a terminal char, read out previous token
|
||||
(in-port:set-buf! ptbl c)
|
||||
(car (add-tok (->tok tok) toks)))
|
||||
((= parens 0)
|
||||
(parse-error "unexpected closing parenthesis"
|
||||
(in-port:get-lnum ptbl)
|
||||
(in-port:get-cnum ptbl)))
|
||||
(else
|
||||
(reverse (get-toks tok toks)))))
|
||||
((eq? c #\")
|
||||
(cond
|
||||
((and (not all?) (not (null? tok)))
|
||||
;; Reached a terminal char, read out previous token
|
||||
(in-port:set-buf! ptbl c)
|
||||
(car (add-tok (->tok tok) toks)))
|
||||
(else
|
||||
(let ((str (read-str fp '() ptbl))
|
||||
(toks* (get-toks tok toks)))
|
||||
(define new-toks (add-tok str toks*))
|
||||
(if all?
|
||||
(parse fp '() new-toks all? #f parens ptbl)
|
||||
(car new-toks))))))
|
||||
((eq? c #\#)
|
||||
(if (null? tok)
|
||||
;; # reader
|
||||
(let ((next-c (read-char fp)))
|
||||
(in-port:set-cnum! ptbl
|
||||
(+ 1 (in-port:get-cnum ptbl)))
|
||||
(cond
|
||||
;; Booleans
|
||||
;; Do not use add-tok below, no need to quote a bool
|
||||
((eq? #\t next-c)
|
||||
(if all?
|
||||
(parse fp '() (cons #t toks) all? #f parens ptbl)
|
||||
#t))
|
||||
((eq? #\f next-c)
|
||||
(if all?
|
||||
(parse fp '() (cons #f toks) all? #f parens ptbl)
|
||||
#f))
|
||||
;; Vector
|
||||
((eq? #\( next-c)
|
||||
(let ((sub (parse fp '() '() #t #f (+ parens 1) ptbl))
|
||||
(toks* (get-toks tok toks)))
|
||||
(define new-toks
|
||||
(add-tok
|
||||
(if (and (pair? sub) (dotted? sub))
|
||||
(parse-error
|
||||
"Invalid vector syntax" ;(->dotted-list sub)
|
||||
(in-port:get-lnum ptbl)
|
||||
(in-port:get-cnum ptbl))
|
||||
(list->vector sub))
|
||||
toks*))
|
||||
(if all?
|
||||
(parse fp '() new-toks all? #f parens ptbl)
|
||||
(car new-toks))))
|
||||
;; Character
|
||||
((eq? #\\ next-c)
|
||||
(let ((new-toks (cons (read-pound fp ptbl) toks)))
|
||||
(if all?
|
||||
(parse fp '() new-toks all? #f parens ptbl)
|
||||
(car new-toks))))
|
||||
(else
|
||||
(parse-error "Unhandled input sequence"
|
||||
(in-port:get-lnum ptbl)
|
||||
(in-port:get-cnum ptbl)))))
|
||||
;; just another char...
|
||||
(parse fp (cons c tok) toks all? #f parens ptbl)))
|
||||
(else
|
||||
(parse fp (cons c tok) toks all? #f parens ptbl)))))
|
||||
|
||||
;; Read chars past a leading #\
|
||||
(define (read-pound fp ptbl)
|
||||
(define (done raw-buf)
|
||||
(let ((buf (reverse raw-buf)))
|
||||
(cond
|
||||
((= 0 (length buf))
|
||||
(parse-error "missing character"
|
||||
(in-port:get-lnum ptbl)
|
||||
(in-port:get-cnum ptbl)))
|
||||
((= 1 (length buf))
|
||||
(car buf))
|
||||
((equal? buf '(#\a #\l #\a #\r #\m))
|
||||
(integer->char 7))
|
||||
((equal? buf '(#\b #\a #\c #\k #\s #\p #\a #\c #\e))
|
||||
(integer->char 8))
|
||||
((equal? buf '(#\d #\e #\l #\e #\t #\e))
|
||||
(integer->char 127))
|
||||
((equal? buf '(#\e #\s #\c #\a #\p #\e))
|
||||
(integer->char 27))
|
||||
((equal? buf '(#\n #\e #\w #\l #\i #\n #\e))
|
||||
(integer->char 10))
|
||||
((equal? buf '(#\n #\u #\l #\l))
|
||||
(integer->char 0))
|
||||
((equal? buf '(#\r #\e #\t #\u #\r #\n))
|
||||
(integer->char 13))
|
||||
((equal? buf '(#\s #\p #\a #\c #\e))
|
||||
(integer->char 32))
|
||||
((equal? buf '(#\t #\a #\b))
|
||||
(integer->char 9))
|
||||
(else
|
||||
(parse-error (string-append
|
||||
"unable to parse character: "
|
||||
(list->string buf))
|
||||
(in-port:get-lnum ptbl)
|
||||
(in-port:get-cnum ptbl))))))
|
||||
(define (loop buf)
|
||||
(let ((c (peek-char fp)))
|
||||
(if (or (eof-object? c)
|
||||
(char-whitespace? c)
|
||||
(and (> (length buf) 0)
|
||||
(equal? c #\))))
|
||||
(done buf)
|
||||
(loop (cons (read-char fp) buf)))))
|
||||
(loop '()))
|
||||
|
||||
(define (read-str fp buf ptbl)
|
||||
(let ((c (read-char fp)))
|
||||
(cond
|
||||
((eof-object? c)
|
||||
(parse-error "missing closing double-quote"
|
||||
(in-port:get-lnum ptbl)
|
||||
(in-port:get-cnum ptbl)))
|
||||
((equal? #\\ c)
|
||||
(read-str fp (read-str-esc fp buf ptbl) ptbl))
|
||||
((equal? #\" c)
|
||||
(list->string (reverse buf)))
|
||||
(else
|
||||
(read-str fp (cons c buf) ptbl)))))
|
||||
|
||||
;; Read an escaped character within a string
|
||||
;; The escape '\' has already been read at this point
|
||||
(define (read-str-esc fp buf ptbl)
|
||||
(let ((c (read-char fp)))
|
||||
(cond
|
||||
((eof-object? c)
|
||||
(parse-error "missing escaped character within string"
|
||||
(in-port:get-lnum ptbl)
|
||||
(in-port:get-cnum ptbl)))
|
||||
((or (equal? #\" c)
|
||||
(equal? #\\ c))
|
||||
(cons c buf))
|
||||
((equal? #\n c)
|
||||
(cons #\newline buf))
|
||||
(else
|
||||
(parse-error (string-append
|
||||
"invalid escape character ["
|
||||
(list->string (list c))
|
||||
"] in string")
|
||||
(in-port:get-lnum ptbl)
|
||||
(in-port:get-cnum ptbl))))))
|
||||
|
||||
(define (sign? c)
|
||||
(or
|
||||
(equal? c #\+)
|
||||
(equal? c #\-)))
|
||||
|
||||
;; parse-atom -> [chars] -> literal
|
||||
(define (parse-atom a)
|
||||
(cond
|
||||
((or (char-numeric? (car a))
|
||||
(and (> (length a) 1)
|
||||
(char-numeric? (cadr a))
|
||||
(sign? (car a))))
|
||||
(string->number (list->string a)))
|
||||
(else
|
||||
(string->symbol (list->string a)))))
|
||||
|
||||
;; Main lexer/parser
|
||||
(define cyc-read ;; TODO: should be (read), but that is breaking on csi 4.8.0.5
|
||||
(lambda args
|
||||
(let ((fp (if (null? args)
|
||||
(current-input-port)
|
||||
(car args))))
|
||||
(parse fp '() '() #f #f 0 (reg-port fp)))))
|
||||
|
||||
;; read-all -> port -> [objects]
|
||||
(define (read-all . args)
|
||||
(let ((fp (if (null? args)
|
||||
(current-input-port)
|
||||
(car args))))
|
||||
(define (loop fp result)
|
||||
(let ((obj (cyc-read fp)))
|
||||
(if (eof-object? obj)
|
||||
(reverse result)
|
||||
(loop fp (cons obj result)))))
|
||||
(loop fp '())))
|
||||
|
||||
;; TODO: for some reason this causes trouble in chicken 4.8. WTF??
|
||||
;; read -> port -> object
|
||||
;(define read cyc-read)
|
||||
|
||||
; ;; Test code
|
||||
; ;(let ((fp (open-input-file "tests/begin.scm")))
|
||||
; ;(let ((fp (open-input-file "tests/strings.scm")))
|
||||
; (let ((fp (open-input-file "test.scm")))
|
||||
; (let ((fp (open-input-file "tests/unit-tests.scm")))
|
||||
; (write (read-all fp)))
|
||||
;(define (repl)
|
||||
; (let ((fp (current-input-port)))
|
||||
; (write (cyc-read fp)))
|
||||
; (repl))
|
||||
;(repl)
|
||||
|
||||
|
||||
#f
|
||||
|
|
|
|||
470
scheme/read.sld
470
scheme/read.sld
|
|
@ -1,3 +1,9 @@
|
|||
;; Cyclone Scheme
|
||||
;; Copyright (c) 2014, Justin Ethier
|
||||
;; All rights reserved.
|
||||
;;
|
||||
;; This module contains the s-expression parser and supporting functions.
|
||||
;;
|
||||
(define-library (scheme read)
|
||||
(import (scheme base)
|
||||
(scheme char))
|
||||
|
|
@ -5,6 +11,466 @@
|
|||
read
|
||||
read-all
|
||||
)
|
||||
(include "parser.scm")
|
||||
(begin
|
||||
(define read cyc-read)))
|
||||
|
||||
(define read cyc-read)
|
||||
|
||||
;; Extended information for each input port
|
||||
(define *in-port-table* '())
|
||||
(define (reg-port fp)
|
||||
(let ((r (assoc fp *in-port-table*)))
|
||||
(cond
|
||||
((not r)
|
||||
;(write `(ADDED NEW ENTRY TO in port table!!))
|
||||
(set! r
|
||||
(list fp
|
||||
#f ; Buffered char, if any
|
||||
1 ; Line number
|
||||
0)) ; Char number
|
||||
(set! *in-port-table* (cons r *in-port-table*))
|
||||
r)
|
||||
(else r))))
|
||||
;; TODO: unreg-port - delete fp entry from *in-port-table*
|
||||
;; would want to do this when port is closed
|
||||
|
||||
(define (in-port:read-buf! ptbl)
|
||||
(let ((result (cadr ptbl)))
|
||||
(in-port:set-buf! ptbl #f)
|
||||
result))
|
||||
(define (in-port:get-buf ptbl) (cadr ptbl))
|
||||
(define (in-port:set-buf! ptbl buf) (set-car! (cdr ptbl) buf))
|
||||
(define (in-port:get-lnum ptbl) (caddr ptbl))
|
||||
(define (in-port:set-lnum! ptbl lnum) (set-car! (cddr ptbl) lnum))
|
||||
(define (in-port:get-cnum ptbl) (cadddr ptbl))
|
||||
(define (in-port:set-cnum! ptbl cnum) (set-car! (cdddr ptbl) cnum))
|
||||
;; END input port table
|
||||
|
||||
;; Helper functions
|
||||
(define (add-tok tok toks)
|
||||
(cons tok toks))
|
||||
|
||||
;; Get completed list of tokens
|
||||
(define (get-toks tok toks)
|
||||
(if (null? tok)
|
||||
toks
|
||||
(add-tok (->tok tok) toks)))
|
||||
|
||||
;; Add a token to the list, quoting it if necessary
|
||||
(define (->tok lst)
|
||||
(parse-atom (reverse lst)))
|
||||
|
||||
;; Did we read a dotted list
|
||||
(define (dotted? lst)
|
||||
(and (> (length lst) 2)
|
||||
(equal? (cadr (reverse lst)) (string->symbol "."))))
|
||||
|
||||
;; Convert a list read by the reader into an improper list
|
||||
(define (->dotted-list lst)
|
||||
(cond
|
||||
((null? lst) '())
|
||||
((equal? (car lst) (string->symbol "."))
|
||||
(cadr lst))
|
||||
(else
|
||||
(cons (car lst) (->dotted-list (cdr lst))))))
|
||||
|
||||
(define (parse-error msg lnum cnum)
|
||||
(error
|
||||
(string-append
|
||||
"Error (line "
|
||||
(number->string lnum)
|
||||
", char "
|
||||
(number->string cnum)
|
||||
"): "
|
||||
msg)))
|
||||
|
||||
;; Add finished token, if there is one, and continue parsing
|
||||
(define (parse/tok fp tok toks all? comment? parens ptbl curr-char)
|
||||
(cond
|
||||
((null? tok)
|
||||
(parse fp '() toks all? comment? parens ptbl))
|
||||
(all?
|
||||
(parse fp '()
|
||||
(add-tok (->tok tok) toks)
|
||||
all?
|
||||
comment?
|
||||
parens
|
||||
ptbl))
|
||||
(else
|
||||
;; Reached a terminating char, return current token and
|
||||
;; save term char for the next (read).
|
||||
;; Note: never call set-buf! if in "all?" mode, since
|
||||
;; that mode builds a list of tokens
|
||||
(in-port:set-buf! ptbl curr-char)
|
||||
;(write `(DEBUG ,tok ,ptbl))
|
||||
;(write "\n")
|
||||
(car (add-tok (->tok tok) toks)))))
|
||||
|
||||
;; Parse input from stream
|
||||
;;
|
||||
;; Input:
|
||||
;; - Port object
|
||||
;; - Current token
|
||||
;; - List of tokens read (if applicable)
|
||||
;; - Bool - Read-all mode, or just read the next object?
|
||||
;; - Bool - Are we inside a comment?
|
||||
;; - Level of nested parentheses
|
||||
;; - Entry in the in-port table for this port
|
||||
;;
|
||||
;; Output: next object, or list of objects (if read-all mode)
|
||||
;;
|
||||
(define (parse fp tok toks all? comment? parens ptbl)
|
||||
(in-port:set-cnum! ptbl
|
||||
(+ 1 (in-port:get-cnum ptbl)))
|
||||
|
||||
(let ((c (if (in-port:get-buf ptbl)
|
||||
(in-port:read-buf! ptbl) ;; Already buffered
|
||||
(read-char fp))))
|
||||
;; DEBUGGING
|
||||
;(write `(DEBUG read ,tok ,c))
|
||||
;(write (newline))
|
||||
;; END DEBUG
|
||||
(cond
|
||||
((eof-object? c)
|
||||
(if (> parens 0)
|
||||
(parse-error "missing closing parenthesis"
|
||||
(in-port:get-lnum ptbl)
|
||||
(in-port:get-cnum ptbl)))
|
||||
(if all?
|
||||
(reverse (get-toks tok toks))
|
||||
(let ((last (get-toks tok toks)))
|
||||
(if (> (length last) 0)
|
||||
(car last)
|
||||
c)))) ;; EOF
|
||||
(comment?
|
||||
(if (eq? c #\newline)
|
||||
(begin
|
||||
(in-port:set-lnum! ptbl
|
||||
(+ 1 (in-port:get-lnum ptbl)))
|
||||
(in-port:set-cnum! ptbl 0)
|
||||
(parse fp '() toks all? #f parens ptbl))
|
||||
(parse fp '() toks all? #t parens ptbl)))
|
||||
((char-whitespace? c)
|
||||
(if (equal? c #\newline)
|
||||
(in-port:set-lnum! ptbl
|
||||
(+ 1 (in-port:get-lnum ptbl))))
|
||||
(if (equal? c #\newline)
|
||||
(in-port:set-cnum! ptbl 0))
|
||||
(parse/tok fp tok toks all? #f parens ptbl c))
|
||||
((eq? c #\;)
|
||||
(parse/tok fp tok toks all? #t parens ptbl c))
|
||||
((eq? c #\')
|
||||
(cond
|
||||
((and (not all?) (not (null? tok)))
|
||||
;; Reached a terminal char, read out previous token
|
||||
;; TODO: would also need to do this if previous char was
|
||||
;; not a quote!
|
||||
;; EG: 'a'b ==> (quote a) (quote b), NOT (quote (quote b))
|
||||
(in-port:set-buf! ptbl c)
|
||||
(car (add-tok (->tok tok) toks)))
|
||||
(else
|
||||
;; Read the next expression and wrap it in a quote
|
||||
(let ((sub
|
||||
(parse fp
|
||||
'()
|
||||
'()
|
||||
#f ;all?
|
||||
#f ;comment?
|
||||
0 ;parens
|
||||
ptbl)))
|
||||
(define new-toks
|
||||
(add-tok
|
||||
(list
|
||||
'quote
|
||||
sub)
|
||||
;(if (and (pair? sub) (dotted? sub))
|
||||
; (->dotted-list sub)
|
||||
; sub))
|
||||
(get-toks tok toks)))
|
||||
;; Keep going
|
||||
(if all?
|
||||
(parse fp '() new-toks all? #f parens ptbl)
|
||||
(car new-toks))))))
|
||||
((eq? c #\`)
|
||||
;; TODO: should consolidate this with above
|
||||
(cond
|
||||
((and (not all?) (not (null? tok)))
|
||||
;; Reached a terminal char, read out previous token
|
||||
(in-port:set-buf! ptbl c)
|
||||
(car (add-tok (->tok tok) toks)))
|
||||
(else
|
||||
;; Read the next expression and wrap it in a quote
|
||||
(let ((sub (parse fp '() '() #f #f 0 ptbl)))
|
||||
(define new-toks
|
||||
(add-tok
|
||||
(list 'quasiquote sub)
|
||||
(get-toks tok toks)))
|
||||
;; Keep going
|
||||
(if all?
|
||||
(parse fp '() new-toks all? #f parens ptbl)
|
||||
(car new-toks))))))
|
||||
((eq? c #\,)
|
||||
(cond
|
||||
((and (not all?) (not (null? tok)))
|
||||
;; Reached a terminal char, read out previous token
|
||||
(in-port:set-buf! ptbl c)
|
||||
(car (add-tok (->tok tok) toks)))
|
||||
(else
|
||||
;; TODO:
|
||||
; buffer must be empty now since it is only 1 char, so
|
||||
; call read-char. then:
|
||||
; - @ - unquote-splicing processing
|
||||
; - eof - error
|
||||
; - otherwise, add char back to buffer and do unquote processing
|
||||
|
||||
;; Read the next expression and wrap it in a quote
|
||||
(letrec ((sub #f)
|
||||
(next-c (read-char fp))
|
||||
(unquote-sym (if (equal? next-c #\@) 'unquote-splicing 'unquote))
|
||||
(new-toks #f))
|
||||
|
||||
;; Buffer read-ahead char, if unused
|
||||
(cond
|
||||
((eof-object? next-c)
|
||||
(parse-error "unexpected end of file"
|
||||
(in-port:get-lnum ptbl)
|
||||
(in-port:get-cnum ptbl)))
|
||||
((not (equal? next-c #\@))
|
||||
(in-port:set-buf! ptbl next-c))
|
||||
(else #f))
|
||||
|
||||
(set! sub (parse fp '() '() #f #f 0 ptbl))
|
||||
(set! new-toks
|
||||
(add-tok
|
||||
(list unquote-sym sub)
|
||||
(get-toks tok toks)))
|
||||
|
||||
;; Keep going
|
||||
(if all?
|
||||
(parse fp '() new-toks all? #f parens ptbl)
|
||||
(car new-toks))))))
|
||||
((eq? c #\()
|
||||
(cond
|
||||
((and (not all?) (not (null? tok)))
|
||||
;; Reached a terminal char, read out previous token
|
||||
(in-port:set-buf! ptbl c)
|
||||
(car (add-tok (->tok tok) toks)))
|
||||
(else
|
||||
(let ((sub ;(_cyc-read-all fp (+ parens 1)))
|
||||
(parse fp '() '() #t #f (+ parens 1) ptbl))
|
||||
(toks* (get-toks tok toks)))
|
||||
(define new-toks (add-tok
|
||||
(if (and (pair? sub) (dotted? sub))
|
||||
(->dotted-list sub)
|
||||
sub)
|
||||
toks*))
|
||||
;(write `(DEBUG incrementing paren level ,parens ,sub))
|
||||
(if all?
|
||||
(parse fp '() new-toks all? #f parens ptbl)
|
||||
(car new-toks))))))
|
||||
((eq? c #\))
|
||||
(cond
|
||||
((and (not all?) (not (null? tok)))
|
||||
;; Reached a terminal char, read out previous token
|
||||
(in-port:set-buf! ptbl c)
|
||||
(car (add-tok (->tok tok) toks)))
|
||||
((= parens 0)
|
||||
(parse-error "unexpected closing parenthesis"
|
||||
(in-port:get-lnum ptbl)
|
||||
(in-port:get-cnum ptbl)))
|
||||
(else
|
||||
(reverse (get-toks tok toks)))))
|
||||
((eq? c #\")
|
||||
(cond
|
||||
((and (not all?) (not (null? tok)))
|
||||
;; Reached a terminal char, read out previous token
|
||||
(in-port:set-buf! ptbl c)
|
||||
(car (add-tok (->tok tok) toks)))
|
||||
(else
|
||||
(let ((str (read-str fp '() ptbl))
|
||||
(toks* (get-toks tok toks)))
|
||||
(define new-toks (add-tok str toks*))
|
||||
(if all?
|
||||
(parse fp '() new-toks all? #f parens ptbl)
|
||||
(car new-toks))))))
|
||||
((eq? c #\#)
|
||||
(if (null? tok)
|
||||
;; # reader
|
||||
(let ((next-c (read-char fp)))
|
||||
(in-port:set-cnum! ptbl
|
||||
(+ 1 (in-port:get-cnum ptbl)))
|
||||
(cond
|
||||
;; Booleans
|
||||
;; Do not use add-tok below, no need to quote a bool
|
||||
((eq? #\t next-c)
|
||||
(if all?
|
||||
(parse fp '() (cons #t toks) all? #f parens ptbl)
|
||||
#t))
|
||||
((eq? #\f next-c)
|
||||
(if all?
|
||||
(parse fp '() (cons #f toks) all? #f parens ptbl)
|
||||
#f))
|
||||
;; Vector
|
||||
((eq? #\( next-c)
|
||||
(let ((sub (parse fp '() '() #t #f (+ parens 1) ptbl))
|
||||
(toks* (get-toks tok toks)))
|
||||
(define new-toks
|
||||
(add-tok
|
||||
(if (and (pair? sub) (dotted? sub))
|
||||
(parse-error
|
||||
"Invalid vector syntax" ;(->dotted-list sub)
|
||||
(in-port:get-lnum ptbl)
|
||||
(in-port:get-cnum ptbl))
|
||||
(list->vector sub))
|
||||
toks*))
|
||||
(if all?
|
||||
(parse fp '() new-toks all? #f parens ptbl)
|
||||
(car new-toks))))
|
||||
;; Character
|
||||
((eq? #\\ next-c)
|
||||
(let ((new-toks (cons (read-pound fp ptbl) toks)))
|
||||
(if all?
|
||||
(parse fp '() new-toks all? #f parens ptbl)
|
||||
(car new-toks))))
|
||||
(else
|
||||
(parse-error "Unhandled input sequence"
|
||||
(in-port:get-lnum ptbl)
|
||||
(in-port:get-cnum ptbl)))))
|
||||
;; just another char...
|
||||
(parse fp (cons c tok) toks all? #f parens ptbl)))
|
||||
(else
|
||||
(parse fp (cons c tok) toks all? #f parens ptbl)))))
|
||||
|
||||
;; Read chars past a leading #\
|
||||
(define (read-pound fp ptbl)
|
||||
(define (done raw-buf)
|
||||
(let ((buf (reverse raw-buf)))
|
||||
(cond
|
||||
((= 0 (length buf))
|
||||
(parse-error "missing character"
|
||||
(in-port:get-lnum ptbl)
|
||||
(in-port:get-cnum ptbl)))
|
||||
((= 1 (length buf))
|
||||
(car buf))
|
||||
((equal? buf '(#\a #\l #\a #\r #\m))
|
||||
(integer->char 7))
|
||||
((equal? buf '(#\b #\a #\c #\k #\s #\p #\a #\c #\e))
|
||||
(integer->char 8))
|
||||
((equal? buf '(#\d #\e #\l #\e #\t #\e))
|
||||
(integer->char 127))
|
||||
((equal? buf '(#\e #\s #\c #\a #\p #\e))
|
||||
(integer->char 27))
|
||||
((equal? buf '(#\n #\e #\w #\l #\i #\n #\e))
|
||||
(integer->char 10))
|
||||
((equal? buf '(#\n #\u #\l #\l))
|
||||
(integer->char 0))
|
||||
((equal? buf '(#\r #\e #\t #\u #\r #\n))
|
||||
(integer->char 13))
|
||||
((equal? buf '(#\s #\p #\a #\c #\e))
|
||||
(integer->char 32))
|
||||
((equal? buf '(#\t #\a #\b))
|
||||
(integer->char 9))
|
||||
(else
|
||||
(parse-error (string-append
|
||||
"unable to parse character: "
|
||||
(list->string buf))
|
||||
(in-port:get-lnum ptbl)
|
||||
(in-port:get-cnum ptbl))))))
|
||||
(define (loop buf)
|
||||
(let ((c (peek-char fp)))
|
||||
(if (or (eof-object? c)
|
||||
(char-whitespace? c)
|
||||
(and (> (length buf) 0)
|
||||
(equal? c #\))))
|
||||
(done buf)
|
||||
(loop (cons (read-char fp) buf)))))
|
||||
(loop '()))
|
||||
|
||||
(define (read-str fp buf ptbl)
|
||||
(let ((c (read-char fp)))
|
||||
(cond
|
||||
((eof-object? c)
|
||||
(parse-error "missing closing double-quote"
|
||||
(in-port:get-lnum ptbl)
|
||||
(in-port:get-cnum ptbl)))
|
||||
((equal? #\\ c)
|
||||
(read-str fp (read-str-esc fp buf ptbl) ptbl))
|
||||
((equal? #\" c)
|
||||
(list->string (reverse buf)))
|
||||
(else
|
||||
(read-str fp (cons c buf) ptbl)))))
|
||||
|
||||
;; Read an escaped character within a string
|
||||
;; The escape '\' has already been read at this point
|
||||
(define (read-str-esc fp buf ptbl)
|
||||
(let ((c (read-char fp)))
|
||||
(cond
|
||||
((eof-object? c)
|
||||
(parse-error "missing escaped character within string"
|
||||
(in-port:get-lnum ptbl)
|
||||
(in-port:get-cnum ptbl)))
|
||||
((or (equal? #\" c)
|
||||
(equal? #\\ c))
|
||||
(cons c buf))
|
||||
((equal? #\n c)
|
||||
(cons #\newline buf))
|
||||
(else
|
||||
(parse-error (string-append
|
||||
"invalid escape character ["
|
||||
(list->string (list c))
|
||||
"] in string")
|
||||
(in-port:get-lnum ptbl)
|
||||
(in-port:get-cnum ptbl))))))
|
||||
|
||||
(define (sign? c)
|
||||
(or
|
||||
(equal? c #\+)
|
||||
(equal? c #\-)))
|
||||
|
||||
;; parse-atom -> [chars] -> literal
|
||||
(define (parse-atom a)
|
||||
(cond
|
||||
((or (char-numeric? (car a))
|
||||
(and (> (length a) 1)
|
||||
(char-numeric? (cadr a))
|
||||
(sign? (car a))))
|
||||
(string->number (list->string a)))
|
||||
(else
|
||||
(string->symbol (list->string a)))))
|
||||
|
||||
;; Main lexer/parser
|
||||
(define cyc-read ;; TODO: should be (read), but that is breaking on csi 4.8.0.5
|
||||
(lambda args
|
||||
(let ((fp (if (null? args)
|
||||
(current-input-port)
|
||||
(car args))))
|
||||
(parse fp '() '() #f #f 0 (reg-port fp)))))
|
||||
|
||||
;; read-all -> port -> [objects]
|
||||
(define (read-all . args)
|
||||
(let ((fp (if (null? args)
|
||||
(current-input-port)
|
||||
(car args))))
|
||||
(define (loop fp result)
|
||||
(let ((obj (cyc-read fp)))
|
||||
(if (eof-object? obj)
|
||||
(reverse result)
|
||||
(loop fp (cons obj result)))))
|
||||
(loop fp '())))
|
||||
|
||||
;; TODO: for some reason this causes trouble in chicken 4.8. WTF??
|
||||
;; read -> port -> object
|
||||
;(define read cyc-read)
|
||||
|
||||
; ;; Test code
|
||||
; ;(let ((fp (open-input-file "tests/begin.scm")))
|
||||
; ;(let ((fp (open-input-file "tests/strings.scm")))
|
||||
; (let ((fp (open-input-file "test.scm")))
|
||||
; (let ((fp (open-input-file "tests/unit-tests.scm")))
|
||||
; (write (read-all fp)))
|
||||
;(define (repl)
|
||||
; (let ((fp (current-input-port)))
|
||||
; (write (cyc-read fp)))
|
||||
; (repl))
|
||||
;(repl)
|
||||
|
||||
))
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue