(module schemelink mzscheme
(require (lib "mred.ss" "mred")
"link.ss")
(define (expr->string v)
(let ([port (open-output-string)])
(write v port)
(get-output-string port)))
(define (string->expr s)
(with-handlers (((lambda (x) #t)
(lambda (x)
(input-type-error "Read from string error."))))
(let* ((port (open-input-string s))
(e (read port)))
(if (eof-object? (read port))
e
(input-type-error "More than one expression in the string.")))))
(define (hash-table-exist? table key)
(let/ec r
(hash-table-get table key (lambda () (r #f)))
#t))
(define (vector-for-each f vec)
(do ((len (vector-length vec))
(i 0 (add1 i)))
((= i len))
(f (vector-ref vec i))))
(define (vector-map f vec)
(let* ((len (vector-length vec))
(new-vec (make-vector len)))
(do ((i 0 (add1 i)))
((= i len) new-vec)
(vector-set! new-vec i
(f (vector-ref vec i))))))
(define (my-make-vector n f)
(do ((vec (make-vector n))
(i 0 (add1 i)))
((= i n) vec)
(vector-set! vec i (f))))
(define (vector-every pred? vec)
(let loop ((i (sub1 (vector-length vec))))
(cond ((negative? i)
#t)
((pred? (vector-ref vec i))
(loop (sub1 i)))
(else
#f))))
(define (simple? exp)
(or (number? exp)
(symbol? exp)
(null? exp)
(char? exp)
(keyword? exp)
(void? exp)
(boolean? exp)
(eof-object? exp)))
(define-struct tag (num exp))
(define-struct ref (num))
(define-struct hash (assoc-list eq))
(define (tagify exp)
(define num 0)
(define table (make-hash-table 'weak))
(define (tag-help1 exp)
(if (simple? exp)
exp
(case (hash-table-get table exp (lambda () 'unknow))
((unknow)
(hash-table-put! table exp #f)
(cond ((box? exp)
(tag-help1 (unbox exp)))
((pair? exp)
(tag-help1 (car exp))
(tag-help1 (cdr exp)))
((vector? exp)
(vector-for-each tag-help1 exp))
((and (hash-table? exp)
(print-hash-table))
(hash-table-for-each (lambda (key val)
(tag-help1 key)
(tag-help1 val))
exp))))
((#f)
(hash-table-put! table exp #t)))))
(define (tag-help2 exp)
(if (simple? exp)
exp
(let ((v (hash-table-get table exp)))
(cond ((not v)
(tag-help3 exp))
((eq? v #t)
(hash-table-put! table exp num)
(set! num (add1 num))
(make-tag (hash-table-get table exp) (tag-help3 exp)))
(else
(make-ref v))))))
(define (tag-help3 exp)
(cond ((box? exp)
(box (tag-help2 (unbox exp))))
((pair? exp)
(cons (tag-help2 (car exp))
(tag-help2 (cdr exp))))
((vector? exp)
(vector-map tag-help2 exp))
((and (hash-table? exp)
(print-hash-table))
(make-hash (hash-table-map exp
(lambda (key val)
(cons (tag-help2 key)
(tag-help2 val))))
(hash-table? exp 'equal)))
(else
exp)))
(tag-help1 exp)
(tag-help2 exp))
(define (untag exp)
(define table (make-hash-table))
(define (untag-help exp k)
(cond ((tag? exp)
(if (hash-table-exist? table (tag-num exp))
(input-type-error "Multiple tag number."))
(untag-help (tag-exp exp)
(lambda (v)
(hash-table-put! table (tag-num exp) v)
(k v))))
((ref? exp)
(k (hash-table-get table (ref-num exp)
(lambda () (input-type-error "Illegal reference number.")))))
((box? exp)
(let ((t (box 'undefined)))
(k t)
(set-box! t (untag-help (unbox exp) values))
t))
((pair? exp)
(let ((t (cons 'undefined 'undefined)))
(k t)
(set-car! t (untag-help (car exp) values))
(set-cdr! t (untag-help (cdr exp) values))
t))
((vector? exp)
(let* ((len (vector-length exp))
(t (make-vector len)))
(k t)
(do ((i 0 (add1 i)))
((= i len) t)
(vector-set! t i
(untag-help (vector-ref exp i) values)))))
((hash? exp)
(let ((t (if (hash-eq exp)
(make-hash-table 'equal)
(make-hash-table))))
(k t)
(for-each (lambda (v)
(hash-table-put! t (car v) (cdr v)))
(untag-help (hash-assoc-list exp) values))
(set-immutable! t)
t))
(else
(k exp))))
(untag-help exp values))
(define (uncirculate exp)
(uncirculate-help exp (make-hash-table 'weak)))
(define (uncirculate-help exp table)
(define num 0)
(cond ((hash-table-get table exp (lambda () #f))
=> (lambda (i)
(if (number? i)
(make-ref i)
(begin0
(make-ref num)
(hash-table-put! table exp num)
(set! num (add1 num))))))
((box? exp)
(hash-table-put! table exp #t)
(let* ((content (uncirculate-help (unbox exp) table))
(i (hash-table-get table exp)))
(hash-table-remove! table exp)
(if (number? i)
(make-tag i (box content))
(box content))))
((pair? exp)
(hash-table-put! table exp #t)
(let* ((kar (uncirculate-help (car exp) table))
(kdr (uncirculate-help (cdr exp) table))
(i (hash-table-get table exp)))
(hash-table-remove! table exp)
(if (number? i)
(make-tag i (cons kar kdr))
(cons kar kdr))))
((vector? exp)
(hash-table-put! table exp #t)
(let* ((v (vector-map (lambda (e) (uncirculate-help e table)) exp))
(i (hash-table-get table exp)))
(hash-table-remove! table exp)
(if (number? i)
(make-tag i v)
v)))
((and (hash-table? exp)
(print-hash-table))
(hash-table-put! table exp #t)
(let* ((assoc-list (uncirculate-help (hash-table-map exp cons) table))
(i (hash-table-get table exp)))
(hash-table-remove! table exp)
(if (number? i)
(make-tag i (make-hash assoc-list (hash-table? exp 'equal)))
(make-hash assoc-list (hash-table? exp 'equal)))))
(else
exp)))
(define (MathMessage n t m)
(MathPutFunction 'EvaluatePacket 1)
(MathPutFunction 'Message n)
(MathPutFunction 'MessageName 2)
(MathPutCharSymbol 'Eval)
(MathPutByteString t)
(m)
(MathNextPacket)
(MathNewPacket)
(MathPutCharSymbol '$Failed))
(define (input-type-error s)
(MathNewPacket)
(MathMessage 2 #"inputtype"
(lambda () (MathPutString s)))
(abort-current-continuation (default-continuation-prompt-tag)))
(define (MathGet)
(case (MathGetNext)
((0) (let ((ErrorMessage (MathErrorMessage)))
(MathClearError)
(MathNewPacket)
(MathMessage 2 #"mlink"
(lambda () (MathPutByteString ErrorMessage)))
(abort-current-continuation (default-continuation-prompt-tag))))
((70) (let ((n (MathGetArgCount))
(Head (MathGet)))
(case Head
((List)
(if (zero? n)
'()
(let ((lst (list (MathGet))))
(do ((p lst (cdr p))
(i (sub1 n) (sub1 i)))
((zero? i) lst)
(set-cdr! p (list (MathGet)))))))
((Rational)
(unless (= n 2)
(input-type-error "Illegal Rational."))
(let* ((n (MathGet))
(d (MathGet)))
(unless (and (integer? n)
(integer? d))
(input-type-error "Illegal Rational."))
(/ n d)))
((Complex)
(unless (= n 2)
(input-type-error "Illegal Complex."))
(let* ((r (MathGet))
(i (MathGet)))
(unless (and (real? r)
(real? i))
(input-type-error "Illegal Complex."))
(make-rectangular r i)))
((DirectedInfinity)
(unless (= n 1)
(input-type-error "Illegal DirectedInfinity."))
(case (MathGet)
((1) +inf.0)
((-1) -inf.0)
(else (input-type-error "Illegal DirectedInfinity."))))
((SchemeImproperList)
(if (< n 2)
(input-type-error "ImproperList must contain at least 2 elements."))
(unless (read-accept-dot)
(input-type-error "Illegal use of dot."))
(let ((lst (list (MathGet))))
(do ((p lst (cdr p))
(i (- n 2) (sub1 i)))
((zero? i) (set-cdr! p (MathGet)) lst)
(set-cdr! p (list (MathGet))))))
((SchemeSymbol)
(unless (and (= n 1)
(= (MathGetNext) 34))
(input-type-error "Symbol must contain a string."))
(string->symbol (MathGetString)))
((SchemeVector)
(my-make-vector n MathGet))
((SchemeBox)
(unless (and (read-accept-box)
(= n 1))
(input-type-error "Bad box."))
(box (MathGet)))
((SchemeChar)
(unless (and (= n 1)
(= (MathGetNext) 34))
(input-type-error "Char must contain a string."))
(let ((s (MathGetString)))
(unless (= (string-length s) 1)
(input-type-error "Char must contain a string of length 1."))
(string-ref s 0)))
((SchemeBytes)
(unless (and (= n 1)
(= (MathGetNext) 34))
(input-type-error "Bytes must contain a string."))
(MathGetByteString))
((SchemeTag)
(unless (and (read-accept-graph)
(= n 2)
(= (MathGetNext) 43))
(input-type-error "Bad Tag."))
(make-tag (MathGetInteger)
(MathGet)))
((SchemeReference)
(unless (and (read-accept-graph)
(= n 1)
(= (MathGetNext) 43))
(input-type-error "Bad Reference."))
(make-ref (MathGetInteger)))
((SchemeHashTable)
(unless (= n 1)
(input-type-error "HashTable must contain an assoc list."))
(make-hash (MathGet) #t))
((SchemeHashTableEq)
(unless (= n 1)
(input-type-error "HashTableEq must contain an assoc list."))
(make-hash (MathGet) #f))
((SchemeRegExp)
(unless (= n 1)
(input-type-error "RegExp must contain one string/bytes."))
(let ((s (MathGet)))
(cond ((string? s)
(regexp s))
((bytes? s)
(byte-regexp s))
(else
(input-type-error "RegExp must contain one string/bytes.")))))
((SchemePRegExp)
(unless (= n 1)
(input-type-error "PRegExp must contain one string/bytes."))
(let ((s (MathGet)))
(cond ((string? s)
(pregexp s))
((bytes? s)
(byte-pregexp s))
(else
(input-type-error "PRegExp must contain one string/bytes.")))))
((SchemeKeyword)
(unless (and (= n 1)
(= (MathGetNext) 34))
(input-type-error "Keyword must contain a string."))
(string->keyword (MathGetString)))
((SchemeExpression)
(unless (and (= n 1)
(= (MathGetNext) 34))
(input-type-error "SchemeExpression must contain one S-exp as a string."))
(string->expr (MathGetString)))
(else
(let ((lst (list Head)))
(do ((p lst (cdr p))
(i n (sub1 i)))
((zero? i) lst)
(set-cdr! p (list (MathGet)))))))))
((35) (let ((sym (MathGetSymbol)))
(case sym
((True) #t)
((False) #f)
((Null) (void))
((Indeterminate) +nan.0)
(else sym))))
((43) (string->number (bytes->string/latin-1 (MathGetByteString))))
((42) (string->number (bytes->string/latin-1 (MathGetCharString))))
((34) (MathGetString))))
(define (my-length lst acc)
(cond ((null? lst)
acc)
((pair? lst)
(my-length (cdr lst) (add1 acc)))
(else
(- -1 acc))))
(define (improper-for-each f lst)
(cond ((pair? lst)
(f (car lst))
(improper-for-each f (cdr lst)))
(else
(f lst))))
(define (MathPutInteger num)
(MathPutNext 43)
(MathPutByteString (string->bytes/latin-1 (number->string num))))
(define (MathPutNumber num)
(cond ((and (integer? num)
(exact? num))
(MathPutInteger num))
((and (rational? num)
(exact? num))
(MathPutFunction 'Rational 2)
(MathPutInteger (numerator num))
(MathPutInteger (denominator num)))
((real? num)
(MathPutReal num))
(else
(MathPutFunction 'Complex 2)
(MathPutNumber (real-part num))
(MathPutNumber (imag-part num)))))
(define (MathPutSymbol sym)
(let* ((str (symbol->string sym))
(lst (string->list str)))
(if (and (not (null? lst))
(or (char-alphabetic? (car lst))
(char=? (car lst) #\$))
(andmap (lambda (c)
(or (char-alphabetic? c)
(char-numeric? c)))
(cdr lst)))
(MathPutNext 35)
(MathPutFunction 'SchemeSymbol 1))
(MathPutString str)))
(define (MathPut exp)
(cond ((pair? exp)
(let ((len (my-length exp 0)))
(cond ((positive? len)
(MathPutFunction 'List len)
(for-each MathPut exp))
(else
(MathPutFunction 'SchemeImproperList (- len))
(improper-for-each MathPut exp)))))
((symbol? exp)
(MathPutSymbol exp))
((boolean? exp)
(MathPutCharSymbol (if exp 'True 'False)))
((number? exp)
(MathPutNumber exp))
((string? exp)
(MathPutString exp))
((bytes? exp)
(MathPutFunction 'SchemeBytes 1)
(MathPutByteString exp))
((and (box? exp)
(print-box))
(MathPutFunction 'SchemeBox 1)
(MathPut (unbox exp)))
((char? exp)
(MathPutFunction 'SchemeChar 1)
(MathPutString (make-string 1 exp)))
((vector? exp)
(MathPutFunction 'SchemeVector (vector-length exp))
(vector-for-each MathPut exp))
((null? exp)
(MathPutFunction 'List 0))
((void? exp)
(MathPutCharSymbol 'Null))
((tag? exp)
(MathPutFunction 'SchemeTag 2)
(MathPutInteger (tag-num exp))
(MathPut (tag-exp exp)))
((ref? exp)
(MathPutFunction 'SchemeReference 1)
(MathPutInteger (ref-num exp)))
((hash? exp)
(MathPutFunction (if (hash-eq exp) 'SchemeHashTable 'SchemeHashTableEq) 1)
(MathPut (hash-assoc-list exp)))
((regexp? exp)
(MathPutFunction 'SchemeRegExp 1)
(MathPutString (object-name exp)))
((byte-regexp? exp)
(MathPutFunction 'SchemeRegExp 1)
(MathPutByteString (object-name exp)))
((pregexp? exp)
(MathPutFunction 'SchemePRegExp 1)
(MathPutString (object-name exp)))
((byte-pregexp? exp)
(MathPutFunction 'SchemePRegExp 1)
(MathPutByteString (object-name exp)))
((keyword? exp)
(MathPutFunction 'SchemeKeyword 1)
(MathPutString (keyword->string exp)))
(else
(MathPutFunction 'SchemeExpression 1)
(MathPutString (expr->string exp)))))
(define (MathGetShared)
(if (read-accept-graph)
(untag (MathGet))
(MathGet)))
(define (MathPutShared exp)
(MathPut
((if (print-graph)
tagify
uncirculate)
exp)))
(define ns (make-namespace-with-mred 'initial))
(define es (make-eventspace))
(MathMain (vector-map string->bytes/locale (current-command-line-arguments)))
(define (MathRead)
(MathReady)
(if (= (MathNextPacket) 7)
(begin (MathGetInteger)
(MathGetShared))
'(exit)))
(define main-thread
(current-thread))
(thread
(lambda ()
(let lp ()
(sleep)
(if (MathAbort)
(break-thread main-thread))
(lp))))
(let repl-loop ()
(call-with-continuation-prompt
(lambda ()
(let ([v (MathRead)])
(call-with-values
(lambda ()
(call-with-continuation-prompt
(lambda ()
(let ([w (cons '#%top-interaction v)])
(parameterize ((current-eventspace es))
(eval w ns))))
(default-continuation-prompt-tag)
(lambda args '$Failed)))
(case-lambda
((single)
(MathPutShared single))
(multiple
(MathMessage 1 #"multiplereturn" void))))
(abort-current-continuation (default-continuation-prompt-tag))))
(default-continuation-prompt-tag)
(lambda args (repl-loop)))))
![[logo]](/logo.png){kind=logo}