2022-08-11 15:39:34 +00:00
|
|
|
;;; Ported from Scheme 48 1.9. See file COPYING for notices and license.
|
|
|
|
;;;
|
|
|
|
;;; Port Author: Andrew Whatson
|
|
|
|
;;;
|
|
|
|
;;; Original Authors: Richard Kelsey, Jonathan Rees, Mike Sperber
|
|
|
|
;;;
|
|
|
|
;;; scheme48-1.9.2/scheme/bcomp/node.scm
|
|
|
|
|
|
|
|
(define-module (prescheme bcomp node)
|
|
|
|
#:use-module (srfi srfi-9)
|
|
|
|
#:use-module (prescheme scheme48)
|
|
|
|
#:use-module (prescheme bcomp mtype)
|
|
|
|
#:use-module (prescheme record-discloser)
|
|
|
|
#:export (make-node
|
|
|
|
|
|
|
|
node?
|
|
|
|
node-operator
|
|
|
|
node-operator-id
|
|
|
|
node-form
|
|
|
|
node-ref
|
|
|
|
node-set!
|
|
|
|
node-predicate
|
|
|
|
|
|
|
|
make-similar-node
|
|
|
|
force-node
|
|
|
|
schemify
|
|
|
|
|
|
|
|
name->qualified
|
|
|
|
|
|
|
|
get-operator
|
|
|
|
make-operator-table
|
|
|
|
operator-name
|
|
|
|
operator-nargs
|
|
|
|
operator-table-ref
|
|
|
|
operator-define!
|
|
|
|
operator-lookup
|
|
|
|
operator-type
|
|
|
|
operator-uid
|
|
|
|
operator?
|
2022-08-15 03:18:18 +00:00
|
|
|
operators-table ;;config.scm comp-package.scm
|
2022-08-11 15:39:34 +00:00
|
|
|
|
|
|
|
lambda-node?
|
|
|
|
flat-lambda-node?
|
|
|
|
name-node?
|
|
|
|
call-node?
|
|
|
|
literal-node?
|
|
|
|
quote-node?
|
|
|
|
define-node?
|
|
|
|
loophole-node?
|
|
|
|
|
|
|
|
operator/flat-lambda
|
|
|
|
operator/lambda
|
|
|
|
operator/set!
|
|
|
|
operator/call
|
|
|
|
operator/begin
|
|
|
|
operator/name
|
|
|
|
operator/letrec
|
|
|
|
operator/letrec*
|
|
|
|
operator/pure-letrec
|
|
|
|
operator/literal
|
|
|
|
operator/quote
|
|
|
|
operator/unassigned
|
|
|
|
operator/unspecific
|
|
|
|
operator/define
|
|
|
|
operator/define-syntax
|
|
|
|
operator/primitive-procedure
|
|
|
|
operator/structure-ref))
|
|
|
|
|
2022-08-15 03:18:18 +00:00
|
|
|
;; --------------------
|
|
|
|
;; Operators (= special operators and primitives)
|
|
|
|
|
2022-08-11 15:39:34 +00:00
|
|
|
(define-record-type :operator
|
|
|
|
(make-operator type nargs uid name)
|
|
|
|
operator?
|
|
|
|
(type operator-type set-operator-type!)
|
|
|
|
(nargs operator-nargs)
|
|
|
|
(uid operator-uid)
|
|
|
|
(name operator-name))
|
|
|
|
|
|
|
|
(define-record-discloser :operator
|
|
|
|
(lambda (s)
|
|
|
|
(list 'operator
|
|
|
|
(operator-name s)
|
|
|
|
(if (symbol? (operator-type s))
|
|
|
|
(operator-type s)
|
|
|
|
(type->sexp (operator-type s) #t)))))
|
|
|
|
|
|
|
|
(define usual-operator-type
|
|
|
|
(procedure-type any-arguments-type value-type #f))
|
|
|
|
|
|
|
|
(define (get-operator name . type-option)
|
|
|
|
(let ((type (if (null? type-option) #f (car type-option)))
|
|
|
|
(probe (table-ref operators-table name)))
|
|
|
|
(if (operator? probe)
|
|
|
|
(let ((previous-type (operator-type probe)))
|
|
|
|
(cond ((not type))
|
|
|
|
((not previous-type)
|
|
|
|
(set-operator-type! probe type))
|
|
|
|
((symbol? type) ;; 'leaf or 'internal
|
|
|
|
(if (not (eq? type previous-type))
|
|
|
|
(warning 'get-operator
|
|
|
|
"operator type inconsistency" name type previous-type)))
|
|
|
|
((subtype? type previous-type) ;;Improvement
|
|
|
|
(set-operator-type! probe type))
|
|
|
|
((not (subtype? previous-type type))
|
|
|
|
(warning 'get-operator
|
|
|
|
"operator type inconsistency"
|
|
|
|
name
|
|
|
|
(type->sexp previous-type 'foo)
|
|
|
|
(type->sexp type 'foo))))
|
|
|
|
probe)
|
|
|
|
(let* ((uid *operator-uid*)
|
|
|
|
(op (make-operator type
|
|
|
|
(if (and type
|
|
|
|
(not (symbol? type))
|
|
|
|
(fixed-arity-procedure-type? type))
|
|
|
|
(procedure-type-arity type)
|
|
|
|
#f)
|
|
|
|
uid
|
|
|
|
name)))
|
|
|
|
(if (>= uid number-of-operators)
|
|
|
|
(warning 'get-operator
|
|
|
|
"too many operators" (operator-name op) (operator-type op)))
|
|
|
|
(set! *operator-uid* (+ *operator-uid* 1))
|
|
|
|
(table-set! operators-table (operator-name op) op)
|
|
|
|
(vector-set! the-operators uid op)
|
|
|
|
op))))
|
|
|
|
|
|
|
|
(define *operator-uid* 0)
|
|
|
|
|
|
|
|
(define operators-table (make-table))
|
|
|
|
|
|
|
|
(define number-of-operators 400) ;;Fixed-size limits bad, but speed good
|
|
|
|
(define the-operators (make-vector number-of-operators #f))
|
|
|
|
|
|
|
|
;; --------------------
|
|
|
|
;; Operator tables (for fast dispatch)
|
|
|
|
|
|
|
|
(define (make-operator-table default)
|
|
|
|
(make-vector number-of-operators default))
|
|
|
|
|
|
|
|
(define operator-table-ref vector-ref)
|
|
|
|
|
|
|
|
(define (operator-lookup table op)
|
|
|
|
(operator-table-ref table (operator-uid op)))
|
|
|
|
|
|
|
|
(define (operator-define! table name type proc)
|
|
|
|
(vector-set! table
|
|
|
|
(operator-uid (get-operator name type))
|
|
|
|
proc))
|
|
|
|
|
|
|
|
;; --------------------
|
|
|
|
;; Nodes
|
|
|
|
|
|
|
|
;; A node is an annotated expression (or definition or other form).
|
|
|
|
;; The FORM component of a node is an S-expression of the same form as
|
|
|
|
;; the S-expression representation of the expression. E.g. for
|
|
|
|
;; literals, the form is the literal value; for variables the form is
|
|
|
|
;; the variable name; for IF expressions the form is a 4-element list
|
|
|
|
;; (<if> test con alt). Nodes also have a tag identifying what kind
|
|
|
|
;; of node it is (literal, variable, if, etc.) and a property list.
|
|
|
|
|
|
|
|
(define-record-type :node
|
|
|
|
(really-make-node uid form plist)
|
|
|
|
node?
|
|
|
|
(uid node-operator-id)
|
|
|
|
(form node-form)
|
|
|
|
(plist node-plist set-node-plist!))
|
|
|
|
|
|
|
|
(define-record-discloser :node
|
|
|
|
(lambda (n) (list (operator-name (node-operator n)) (node-form n))))
|
|
|
|
|
|
|
|
(define (make-node operator form)
|
|
|
|
(really-make-node (operator-uid operator) form '()))
|
|
|
|
|
|
|
|
(define (node-ref node key)
|
|
|
|
(let ((probe (assq key (node-plist node))))
|
|
|
|
(if probe (cdr probe) #f)))
|
|
|
|
|
|
|
|
;; removes property if value is #f
|
|
|
|
(define (node-set! node key value) ;;gross
|
|
|
|
(if value
|
|
|
|
(let ((probe (assq key (node-plist node))))
|
|
|
|
(if probe
|
|
|
|
(set-cdr! probe value)
|
|
|
|
(set-node-plist! node (cons (cons key value) (node-plist node)))))
|
|
|
|
(let loop ((l (node-plist node)) (prev #f))
|
|
|
|
(cond ((null? l) 'lose)
|
|
|
|
((eq? key (caar l))
|
|
|
|
(if prev
|
|
|
|
(set-cdr! prev (cdr l))
|
|
|
|
(set-node-plist! node (cdr l))))
|
|
|
|
(else (loop (cdr l) l))))))
|
|
|
|
|
|
|
|
(define (node-operator node)
|
|
|
|
(vector-ref the-operators (node-operator-id node)))
|
|
|
|
|
|
|
|
(define (node-predicate name . type-option)
|
|
|
|
(let ((id (operator-uid (apply get-operator name type-option))))
|
|
|
|
(lambda (node)
|
|
|
|
(= (node-operator-id node) id))))
|
|
|
|
|
|
|
|
(define (make-similar-node node form)
|
|
|
|
(if (equal? form (node-form node))
|
|
|
|
node
|
|
|
|
(make-node (node-operator node) form)))
|
|
|
|
|
|
|
|
;; Top-level nodes are often delayed.
|
|
|
|
|
|
|
|
(define (force-node node)
|
|
|
|
(if (node? node)
|
|
|
|
node
|
|
|
|
(force node)))
|
|
|
|
|
|
|
|
;; Node predicates and operators.
|
|
|
|
|
|
|
|
(define lambda-node? (node-predicate 'lambda syntax-type))
|
|
|
|
(define flat-lambda-node? (node-predicate 'flat-lambda syntax-type))
|
|
|
|
(define call-node? (node-predicate 'call))
|
|
|
|
(define name-node? (node-predicate 'name 'leaf))
|
|
|
|
(define literal-node? (node-predicate 'literal 'leaf))
|
|
|
|
(define quote-node? (node-predicate 'quote syntax-type))
|
|
|
|
(define define-node? (node-predicate 'define))
|
|
|
|
(define loophole-node? (node-predicate 'loophole))
|
|
|
|
|
|
|
|
(define operator/flat-lambda (get-operator 'flat-lambda))
|
|
|
|
(define operator/lambda (get-operator 'lambda syntax-type))
|
|
|
|
(define operator/set! (get-operator 'set! syntax-type))
|
|
|
|
(define operator/call (get-operator 'call 'internal))
|
|
|
|
(define operator/begin (get-operator 'begin syntax-type))
|
|
|
|
(define operator/name (get-operator 'name 'leaf))
|
|
|
|
(define operator/letrec (get-operator 'letrec))
|
|
|
|
(define operator/letrec* (get-operator 'letrec*))
|
|
|
|
(define operator/pure-letrec (get-operator 'pure-letrec))
|
|
|
|
(define operator/literal (get-operator 'literal))
|
|
|
|
(define operator/quote (get-operator 'quote syntax-type))
|
|
|
|
(define operator/unassigned (get-operator 'unassigned))
|
|
|
|
(define operator/unspecific (get-operator 'unspecific (proc () unspecific-type)))
|
|
|
|
(define operator/define (get-operator 'define syntax-type))
|
|
|
|
(define operator/define-syntax (get-operator 'define-syntax syntax-type))
|
|
|
|
(define operator/primitive-procedure
|
|
|
|
(get-operator 'primitive-procedure syntax-type))
|
|
|
|
(define operator/structure-ref (get-operator 'structure-ref syntax-type))
|