TakeV/guile-prescheme
Archived
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

Initial prescheme-display stubs

Browse source
This commit is contained in:
Andrew Whatson 2022-08-08 23:07:58 +10:00
parent c0f994b559
commit f92d8f1c39
5 changed files with 246 additions and 4 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
TODO.org
View file

@ -73,7 +73,7 @@ involve:
** ps-compiler/prescheme/package-defs.scm [4/27]
*** [-] prescheme-compiler
*** [ ] prescheme-display
*** [-] prescheme-display
*** [ ] protocol
*** [ ] prescheme-front-end
*** [ ] forms

1
hall.scm
View file

@ -54,6 +54,7 @@
(directory
"prescheme"
((directory "primop" ((scheme-file "primop")))
(scheme-file "display")
(scheme-file "record")
(scheme-file "spec")
(scheme-file "top")

3
prescheme/ps-defenum.scm
View file

@ -22,11 +22,14 @@
(define-module (prescheme ps-defenum)
#:use-module (srfi srfi-9)
#:use-module (prescheme s48-defenum)
#:use-module (prescheme record-discloser)
#:use-module (prescheme syntax-utils)
#:re-export (enum)
#:export (make-external-constant
external-constant?
external-constant-enum-name
external-constant-name
external-constant-c-string
define-external-enumeration))

5
ps-compiler/node/node.scm
View file

@ -19,9 +19,8 @@
#:use-module (ps-compiler node primop)
#:use-module (ps-compiler util syntax)
#:use-module (ps-compiler util util)
#:replace (make-variable)
#:export (variable?
global-variable? make-global-variable
#:replace (make-variable variable?)
#:export (global-variable? make-global-variable
variable-name set-variable-name!
variable-id
variable-type set-variable-type!

239
ps-compiler/prescheme/display.scm Normal file
View file

@ -0,0 +1,239 @@
;;; Ported from Scheme 48 1.9. See file COPYING for notices and license.
;;;
;;; Port Author: Andrew Whatson
;;;
;;; Original Authors: Richard Kelsey, Mike Sperber
;;;
;;; scheme48-1.9.2/ps-compiler/prescheme/display.scm
;;;
;;; Data must be done last as it may contain references to the other stuff.
(define-module (ps-compiler prescheme display)
#:use-module (prescheme scheme48)
#:use-module (prescheme ps-defenum)
#:use-module (ps-compiler node node)
#:use-module (ps-compiler node primop)
#:export (display-forms-as-scheme))
(define (display-forms-as-scheme forms out)
(receive (data other)
(partition-list (lambda (f)
(and (node? (form-value f))
(literal-node? (form-value f))))
forms)
(for-each (lambda (f)
(display-form-as-scheme f (schemify (form-value f)) out))
other)
(for-each (lambda (f)
(display-data-form-as-scheme f out))
data)))
(define form-value (structure-ref forms form-value))
(define form-var (structure-ref forms form-var))
(define literal-node? (node-predicate 'literal #f))
(define (display-form-as-scheme f value out)
(cond ((unspecific? value)
(p `(define ,(get-form-name f)) out)
(newline out))
((or (external-value? value)
(memq 'closed-compiled-primitive (variable-flags (form-var f))))
(values))
(else
(p `(define ,(get-form-name f) ,value)
out)
(newline out))))
(define (display-data-form-as-scheme f out)
(let* ((value (clean-literal (node-form (form-value f))))
(value (if (and (quoted? value)
(not (or (list? (cadr value))
(vector? (cadr value)))))
(cadr value)
value)))
(display-form-as-scheme f value out)))
(define (get-form-name form)
(name->symbol (get-variable-name (form-var form))))
(define (schemify node)
(if (node? node)
((operator-table-ref schemifiers (node-operator-id node))
node)
(schemify-sexp node)))
(define unspecific?
(let ((x (if #f #t)))
(lambda (y)
(eq? x y))))
(define schemifiers
(make-operator-table (lambda (node)
(let ((form (node-form node)))
(if (list? form)
(map schemify form)
form)))))
(define (define-schemifier name type proc)
(operator-define! schemifiers name type proc))
(define-schemifier 'name 'leaf
(lambda (node)
(cond ((node-ref node 'binding)
=> (lambda (binding)
(let ((var (binding-place binding)))
(if (variable? var)
(get-variable-name var)
(desyntaxify (node-form node))))))
(else
(name->symbol (node-form node))))))
;; Rename things that have differ in Scheme and Pre-Scheme
(define aliases
(map (lambda (s)
(cons s (string->symbol (string-append "ps-" (symbol->string s)))))
'(read-char peek-char write-char newline
open-input-file open-output-file
close-input-port close-output-port)))
(define (get-variable-name var)
(cond ((and (generated-top-variable? var)
(not (memq 'closed-compiled-primitive (variable-flags var))))
(string->symbol (string-append (symbol->string
(name->symbol (variable-name var)))
"."
(number->string (variable-id var)))))
((assq (variable-name var) aliases)
=> cdr)
(else
(variable-name var))))
(define (name->symbol name)
(if (symbol? name)
name
(string->symbol (string-append (symbol->string
(name->symbol (generated-name name)))
"."
(number->string (generated-uid name))))))
(define-schemifier 'quote #f
(lambda (node)
(list 'quote (cadr (node-form node)))))
(define-schemifier 'literal #f
(lambda (node)
(let ((form (node-form node)))
(cond ((primop? form)
(primop-id form))
((external-value? form)
(let ((string (external-value-string form)))
(if (string=? string "(long(*)())")
'integer->procedure
(string->symbol (external-value-string form)))))
((external-constant? form)
`(enum ,(external-constant-enum-name form)
,(external-constant-name form)))
(else
(schemify-sexp form))))))
(define-schemifier 'unspecific #f
(lambda (node)
''unspecific))
;; Used for primitives in non-call position. The CDR of the form is a
;; variable that will be bound to the primitive's closed-compiled value.
(define-schemifier 'primitive #f
(lambda (node)
(let ((form (node-form node)))
(cond ((pair? form)
(get-variable-name (cdr form))) ;; non-call position
((assq (primitive-id form) aliases)
=> cdr)
(else
(primitive-id form))))))
;; lambda, let-syntax, letrec-syntax...
(define-schemifier 'letrec #f
(lambda (node)
(let ((form (node-form node)))
`(letrec ,(map (lambda (spec)
`(,(schemify (car spec)) ,(schemify (cadr spec))))
(cadr form))
,@(map (lambda (f) (schemify f))
(cddr form))))))
(define-schemifier 'lambda #f
(lambda (node)
(let ((form (node-form node)))
`(lambda ,(let label ((vars (cadr form)))
(cond ((pair? vars)
(cons (schemify (car vars))
(label (cdr vars))))
((null? vars)
'())
(else
(schemify vars))))
,@(map schemify (cddr form))))))
(define-schemifier 'goto #f
(lambda (node)
(map schemify (cdr (node-form node)))))
(define (schemify-sexp thing)
(cond ((name? thing)
(desyntaxify thing))
((primop? thing)
(primop-id thing))
((operator? thing)
(operator-name thing))
((primitive? thing)
(primitive-id thing))
((variable? thing)
(get-variable-name thing))
((pair? thing)
(let ((x (schemify-sexp (car thing)))
(y (schemify-sexp (cdr thing))))
(if (and (eq? x (car thing))
(eq? y (cdr thing)))
thing ;;+++
(cons x y))))
((vector? thing)
(let ((new (make-vector (vector-length thing) #f)))
(let loop ((i 0) (same? #t))
(if (>= i (vector-length thing))
(if same? thing new) ;;+++
(let ((x (schemify-sexp (vector-ref thing i))))
(vector-set! new i x)
(loop (+ i 1)
(and same? (eq? x (vector-ref thing i)))))))))
(else thing)))
(define (clean-literal thing)
(cond ((name? thing)
(desyntaxify thing))
((variable? thing)
(get-variable-name thing))
((external-constant? thing)
`(enum ,(external-constant-enum-name thing)
,(external-constant-name thing)))
((pair? thing)
(let ((x (clean-literal (car thing)))
(y (clean-literal (cdr thing))))
(if (and (quoted? x) (quoted? y))
`(quote (,(cadr x) . ,(cadr y)))
`(cons ,x ,y))))
((vector? thing)
(let ((elts (map clean-literal (vector->list thing))))
(if (every? quoted? elts)
`(quote ,(list->vector (map cadr elts)))
`(vector . ,elts))))
(else
`(quote ,thing))))
(define (quoted? x)
(and (pair? x)
(eq? (car x) 'quote)))