292 lines
8.4 KiB
Scheme
292 lines
8.4 KiB
Scheme
|
;;; compat.ss
|
||
|
|
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||
|
|
;;;
|
||
|
|
;;; Licensed under the Apache License, Version 2.0 (the "License");
|
||
|
|
;;; you may not use this file except in compliance with the License.
|
||
|
|
;;; You may obtain a copy of the License at
|
||
|
|
;;;
|
||
|
|
;;; http://www.apache.org/licenses/LICENSE-2.0
|
||
|
|
;;;
|
||
|
|
;;; Unless required by applicable law or agreed to in writing, software
|
||
|
|
;;; distributed under the License is distributed on an "AS IS" BASIS,
|
||
|
|
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||
|
|
;;; See the License for the specific language governing permissions and
|
||
|
|
;;; limitations under the License.
|
||
|
|
|
||
|
|
;;; miscellaneous definitions to make this version compatible
|
||
|
|
;;; (where possible) with previous versions...and to a small extent with
|
||
|
|
;;; other versions of scheme and other dialects of lisp as well
|
||
|
|
|
||
|
|
;;; use only those items that you need to avoid introducing accidental
|
||
|
|
;;; dependencies on other items.
|
||
|
|
|
||
|
|
(define-syntax define!
|
||
|
|
(syntax-rules ()
|
||
|
|
((_ x v) (begin (set! x v) 'x))))
|
||
|
|
|
||
|
|
(define-syntax defrec!
|
||
|
|
(syntax-rules ()
|
||
|
|
((_ x v) (define! x (rec x v)))))
|
||
|
|
|
||
|
|
(define-syntax begin0
|
||
|
|
(syntax-rules ()
|
||
|
|
((_ x y ...) (let ((t x)) y ... t))))
|
||
|
|
|
||
|
|
(define-syntax recur
|
||
|
|
(syntax-rules ()
|
||
|
|
((_ f ((i v) ...) e1 e2 ...)
|
||
|
|
(let f ((i v) ...) e1 e2 ...))))
|
||
|
|
|
||
|
|
(define-syntax trace-recur
|
||
|
|
(syntax-rules ()
|
||
|
|
((_ f ((x v) ...) e1 e2 ...)
|
||
|
|
(trace-let f ((x v) ...) e1 e2 ...))))
|
||
|
|
|
||
|
|
(define swap-box!
|
||
|
|
(lambda (b v)
|
||
|
|
(if (box? b)
|
||
|
|
(let ((x (unbox b))) (set-box! b v) x)
|
||
|
|
(error 'swap-box! "~s is not a box" b))))
|
||
|
|
|
||
|
|
(define cull
|
||
|
|
(lambda (pred? ls)
|
||
|
|
(unless (procedure? pred?)
|
||
|
|
(error 'cull "~s is not a procedure" pred?))
|
||
|
|
(let f ([l ls])
|
||
|
|
(cond
|
||
|
|
[(pair? l)
|
||
|
|
(if (pred? (car l))
|
||
|
|
(cons (car l) (f (cdr l)))
|
||
|
|
(f (cdr l)))]
|
||
|
|
[(null? l) '()]
|
||
|
|
[else (error 'cull "~s is not a proper list" ls)]))))
|
||
|
|
|
||
|
|
(define cull! cull)
|
||
|
|
|
||
|
|
(define mem
|
||
|
|
(lambda (pred? ls)
|
||
|
|
(unless (procedure? pred?)
|
||
|
|
(error 'mem "~s is not a procedure" pred?))
|
||
|
|
(let f ([l ls])
|
||
|
|
(cond
|
||
|
|
[(pair? l) (if (pred? (car l)) l (f (cdr l)))]
|
||
|
|
[(null? l) #f]
|
||
|
|
[else (error 'mem "~s is not a proper list" ls)]))))
|
||
|
|
|
||
|
|
(define rem
|
||
|
|
(lambda (pred? ls)
|
||
|
|
(unless (procedure? pred?)
|
||
|
|
(error 'rem "~s is not a procedure" pred?))
|
||
|
|
(let f ([l ls])
|
||
|
|
(cond
|
||
|
|
[(pair? l)
|
||
|
|
(if (pred? (car l))
|
||
|
|
(f (cdr l))
|
||
|
|
(cons (car l) (f (cdr l))))]
|
||
|
|
[(null? l) '()]
|
||
|
|
[else (error 'rem "~s is not a proper list" ls)]))))
|
||
|
|
|
||
|
|
(define rem!
|
||
|
|
(lambda (pred? ls)
|
||
|
|
(unless (procedure? pred?)
|
||
|
|
(error 'rem! "~s is not a procedure" pred?))
|
||
|
|
(let f ([l ls])
|
||
|
|
(cond
|
||
|
|
[(pair? l)
|
||
|
|
(if (pred? (car l))
|
||
|
|
(f (cdr l))
|
||
|
|
(begin
|
||
|
|
(set-cdr! l (f (cdr l)))
|
||
|
|
l))]
|
||
|
|
[(null? l) '()]
|
||
|
|
[else (error 'rem! "~s is not a proper list" ls)]))))
|
||
|
|
|
||
|
|
(define ass
|
||
|
|
(lambda (pred? alist)
|
||
|
|
(unless (procedure? pred?)
|
||
|
|
(error 'ass "~s is not a procedure" pred?))
|
||
|
|
(let loop ([l alist])
|
||
|
|
(cond
|
||
|
|
[(and (pair? l) (pair? (car l)))
|
||
|
|
(if (pred? (caar l))
|
||
|
|
(car l)
|
||
|
|
(loop (cdr l)))]
|
||
|
|
[(null? l) #f]
|
||
|
|
[else (error 'ass "improperly formed alist ~s" alist)]))))
|
||
|
|
|
||
|
|
(define prompt-read
|
||
|
|
(lambda (fmt . args)
|
||
|
|
(apply printf fmt args)
|
||
|
|
(read)))
|
||
|
|
|
||
|
|
(define tree-copy
|
||
|
|
(rec tree-copy
|
||
|
|
(lambda (x)
|
||
|
|
(if (pair? x)
|
||
|
|
(cons (tree-copy (car x)) (tree-copy (cdr x)))
|
||
|
|
x))))
|
||
|
|
|
||
|
|
(define ferror error)
|
||
|
|
|
||
|
|
(define *most-negative-short-integer* (most-negative-fixnum))
|
||
|
|
(define *most-positive-short-integer* (most-positive-fixnum))
|
||
|
|
|
||
|
|
(define *most-negative-fixnum* (most-negative-fixnum))
|
||
|
|
(define *most-positive-fixnum* (most-positive-fixnum))
|
||
|
|
|
||
|
|
(define *eof* (read-char (open-input-string "")))
|
||
|
|
|
||
|
|
(define short-integer? fixnum?)
|
||
|
|
(define big-integer? bignum?)
|
||
|
|
(define ratio? ratnum?)
|
||
|
|
(define float? flonum?)
|
||
|
|
|
||
|
|
(define bound? top-level-bound?)
|
||
|
|
(define global-value top-level-value)
|
||
|
|
(define set-global-value! set-top-level-value!)
|
||
|
|
(define define-global-value define-top-level-value)
|
||
|
|
(define symbol-value top-level-value)
|
||
|
|
(define set-symbol-value! set-top-level-value!)
|
||
|
|
|
||
|
|
(define put putprop)
|
||
|
|
(define get getprop)
|
||
|
|
|
||
|
|
(define copy-list list-copy)
|
||
|
|
(define copy-tree tree-copy)
|
||
|
|
(define copy-string string-copy)
|
||
|
|
(define copy-vector vector-copy)
|
||
|
|
|
||
|
|
(define intern string->symbol)
|
||
|
|
(define symbol-name symbol->string)
|
||
|
|
(define string->uninterned-symbol gensym)
|
||
|
|
(define make-temp-symbol string->uninterned-symbol)
|
||
|
|
(define uninterned-symbol? gensym?)
|
||
|
|
(define temp-symbol? uninterned-symbol?)
|
||
|
|
|
||
|
|
(define compile-eval compile)
|
||
|
|
|
||
|
|
(define closure? procedure?)
|
||
|
|
|
||
|
|
(define =? =)
|
||
|
|
(define <? <)
|
||
|
|
(define >? >)
|
||
|
|
(define <=? <=)
|
||
|
|
(define >=? >=)
|
||
|
|
|
||
|
|
(define float exact->inexact)
|
||
|
|
(define rational inexact->exact)
|
||
|
|
|
||
|
|
(define char-equal? char=?)
|
||
|
|
(define char-less? char<?)
|
||
|
|
(define string-equal? string=?)
|
||
|
|
(define string-less? string<?)
|
||
|
|
|
||
|
|
; following defn conflicts with new r6rs mod
|
||
|
|
#;(define mod modulo)
|
||
|
|
|
||
|
|
(define flush-output flush-output-port)
|
||
|
|
(define clear-output clear-output-port)
|
||
|
|
(define clear-input clear-input-port)
|
||
|
|
|
||
|
|
(define mapcar map)
|
||
|
|
(define mapc for-each)
|
||
|
|
(define true #t)
|
||
|
|
(define false #f)
|
||
|
|
(define t #t)
|
||
|
|
(define nil '())
|
||
|
|
|
||
|
|
(define macro-expand expand)
|
||
|
|
|
||
|
|
;;; old macro and structure definition
|
||
|
|
|
||
|
|
;;; thanks to Michael Lenaghan (MichaelL@frogware.com) for suggesting
|
||
|
|
;;; various improvements.
|
||
|
|
(define-syntax define-macro!
|
||
|
|
(lambda (x)
|
||
|
|
(syntax-case x ()
|
||
|
|
[(k (name arg1 ... . args)
|
||
|
|
form1
|
||
|
|
form2
|
||
|
|
...)
|
||
|
|
#'(k name (arg1 ... . args)
|
||
|
|
form1
|
||
|
|
form2
|
||
|
|
...)]
|
||
|
|
[(k (name arg1 arg2 ...)
|
||
|
|
form1
|
||
|
|
form2
|
||
|
|
...)
|
||
|
|
#'(k name (arg1 arg2 ...)
|
||
|
|
form1
|
||
|
|
form2
|
||
|
|
...)]
|
||
|
|
[(k name args . forms)
|
||
|
|
(identifier? #'name)
|
||
|
|
(letrec ((add-car
|
||
|
|
(lambda (access)
|
||
|
|
(case (car access)
|
||
|
|
((cdr) `(cadr ,@(cdr access)))
|
||
|
|
((cadr) `(caadr ,@(cdr access)))
|
||
|
|
((cddr) `(caddr ,@(cdr access)))
|
||
|
|
((cdddr) `(cadddr ,@(cdr access)))
|
||
|
|
(else `(car ,access)))))
|
||
|
|
(add-cdr
|
||
|
|
(lambda (access)
|
||
|
|
(case (car access)
|
||
|
|
((cdr) `(cddr ,@(cdr access)))
|
||
|
|
((cadr) `(cdadr ,@(cdr access)))
|
||
|
|
((cddr) `(cdddr ,@(cdr access)))
|
||
|
|
((cdddr) `(cddddr ,@(cdr access)))
|
||
|
|
(else `(cdr ,access)))))
|
||
|
|
(parse
|
||
|
|
(lambda (l access)
|
||
|
|
(cond
|
||
|
|
((null? l) '())
|
||
|
|
((symbol? l) `((,l ,access)))
|
||
|
|
((pair? l)
|
||
|
|
(append!
|
||
|
|
(parse (car l) (add-car access))
|
||
|
|
(parse (cdr l) (add-cdr access))))
|
||
|
|
(else
|
||
|
|
(syntax-error #'args
|
||
|
|
(format "invalid ~s parameter syntax" (datum k))))))))
|
||
|
|
(with-syntax ((proc (datum->syntax-object #'k
|
||
|
|
(let ((g (gensym)))
|
||
|
|
`(lambda (,g)
|
||
|
|
(let ,(parse (datum args) `(cdr ,g))
|
||
|
|
,@(datum forms)))))))
|
||
|
|
#'(define-syntax name
|
||
|
|
(lambda (x)
|
||
|
|
(syntax-case x ()
|
||
|
|
((k1 . r)
|
||
|
|
(datum->syntax-object #'k1
|
||
|
|
(proc (syntax-object->datum x)))))))))])))
|
||
|
|
|
||
|
|
(alias define-macro define-macro!)
|
||
|
|
(alias defmacro define-macro!)
|
||
|
|
|
||
|
|
(define-macro! define-struct! (name . slots)
|
||
|
|
`(begin
|
||
|
|
(define ,name
|
||
|
|
(lambda ,slots
|
||
|
|
(vector ',name ,@slots)))
|
||
|
|
(define ,(string->symbol (format "~a?" name))
|
||
|
|
(lambda (x)
|
||
|
|
(and (vector? x)
|
||
|
|
(= (vector-length x) (1+ ,(length slots)))
|
||
|
|
(eq? ',name (vector-ref x 0)))))
|
||
|
|
,@(\#make-accessors name slots)
|
||
|
|
',name))
|
||
|
|
|
||
|
|
(define \#make-accessors
|
||
|
|
(lambda (name slots)
|
||
|
|
(recur f ((n 1) (slots slots))
|
||
|
|
(if (not (null? slots))
|
||
|
|
(let*
|
||
|
|
((afn (string->symbol (format "~a-~a" name (car slots))))
|
||
|
|
(sfn (string->symbol (format "~a!" afn))))
|
||
|
|
`((define-macro! ,afn (x) `(vector-ref ,x ,,n))
|
||
|
|
(define-macro! ,sfn (x v) `(vector-set! ,x ,,n ,v))
|
||
|
|
,@(f (1+ n) (cdr slots))))
|
||
|
|
'()))))
|