#! /bin/sh # This is a shell archive. Remove anything before this line, then unpack # it by saving it into a file and typing "sh file". To overwrite existing # files, type "sh file -c". You can also feed this as standard input via # unshar, or by typing "sh 'plscheme/README' <<'END_OF_FILE' XThis directory contains the files for PLScheme, a virtual machine and Xcompiler developed by Jonathan Rees in 1988 for 6.821, Dave Gifford's Xgraduate programming languages class at MIT. The code is written in XScheme. X XLoad the files listed in the file PL.SCM in order to run the system. X XVM.SCM contains a read-evaluate-print loop (repl) and a few test Xdefinitions. You must do (initialize) before calling these. They are X(test-fact n), (test-ifact n) and (cons-a-lot). X Xchanges: [oz] X XIn COMPILER.SCM and VM.SCM, the named-let name "recur" is replaced Xwith "loop" to avoid conflicts with the recur special form on some Xschemes. END_OF_FILE if test 629 -ne `wc -c <'plscheme/README'`; then echo shar: \"'plscheme/README'\" unpacked with wrong size! fi # end of 'plscheme/README' fi if test -f 'plscheme/compiler.scm' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'plscheme/compiler.scm'\" else echo shar: Extracting \"'plscheme/compiler.scm'\" \(18005 characters\) sed "s/^X//" >'plscheme/compiler.scm' <<'END_OF_FILE' X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; X;;; This is the file COMPILE.SCM ;;; X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; X X;;; COMPILER: DESUGARER X X(define (desugar exp) X (cond ((or (number? exp) (boolean? exp) (string? exp) (char? exp)) X exp) X ((symbol? exp) X exp) X ((eq? (car exp) 'quote) exp) X ((eq? (car exp) 'lambda) X `(lambda ,(cadr exp) ,(desugar-body (cddr exp)))) X ((eq? (car exp) 'set!) X `(set! ,(cadr exp) ,(desugar (caddr exp)))) X ((eq? (car exp) 'begin) X (desugar-body (cdr exp))) X ((eq? (car exp) 'if) X (if (= (length exp) 3) X `(if ,@(map desugar (cdr exp)) X ',unspecified) X `(if ,@(map desugar (cdr exp))))) X ((eq? (car exp) 'letrec) X `(letrec ,(map (lambda (spec) `(,(car spec) ,(desugar (cadr spec)))) X (cadr exp)) X ,(desugar-body (cddr exp)))) X ((sugar? exp) (desugar (rewrite exp))) X (else (map desugar exp)))) X X(define (desugar-body body) X (let ((body (map desugar body))) X (if (null? (cdr body)) X (car body) X `(begin ,@body)))) X X(define (sugar? exp) X (and (pair? exp) X (member (car exp) '(and cond do let or list)))) X X(define (rewrite exp) X (cond ((not (pair? exp)) exp) X ((eq? (car exp) 'and) (rewrite-and exp)) X ((eq? (car exp) 'cond) (rewrite-cond exp)) X ((eq? (car exp) 'do) (rewrite-do exp)) X ((eq? (car exp) 'let) (rewrite-let exp)) X ((eq? (car exp) 'or) (rewrite-or exp)) X ((eq? (car exp) 'list) (rewrite-list exp)) X (else exp))) X X X X(define (rewrite-and exp) X (let ((conjuncts (cdr exp))) X (cond ((null? conjuncts) `#t) X ((null? (cdr conjuncts)) (car conjuncts)) X (else `(if ,(car conjuncts) X (and ,@(cdr conjuncts)) X #f))))) X X(define (rewrite-cond exp) X (let ((clauses (cdr exp))) X (cond ((null? clauses) `',unspecified) X ((null? (cdar clauses)) X `(or ,(caar clauses) X (cond ,@(cdr clauses)))) X ((eq? (caar clauses) 'else) X `(begin ,@(cdar clauses))) X (else `(if ,(caar clauses) X (begin ,@(cdar clauses)) X (cond ,@(cdr clauses))))))) X X(define (rewrite-let exp) X (cond ((symbol? (cadr exp)) X (let ((tag (cadr exp)) X (bindings (caddr exp)) X (body (cdddr exp))) X `(letrec ((,tag (lambda ,(map car bindings) ,@body))) X (,tag ,@(map cadr bindings))))) X (else X (let ((bindings (cadr exp)) X (body (cddr exp))) X `((lambda ,(map car bindings) ,@body) X ,@(map cadr bindings)))))) X X(define (rewrite-or exp) X (let ((disjuncts (cdr exp))) X (cond ((null? disjuncts) `#f) X ((null? (cdr disjuncts)) (car disjuncts)) X (else `(if ,(car disjuncts) X #t X (or ,@(cdr disjuncts))))))) X X; In Scheme, LIST is supposed to be an n-ary procedure, but MPL Scheme X; doesn't have n-ary procedures, so we implement LIST as a macro. X X(define (rewrite-list exp) X (if (null? (cdr exp)) X ''() X `(cons ,(cadr exp) (list ,@(cddr exp))))) X X X X X;;; COMPILER: CODE GENERATOR X X(define (compile lambda-exp) X (reset-label-counter) X (assemble (generate-lambda-code (desugar lambda-exp) X initial-c-t-env))) X X(define (ctest lambda-exp) ;test routine X (generate-lambda-code (desugar lambda-exp) initial-c-t-env)) X X(define (generate-lambda-code exp c-t-env) X (let ((formals (lambda-formals exp))) X `((check-nargs ,(length formals)) X (make-environment ,(length formals)) X ,@(generate (caddr exp) X (c-t-bind formals c-t-env) X 0 X '((return)))))) X X(define (generate exp c-t-env depth continue-code) X (cond ((variable? exp) X (generate-variable exp c-t-env depth continue-code)) X ((literal? exp) X (generate-literal exp continue-code)) X ((lambda? exp) X (generate-lambda exp c-t-env depth continue-code)) X ((if? exp) X (generate-if exp c-t-env depth continue-code)) X ((begin? exp) X (generate-begin exp c-t-env depth continue-code)) X ((letrec? exp) X (generate-letrec exp c-t-env depth continue-code)) X ((application? exp) X (generate-application exp c-t-env depth continue-code)) X (else (error "unknown expression type" exp)))) X X; Constant X X(define (generate-literal exp continue-code) X `((load-constant (literal ,(literal-value exp))) X ,@continue-code)) X X; Variable reference X X(define (generate-variable var c-t-env depth continue-code) X (let ((info (locate-variable var c-t-env))) X (if (primitive? info) X (generate (eta-expand var (primitive-nargs info)) X initial-c-t-env X depth X continue-code) X `((load-variable ,(env-access-back info) ,(env-access-over info)) X ,@continue-code)))) X X; LAMBDA X X(define (generate-lambda exp c-t-env depth continue-code) X `((make-procedure (code ,(generate-lambda-code exp c-t-env))) X ,@continue-code)) X X; IF X X(define (generate-if exp c-t-env depth continue-code) X (let ((alt-label (generate-label 'else))) X (generate (if-predicate exp) X c-t-env X depth X `((jump-if-false ,alt-label) X ,@(generate (if-consequent exp) X c-t-env X depth X ;; Never label a jump or return. X (if (or (jump-instruction? (car continue-code)) X (return-instruction? (car continue-code))) X `(,(car continue-code) X ,alt-label X ,@(generate (if-alternate exp) X c-t-env X depth X continue-code)) X (let ((continue-label X (generate-label 'after-if))) X `((jump ,continue-label) X ,alt-label X ,@(generate (if-alternate exp) X c-t-env X depth X `(,continue-label X ,@continue-code)))))))))) X X; BEGIN X X(define (generate-begin exp c-t-env depth continue-code) X (let loop ((exp-list (begin-subexpressions exp))) X (generate (car exp-list) X c-t-env X depth X (if (null? (cdr exp-list)) X continue-code X (loop (cdr exp-list)))))) X X; Code for LETREC: X; 1. Push a bunch of unspecifieds. X; 2. Make an environment. X; 3. Evaluate the right-hand sides, storing the results into the X; environment. X; 4. Evaluate the body. X; 5. Reset environment to prior state. X X(define (generate-letrec exp c-t-env depth continue-code) X (let ((bindings (letrec-bindings exp)) X (body (letrec-body exp))) X (let ((new-env (c-t-bind (map binding-lhs bindings) c-t-env))) X (do ((bs bindings (cdr bs)) X (i 1 (+ i 1)) X (code (generate body X new-env X depth X (if (return-instruction? (car continue-code)) X continue-code X `((leave-environment) X ,@continue-code))) X (generate (binding-rhs (car bs)) X new-env X depth X `((set-variable 0 ,i) X ,@code)))) X ((null? bs) X (do ((bs bindings (cdr bs)) X (code `((make-environment ,(length bindings)) X ,@code) X `((load-constant (literal ,unspecified)) X (push) X ,@code))) X ((null? bs) code))))))) X X; Application X X(define (generate-application exp c-t-env depth continue-code) X (if (variable? (operator exp)) X (let ((info (locate-variable (operator exp) c-t-env))) X (if (primitive? info) X (generate-open-application info (operands exp) X c-t-env depth continue-code) X (generate-closed-application exp c-t-env depth continue-code))) X (generate-closed-application exp c-t-env depth continue-code))) X X(define (generate-open-application info arg-exps c-t-env depth continue-code) X (if (not (= (length arg-exps) (primitive-nargs info))) X (error "wrong number of arguments" (primitive-opcode info) arg-exps)) X (let ((call-code `((,(primitive-opcode info)) X ,@continue-code))) X (if (null? arg-exps) X call-code X (generate-pushes (cdr arg-exps) X c-t-env X depth X (generate (car arg-exps) X c-t-env X (+ depth (length (cdr arg-exps))) X call-code))))) X X(define (generate-closed-application exp c-t-env depth continue-code) X (let ((fun-exp (operator exp)) X (arg-exps (operands exp))) X (let ((nargs (length arg-exps))) X (let ((do-it (lambda (call-code) X (generate-pushes arg-exps X c-t-env X depth X (generate fun-exp X c-t-env X (+ depth nargs) X call-code))))) X (cond ((return-instruction? (car continue-code)) X ;; Handle tail recursion X (do-it `((call ,nargs) X ,@(cdr continue-code)))) X ((jump-instruction? (car continue-code)) X ;; Avoid generating a jump to a jump X `((make-continuation ,(jump-instruction-target X (car continue-code)) X ,depth) X ,@(do-it `((call ,nargs) X ,@(cdr continue-code))))) X (else X (let ((return-label (generate-label 'return))) X `((make-continuation ,return-label ,depth) X ,@(do-it `((call ,nargs) X ,return-label X ,@continue-code)))))))))) X X; Push values of expressions so that the first expression's value is X; the last to be pushed. X X(define (generate-pushes exp-list c-t-env depth continue-code) X (if (null? exp-list) X continue-code X (generate-pushes (cdr exp-list) X c-t-env X depth X (generate (car exp-list) X c-t-env X (+ depth (length (cdr exp-list))) X `((push) ,@continue-code))))) X X X X X;;; COMPILER: ASSEMBLER X X; An instruction stream is a list of items. Each item is either a X; label definition or an instruction. A label definition is simply a X; label. An instruction is a list whose car is an opcode and whose X; cdr is a list of operands. X X; This is a typical two-pass assembler. The first pass figures out the X; code offsets for labels; the second pass actually builds the code vector. X X(define (assemble code) X (resolve-labels code X (lambda (size labels) X (really-assemble code size labels)))) X X(define (resolve-labels code k) X (let loop ((offset 0) X (code code) X (labels '())) X (if (null? code) X (k offset labels) X (let ((item (car code)) (code (cdr code))) X (if (pair? item) X (loop (+ offset (length item)) code labels) X (loop offset code (cons (list item offset) labels))))))) X X(define (really-assemble code size labels) X (let ((code-vector (make-vector size))) X (let loop ((offset 0) X (code code)) X (if (null? code) X code-vector X (let ((item (car code)) (code (cdr code))) X (if (pair? item) X (begin (vector-set! code-vector X offset X (opcode (car item))) X (assemble-operands (cdr item) X (+ offset 1) X labels X code-vector) X (loop (+ offset (length item)) code)) X (loop offset code))))))) X X X X(define (assemble-operands operands offset labels code-vector) X (cond ((not (null? operands)) X (vector-set! code-vector X offset X (assemble-operand (car operands) labels)) X (assemble-operands (cdr operands) X (+ offset 1) X labels X code-vector)))) X X(define (assemble-operand operand labels) X (cond ((symbol? operand) X (let ((probe (assoc operand labels))) X (if probe X (cadr probe) X (error "undefined label" operand)))) X ((not (pair? operand)) operand) X ((eq? (car operand) 'literal) X (cadr operand)) X ((eq? (car operand) 'code) X (assemble (cadr operand))) X (else X (error "illegal operand syntax" operand)))) X X X X X X;;; COMPILER: ENVIRONMENTS X X; Compile time environments X X(define (c-t-bind vars c-t-env) X (lambda (var back) X (let loop ((i 1) X (vars vars)) X (cond ((null? vars) X (c-t-env var (+ back 1))) X ((same-variable? var (car vars)) X (make-env-access back i)) X (else X (loop (+ i 1) (cdr vars))))))) X X(define (locate-variable var c-t-env) X (c-t-env var 0)) X X(define initial-c-t-env X (lambda (var back) X ;; primitive-opcodes is a list of (name nargs) X (let ((maybe-primitive (assq var primitive-opcodes))) X (if maybe-primitive X (make-primitive (car maybe-primitive) (cadr maybe-primitive)) X (make-env-access back (global-variable-index var)))))) X X(define *global-variables* '()) X X(define (global-variable-index var) X (let loop ((l *global-variables*) (i 0)) X (cond ((null? l) X (set! *global-variables* (append *global-variables* (list var))) X i) X ((same-variable? var (car l)) i) X (else (loop (cdr l) (+ i 1)))))) X X(define (make-env-access back over) (list 'env-access back over)) X(define (env-access? info) (eq? (car info) 'env-access)) X(define env-access-back cadr) X(define env-access-over caddr) X X(define (make-primitive name nargs) (list 'primitive name nargs)) X(define (primitive? info) (eq? (car info) 'primitive)) X(define primitive-opcode cadr) X(define primitive-nargs caddr) X X X X X;;; COMPILER: UTILITIES X X(define (eta-expand exp nargs) X (let ((vars (do ((some-vars '(a b c d e f) (cdr some-vars)) ;kludge X (vars '() (cons (car some-vars) vars)) X (i nargs (- i 1))) X ((<= i 0) (reverse vars))))) X `(lambda ,vars X (,exp ,@vars)))) X X(define (return-instruction? instruction) X (and (pair? instruction) X (eq? (car instruction) 'return))) X X(define (jump-instruction? instruction) X (and (pair? instruction) X (eq? (car instruction) 'jump))) X X(define jump-instruction-target cadr) X X(define *label* 0) X X(define (reset-label-counter) X (set! *label* 0)) X X(define (generate-label prefix) X (set! *label* (+ *label* 1)) X (string->symbol (string-append (symbol->string prefix) X "-" X (number->string *label*)))) ;;; '(heur))))) X X X;;; COMPILER: EXPRESSION ABSTRACTION X X(define special-form-predicate X (lambda (keyword) X (lambda (exp) X (and (pair? exp) X (eq? (car exp) keyword))))) X X(define keyword? X (lambda (x) X (member x '(quote lambda if begin letrec define)))) X X(define literal? X (lambda (exp) X (or (number? exp) X (boolean? exp) X (quotation? exp)))) X X(define literal-value X (lambda (exp) X (cond ((quotation? exp) (cadr exp)) X ;; Hack to distinguish #F from () -- look at COPY-TO-HEAP X ((eq? exp #f) false) X ((eq? exp #t) true) X (else exp)))) X X(define quotation? (special-form-predicate 'quote)) X X(define variable? X (lambda (exp) X (and (symbol? exp) X (not (keyword? exp))))) X X(define same-variable? eq?) X X(define lambda? (special-form-predicate 'lambda)) X(define lambda-formals cadr) X(define lambda-body caddr) X X(define application? X (lambda (exp) X (and (pair? exp) X (not (keyword? (car exp)))))) X X(define operator car) X(define operands cdr) X X(define if? (special-form-predicate 'if)) X(define if-predicate cadr) X(define if-consequent caddr) X(define if-alternate cadddr) X X(define begin? (special-form-predicate 'begin)) X(define begin-subexpressions cdr) X X(define letrec? (special-form-predicate 'letrec)) X(define letrec-bindings cadr) X(define letrec-body caddr) X X(define binding-lhs car) X(define binding-rhs cadr) X X(define definition? (special-form-predicate 'define)) X(define (definition-lhs form) X (let ((pattern (cadr form))) X (if (pair? pattern) (car pattern) pattern))) X(define (definition-rhs form) X (let ((pattern (cadr form))) X (if (pair? pattern) X `(lambda ,(cdr pattern) ,@(cddr form)) X (caddr form)))) END_OF_FILE if test 18005 -ne `wc -c <'plscheme/compiler.scm'`; then echo shar: \"'plscheme/compiler.scm'\" unpacked with wrong size! fi # end of 'plscheme/compiler.scm' fi if test ! -d 'plscheme/doc' ; then echo shar: Creating directory \"'plscheme/doc'\" mkdir 'plscheme/doc' fi if test -f 'plscheme/doc/6821.sty' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'plscheme/doc/6821.sty'\" else echo shar: Extracting \"'plscheme/doc/6821.sty'\" \(2814 characters\) sed "s/^X//" >'plscheme/doc/6821.sty' <<'END_OF_FILE' X% -*- Mode: TeX -*- X X% X% 6821.STY VERSION 17 X% Edited by Gifford, 9/10/88 17:56:59 X% Edited by Lyn, 9/11/88 19:03 X% Edited by Lyn through 9/24/88 21:40 X% Edited by Lyn through 11/1/88 X X\topmargin=0in X\headheight=-0.5in X\textheight=9.0in X\textwidth=6in X\oddsidemargin=0.375in X\evensidemargin=-0.125in X\footheight=\baselineskip X X\pagestyle{plain} X X\def\@coursetitle{6.821 Programming Languages} X X\def\handout#1#2{\def\@handout{Handout \# #1}\def\@outdate{#2}} X\def\handouttitle#1{\def\@handouttitle{#1}} X\def\pp#1#2#3{\def\@handouttitle{Programming Problem #1: #2 \\ Due #3}} X\def\ps#1#2{\def\@handouttitle{Problem Set #1 \\ Due #2}} X\def\pss#1{\def\@handouttitle{Problem Set #1 Solution}} X\def\pps#1{\def\@handouttitle{Programming Problem #1 Solution}} X\def\@handout{} X\def\@handouttitle{} X\def\@outdate{} X X\newcommand{\reading}[1]{\noindent {\bf Suggested Reading:}{~#1} X\vspace{0.2in}} X X\newcommand{\note}[1]{ X\noindent {\bf Note:}{~#1} X\vspace{0.2in}} X X\newcommand{\mword}[1] {\hbox {\sl #1\/}} X% \newcommand{\mword}[1]{\mbox{\em #1}} X\newcommand{\obj}[2]{\fbox{{\em #1} {\bf #2}}} X\newcommand{\num}[1]{\fbox{{\em Number:} {\bf #1}}} X\newcommand{\mybool}[1]{\fbox{{\em Boolean:} {\bf #1}}} X\newcommand{\truth}{\mybool{truth}} X\newcommand{\falsity}{\mybool{falsity}} X\newcommand{\sym}[1]{\fbox{{\em Symbol:} {\bf #1}}} X\newcommand{\nil}{\fbox{\em Empty List:}} X\newcommand{\primproc}[1]{\fbox{{\em Procedure:} {\bf Primitive #1}}} X\newcommand{\proc}[2]{\fbox{{\em Procedure:} {\bf Formals: (#1) Body:} {\tt #2}}} X\newcommand{\lst}[1]{\fbox{{\em List:} {\bf #1}}} X X\newcommand{\backwhack}{{\tt\char`\\}} X X% Used to have vspace of 1ex X\newcommand{\centerobj}[1]{\vspace{2ex} X\centerline{#1} X\vspace{2ex}} X X\newcommand{\eval}{$\Longrightarrow$} X\newcommand{\downeval}{\shortstack{$\parallel$\\{\em eval}\\$\Downarrow$}} X\newcommand{\downsubst}{\shortstack{$\mid$\\{\em substitute}\\$\downarrow$}} X\newcommand{\downresult}{\shortstack{$\mid$\\{\em primitive}\\{\em application}\\$\downarrow$}} X X\newenvironment{body}{\begin{document}% X \vskip -0.4in X \begin{flushright} \@handout \\ \@outdate \end{flushright}% X \vspace{4ex}% X \centerline{MASSACHUSETTS INSTITUTE OF TECHNOLOGY}% X \centerline{Department of Electrical Engineering and Computer Science} X \vspace{1ex}% X \centerline{\bf\@coursetitle}% X \vspace{1ex}% X {\Large\bf\begin{center} \@handouttitle \end{center}}% X \vspace{2ex}}% X {\end{document}} X X\def\nonterm#1{\hbox{$\langle${\it #1}$\rangle$}} X\def\lamb{\hbox{$\lambda$}} X\def\replaces{\hbox{$::=$}} X X\newtheorem{theorem}{Theorem} X\newtheorem{definition}{Definition} X X\def\eg{{\em e.g.,\thinspace}} X\def\Eg{{\em E.g.,\thinspace}} X\def\ie{{\em i.e.,\thinspace}} X\def\Ie{{\em I.e.,\thinspace}} X\def\viz{{\em viz.,\thinspace}} X\def\Viz{{\em Viz.,\thinspace}} X\def\etc{{\em etc.,\thinspace}} X X X X X X X X X END_OF_FILE if test 2814 -ne `wc -c <'plscheme/doc/6821.sty'`; then echo shar: \"'plscheme/doc/6821.sty'\" unpacked with wrong size! fi # end of 'plscheme/doc/6821.sty' fi if test -f 'plscheme/doc/commands.tex' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'plscheme/doc/commands.tex'\" else echo shar: Extracting \"'plscheme/doc/commands.tex'\" \(3711 characters\) sed "s/^X//" >'plscheme/doc/commands.tex' <<'END_OF_FILE' X% Math spacing: thin \, medium \> [or \:] thick \; X\renewcommand{\:}{\mskip\medmuskip} X X{\catcode`\^^M=13 \gdef\myobeycr{\catcode`\^^M=13 \def^^M{\\}}% X\gdef\restorecr{\catcode`\^^M=5 }} X X\newcommand{\heading}[1]{\vspace{3ex}{\noindent#1}\vspace{1.5ex}} X X\newcommand{\goesto}{$::=$} X\newcommand{\arbno}[1]{#1\hbox{\rm*}} X\newcommand{\atleastone}[1]{#1\hbox{\rm+}} X\newcommand{\weakerthan}{\sqsubseteq} X X\newenvironment{grammar}{ X \def\:{\goesto{}} X \def\|{$\vert$} X \tt \myobeycr X \begin{tabbing} X %\qquad\quad \= X \qquad \= $\vert$ \= \kill X }{\unskip\end{tabbing}} X X\newcommand{\guard}{\mbox{$[\!]$}} X\newcommand{\brak}[1]{[\![{#1}]\!]} X\newcommand{\fun}[1]{\hbox{\it #1\/}} X\newcommand{\Is}[1]{\hbox{\rm is#1}} X\newcommand{\Inj}[1]{\hbox{\rm in#1}} X\newcommand{\Cases}{{\bf cases}\:} X\newcommand{\Of}{\:{\bf of}\:} X\newcommand{\End}{\:{\bf end}\:} X\newcommand{\Let}{{\bf let}\:} X\newcommand{\In}{\:{\bf in}\:} X\newcommand{\Then}{\rightarrow} X\newcommand{\Else}{\guard} X X\newcommand\abstr[1]{\lambda{#1}\:.\:} X\newcommand\strict[1]{\underline{\lambda}{#1}\:.\:} X\newcommand\elt{\!\!\downarrow\!\!} X\newcommand\drop{\!\!\dagger\!\!} X\newcommand\injekt{\hbox{ \rm in }} X\newcommand\projekt{\,\vert\,} X\renewcommand{\|}{$\vert$} X\newcommand{\elem}{\hbox{\raise.13ex\hbox{$\scriptstyle\in$}}} X\newcommand{\wrong}[1]{\fun{wrong }\hbox{\rm``#1''}} X\newcommand{\go}[1]{\hbox{\hspace*{#1em}}} X X\newcommand{\error}{\fun{error}} X X\newcommand\UNIT{\hbox{\it Unit}} X\newcommand\LOC{\hbox{\it Location}} \renewcommand\loc{\hbox{$l$}} X\newcommand\NAT{\hbox{\it Natural-number}} \newcommand\nat{\hbox{$i$}} X\newcommand\TRU{\hbox{\it Boolean}} \newcommand\tru{\hbox{$t$}} X\newcommand\SYM{\hbox{\it Symbol}} X\newcommand\PROC{\hbox{\it Procedure}} \newcommand\dproc{\hbox{$p$}} X\newcommand\SVAL{\hbox{\it Storable-value}} \newcommand\sval{\hbox{$v$}} X\newcommand\XVAL{\hbox{\it Expressible-value}} \newcommand\xval{\hbox{$e$}} X\newcommand\DVAL{\hbox{\it Denotable-value}} \newcommand\dval{\hbox{$d$}} X\newcommand\STO{\hbox{\it Store}} \newcommand\sto{\hbox{$s$}} X\newcommand\EC{\hbox{\it Expcont}} \newcommand\ec{\hbox{$k$}} X\newcommand\CC{\hbox{\it Cmdcont}} \newcommand\cc{\hbox{$c$}} X\newcommand\RES{\hbox{\it Result}} \newcommand\res{\hbox{$x$}} X\newcommand\ANS{\hbox{\it Answer}} \newcommand\ans{\hbox{$a$}} X\newcommand\ENV{\hbox{\it Environment}} \newcommand\env{\hbox{$u$}} X\newcommand\PENV{\hbox{\it Environment}} \newcommand\penv{\hbox{$\rho$}} X\newcommand\DENV{\hbox{\it Dynamic-Environment}} \newcommand\denv{\hbox{$z$}} X\newcommand\ERR{\hbox{\it Error}} X\newcommand\UNBD{\hbox{\it Unbound}} X\newcommand\FULL{\hbox{\it Full}} X\newcommand\CLO{\hbox{\it Closure}} \newcommand\clo{\hbox{$q$}} X\newcommand\TXT{\hbox{\it Text}} \newcommand\txt{\hbox{$z$}} X\newcommand\DEN{\hbox{\it Denotation}} \newcommand\den{\hbox{$z$}} X\newcommand\ID{\Ide} \newcommand\id{\I} X\newcommand\PAIR{\hbox{\it Pair}} X\newcommand\CONS{\hbox{\it Cons-cell}} X\newcommand{\Con}{\hbox{\rm Constant}} \newcommand{\K}{\hbox{\rm K}} X\newcommand{\Ide}{\hbox{\rm Identifier}} \newcommand{\I}{\hbox{\rm I}} X\newcommand{\Vari}{\hbox{\rm Variable}} X\renewcommand{\Exp}{\hbox{\rm Expression}} \newcommand{\E}{\hbox{\rm E}} X\newcommand{\Com}{\hbox{\rm Command}} \newcommand{\C}{\hbox{$\Gamma$}} X\newcommand{\Ksem}{\hbox{$\cal K$}} X\newcommand{\Esem}{\hbox{$\cal E$}} X\newcommand{\Csem}{\hbox{$\cal C$}} X X\newcommand{\sempair}[2]{\langle #1, #2 \rangle} X\newcommand{\bindfor}[3]{[#2 \mapsto #3]#1} X\newcommand{\storefor}[3]{[#2 \mapsto #3]#1} X X X X X END_OF_FILE if test 3711 -ne `wc -c <'plscheme/doc/commands.tex'`; then echo shar: \"'plscheme/doc/commands.tex'\" unpacked with wrong size! fi # end of 'plscheme/doc/commands.tex' fi if test -f 'plscheme/doc/macros.tex' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'plscheme/doc/macros.tex'\" else echo shar: Extracting \"'plscheme/doc/macros.tex'\" \(2779 characters\) sed "s/^X//" >'plscheme/doc/macros.tex' <<'END_OF_FILE' X% -*- Mode: TeX -*- X X \font\fiverm=cmr5 X\font\eightsl=cmsl8 X X% Macros for doing inference rules. The first argument is the IF part of X% the rule, the second is the THEN part. X\def\malign#1{\begin{array}{rcl}#1\end{array}} X\let\eqalign\malign X\def\infrule#1#2{\malign{#1} \over \malign{#2}} X X% Support for doing tabbing environments which use the same tab stops. X% A line consisting of the desired spacing is passed as the argument X% to \settabs. Then the fixedtabs environment will use these tab stops X% until a new \settabs is used. X\newcommand{\settabs}[1]{\def\tabtemplate{#1}}% a global storage bin for X\newcommand{\setuptabs}{\tabtemplate\kill} % tabbing sample lines X\newenvironment{fixedtabs}{\begin{tabbing}\setuptabs}{\end{tabbing}} X X\renewcommand{\emptyset}{\phi} X\newcommand{\fcn}{\rightarrow} X\newcommand{\pow}{\hbox{\eightsl PowerSet}} X\newcommand{\FV}{\mbox{\sl FV}} X\newcommand{\FL}{\mbox{\sl FL}} X\newcommand{\pair}[2]{\mbox{$\langle #1, #2 \rangle$}} X \def\red#1{\, X {\hbox{\lower0.2ex X \hbox{$\buildrel \hbox{\fiverm red } \over \Longrightarrow$}}} X \lower0.2ex\hbox{$^{#1}$} X \,} X\newcommand{\redmany}{\red{{\rm *}}} X\newcommand{\undef}{\mbox{$-$}} X X\newcommand{\keyword}[1]{\mbox{\tt#1}}% X\newcommand{\ktrue}{\keyword{\#t}} X\newcommand{\kfalse}{\keyword{\#f}} X\newcommand{\ku}{\keyword{\#u}} X\newcommand{\kif}{\keyword{if}} X\newcommand{\klambda}{\keyword{lambda}} X\newcommand{\kbegin}{\keyword{begin}} X\newcommand{\knew}{\keyword{new}} X\newcommand{\kget}{\keyword{get}} X\newcommand{\kset}{\keyword{set}} X\newcommand{\kletrec}{\keyword{letrec}} X\newcommand{\klet}{\keyword{let}} X X\newcommand{\synvar}[1]{\mbox{\it#1}}% X\newcommand{\Bool}{\synvar{Bool}} X\newcommand{\bool}{\synvar{b}} X\newcommand{\Unit}{\synvar{Unit}} X\newcommand{\unit}{\synvar{u}} X\newcommand{\Const}{\synvar{Const}} X\newcommand{\const}{\synvar{c}} X\newcommand{\Var}{\synvar{Var}} X\newcommand{\var}[1]{\mbox{$\synvar{x}_{#1}$}} X\newcommand{\Exp}{\synvar{Exp}} X\renewcommand{\exp}[1]{\mbox{$\synvar{e}_{#1}$}} X\newcommand{\Val}{\synvar{Val}} X\newcommand{\val}[1]{\mbox{$\synvar{v}_{#1}$}} X\newcommand{\State}{\synvar{State}} X\newcommand{\state}[1]{\mbox{$\synvar{$\theta$}_{#1}$}} X\newcommand{\Store}{\synvar{Store}} X\newcommand{\store}[1]{\mbox{$\synvar{$\sigma$}_{#1}$}} X\newcommand{\Loc}{\synvar{Loc}} X\newcommand{\loc}[1]{\mbox{$\synvar{l}_{#1}$}} X X\newcommand{\code}[1]{\mbox{\tt #1}} X\newcommand{\lambexp}[2]{\code{(}\klambda\ \code{(}#1\code{)}\ #2\code{)}} X\newcommand{\apply}[2]{\code{(}#1\ #2\code{)}} X\newcommand{\ifexp}[3]{\code{(}\kif\ #1\ #2\ #3\code{)}} X\newcommand{\beginexp}[1]{\code{(}\kbegin\ #1\code{)}} X\newcommand{\newexp}[1]{\code{(}\knew\ #1\code{)}} X\newcommand{\getexp}[1]{\code{(}\kget\ #1\code{)}} X\newcommand{\setexp}[2]{\code{(}\kset\ #1\ #2\code{)}} END_OF_FILE if test 2779 -ne `wc -c <'plscheme/doc/macros.tex'`; then echo shar: \"'plscheme/doc/macros.tex'\" unpacked with wrong size! fi # end of 'plscheme/doc/macros.tex' fi if test -f 'plscheme/doc/plscheme-2.tex' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'plscheme/doc/plscheme-2.tex'\" else echo shar: Extracting \"'plscheme/doc/plscheme-2.tex'\" \(17190 characters\) sed "s/^X//" >'plscheme/doc/plscheme-2.tex' <<'END_OF_FILE' X% -*- Mode: TeX -*- X% 6821 Handout 62 X\documentstyle[11pt,6821]{article} X X\handout{62}{1 December 1988} X\handouttitle{Implementation of Scheme-like Languages, Part II} X X\input{macros} X\input{commands} X\newcommand{\rulename}[1]{\mbox{[{\it#1}\/]}} X X\begin{body} X XToday we'll be discussing some details of the PLScheme Xvirtual machine and runtime system. This handout contains Xsome brief notes on these topics. X X\section*{Descriptors and Stored Objects} X XEvery data object in the PLScheme virtual machine is represented by a Xsingle-word\footnote{We never specify how wide a word is --- in fact Xthe current implementation unrealistically allows it to be arbitrarily Xwide. For concreteness, however, you can assume that a word is 32 Xbits wide.} {\em descriptor}. Each descriptor consists of two parts: Xa tag and a value. See Figure~\ref{descriptor}. X X\begin{figure}[h] X\begin{verbatim} X X n-1 4 3 2 1 0 X +---+--~~~--+---+---+---+---+---+ X | | | | | | | | X +---+--~~~--+---+---+---+---+---+ X \ / \ / X --------v-------- ----v---- X VALUE FIELD TAG FIELD X X Note: n is the width of a machine word X\end{verbatim} X\caption{Format of a descriptor word} X\label{descriptor} X\end{figure} X XIn our system, the tag is represented by the lowest 3 bits of the Xdescriptor word; thus, there are eight possible type tags in the Xsystem. Only seven of these are used in the current Ximplementation; the tags and their associated types are Xshown in the table below: X X\begin{center} X\begin{tabular}{|c|c|} X\hline XTag (decimal) & Value Type \\ \hline X\hline X 0 & small integers\\ \hline X 1 & miscellaneous\\ X & (booleans, nil, unspecified, undefined)\\ \hline X 2 & unused at this time\\ \hline X 3 & pairs\\ \hline X 4 & vectors\\ \hline X 5 & symbols\\ \hline X 6 & procedures\\ \hline X 7 & refs\\ \hline X\end{tabular} X\end{center} X X XThe value is represented by the remaining (non-tag) bits in the Xdescriptor word. Certain values are small enough to be completely Xrepresented by the value bits in the descriptor word. Small integers, Xfor example, are those integers that can be represented in $n - 3$ Xbits, where $n$ is the width of the machine word.\footnote{Normally, Xnumbers that are not representable with the number of bits available Xin the value field --- e.g. bignums and double-precision floating Xpoint numbers --- are stored on the heap, and the descriptor word Xcontains a pointer to the stored object. To simplify matters, XPLScheme does not handle these cases, but they could easily be added.} XOther miscellaneous data values --- such as truth and falsity, the Xempty list, the unspecified value, and the undefined Xvalue\footnote{The unspecified value is the value returned by Xside-effecting operations; it is also the value of an uninitialized Xvector component that has not been initialized. The undefined value Xis the value of a declared but uninitialized variable.} --- can also Xbe easily represented directly in the value field. X XMost values, however, are too ``big'' to fit directly into Xthe value field of a descriptor word. So instead, they Xare represented as {\em stored objects}, a sequence of contiguous Xwords in the heap or stack. The value field of the Xdescriptor word for the object contains the memory address Xof the first word of the stored object. Thus, the descriptor Xword is a ``typed pointer'' to an object stored elsewhere. X\footnote{Alternate representation schemes sometimes Xstore the type with the words in the heap rather than in the pointer.} X XFor simplicity's sake, all stored objects in the PLScheme Xvirtual machine share a standard representation. XThe first word in every stored object is a {\em header word} Xthat is a small integer specifying the length $l$ of (= the number of Xfollowing data words in) the object. The header word is followed Xby $l$ descriptor words that comprise the contents of the object. XThe layouts of the five different kinds of stored objects Xis illustrated in Figures~\ref{stored_object_1} and \ref{stored_object_2}. X X\begin{figure} X\begin{verbatim} X NOTE: The values in all fields are shown in decimal X X X VALUE FIELD TAG FIELD X +--------------------+---------+ X | 2 | 0 | X +--------------------+---------+ X PAIRS | | X +------------------------------+ X | | X +------------------------------+ X X X X +---------------------+--------+ X | n | 0 | X +---------------------+--------+ X | <0th COMPONENT DESCRIPTOR> | X +------------------------------+ Xn-COMPONENT | <1st COMPONENT DESCRIPTOR> | X VECTORS +------------------------------+ X / . / X \ . \ X / . / X +------------------------------+ X |<(n-1)th COMPONENT DESCRIPTOR>| X +------------------------------+ X X X X +---------------------+--------+ X | n | 0 | X +---------------------+--------+ X |<1st CHARACTER ASCII>| 0 | X +---------------------+--------+ Xn-CHARACTER |<2nd CHARACTER ASCII>| 0 | X SYMBOLS +---------------------+--------+ X / . / X \ . \ X / . / X +---------------------+--------+ X || 0 | X +---------------------+--------+ X\end{verbatim} X\caption{PLScheme stored object representations for pairs, vectors, and symbols.} X\label{stored_object_1} X\end{figure} X X X\begin{figure} X\begin{verbatim} X X X +--------------------+---------+ X | 2 | 0 | X +--------------------+---------+ XPROCEDURES | | 4 | X +------------------------------+ X | | 4 | X +------------------------------+ X X X +--------------------+---------+ X REFS | 1 | 0 | X +--------------------+---------+ X | | X +------------------------------+ X X\end{verbatim} X\caption{PLScheme stored object representations for procedures and refs.} X\label{stored_object_2} X\end{figure} X X\subsection*{Notes} X X\begin{itemize} X X\item Stored objects are represented in exactly the Xsame way on the stack as in the heap. In particular, Xthe state vector representing a continuation (along Xwith any associated temporary variables) is a Xstack-allocated stored object. One of the motivations Xfor having the stack ``grow'' from high addresses to Xlow addresses is that it is easy to push the header Xword on the stack as the last step in making a Xstack-allocated stored object. If environments were X(sometimes, at least) allocated on the stack, they Xcould also be represented as stored objects. X XNote that nothing in the current system actually X{\em makes use} of the fact that stack allocated Xstored objects have the same representation as Xheap allocated stored objects. In fact, all system Xfunctions, including the garbage collector, would Xwork fine even if the stack-allocated objects Xdidn't look like stored-objects at all. The main Xmotivation for using the same format for both Xstack and heap objects is uniformity; such uniformity Xfaciliates extensions and modifications to the Xsystem. X X\item Every symbol is stored only {\em once} in the Xheap. Different occurences of the same symbol within Xa program will end up pointing to the unique occurence Xof the stored symbol object in the heap. This allows Xsymbol equivalence to be determined by pointer Xequivalence, which is much faster than doing a comparison Xof the character vectors associated with a symbol. X XA register called \code{*symbol-table*}\footnote{In most Lisp systems, Xthe data structure keeping track of the symbols is traditionally Xreferred to as the {\em ob-array}.} is used to maintain a list of all Xsymbols entered into the heap so far. Any new symbol is first compared Xwith those in the list. If a match is found, a pointer to the Xalready entered symbol is returned; if no match is found, Xthe symbol is entered into the heap, an entry is added to the Xsymbol table list, and the pointer into the heap is returned. This Xprocess of entering a symbol only once into the heap is called X{\em interning} the symbol. X X% Representation of environments and code X X\end{itemize} X X X\section*{Storage Management} X X\subsection*{Storage Allocation} X XThe heap is represented as two equal-sized {\em areas} of memory, Xwhere an area is a contiguous sequence of words (represented by a Xbegin and end pointer) in addition to the {\em next-available} (also Xoften called {\em free}) pointer. The next-available pointer points to Xthe next word of memory in the sequence available for storage Xallocation. The following invariant is always maintained in the heap Xareas: all words from the next-available word up to and including the Xlast word in the area are available for allocation. X XWhen the storage manager is requested to allocate a Xstored object with a particular tag and size\footnote{This Xis accomplished via a call to \code{allocate-stored-object} Xin our implementation.}, it undertakes the following Xsteps: X X\vspace{.15in} X X\begin{description} X\item Check if $\fun{size} + 1$ contiguous words are available in the Xheap starting at the next-available word. X\end{description} X X\begin{enumerate} X X\item If the words are available, create an uninitialzed stored Xobject by storing $\fun{size}$ in the header word pointed to Xby the next-available pointer, adding $\fun{size} + 1$ to the next-available Xpointer, and return the old value of the next-available pointer Xtagged with the appropriate tag. X X\item If the words are not available, perform a garbage collection Xand check again to see if $\fun{size} + 1$ contiguous words are Xavailable in the heap starting at the (new) next-available word. X X\begin{enumerate} X X\item If the required number of words are now available, return a pointer to Xthe stored object in the same manner described above. X X\item If the words are still not available, fail with Xan ``Out of memory'' error. X X\end{enumerate} X X\end{enumerate} X X\vspace{0.15in} X XNote that the storage allocator returns an uninitialized Xobject (one whose data components all initially contain Xthe unspecified value). Other routines are responsible Xfor filling out the skeleton object returned by the Xstorage allocator. X X\subsection*{Garbage Collection} X XGarbage collection is a means of automatically deallocating Xobjects in the heap that can no longer be accessed. The Xresulting freed space can then be used to allocate new objects. X XThe set of all objects that can be accessed by the interpreter Xare those that can be reached by some number of pointer-following Xsteps from a set of objects that comprise the {\em root} of the Xgarbage collection. In the PLScheme virual machine, the root Xconsists of the contents of all descriptor registers plus the Xcontents of the stack. Thus, the set of all accessible objects Xin memory is the the transitive closure of the ``points to'' operator Xstarting with the objects in the root set. All objects that are not Xin this closure are garbage and the space used to store them Xmay be reclaimed. X XThe garbage collection algorithm used in PLScheme is a X{\em stop-and-copy} garbage collector. The rudiments of this Xalgorithm are outlined below; for a more detailed Xdiscussion, see section 5.4 of Abelson \& Sussman with Sussman. X X XThe stop-and-copy algorithm requires the heap memory to be divided Xinto two half-spaces (that is why there are two equal-sized heap areas Xin the implementation). At any point in time, space is allocated from Xthe currently active half-space known as {\em TOSPACE} (called Xthe \code{*current-area*} in the implementation). A {\em FREE} (i.e. Xnext-available) pointer into the TOSPACE points to the beginning of Xfree memory (from which new stored objects are allocated). When FREE reaches the Xend of the half-space, garbage collection is performed. This is Xaccomplished by: X X\begin{enumerate} X X\item ``Flipping'' the half-spaces so that the former TOSPACE Xis now called FROMSPACE (designated \code{*other-space*} in Xour implementation) and the former FROMSPACE becomes the Xnew TOSPACE. X X\item ``Copying'' the non-garbage structures from FROMSPACE (the half-space Xwhere we just ran out of space) to TOSPACE. Here ``copying'' Xmeans that we create in TOSPACE a set of interconnected Xobjects that's isomorphic to (has the same pointer connectivity as) Xthe accessible objects in FROMSPACE. X X\end{enumerate} X XThe copying mechanism uses two pointers into TOSPACE, SCAN and FREE. The position Xof SCAN in memory is an address that is always less than or equal to Xthe address of the FREE pointer. SCAN and FREE divide the TOSPACE Xinto three distinct sections: X X\begin{enumerate} X X\item The addresses less than SCAN hold objects that have been Xcompletely copied to TOSPACE - i.e. all pointers in any Xdescriptor word in this section point into TOSPACE. X X\item The addresses between SCAN and FREE hold objects whose Xcomponents still point to objects in FROMSPACE. The scanning Xprocess continually copies into TOSPACE those objects FROMSPACE Xthat are still pointed at by pointers in this section. X X\item The addresses greater than or equal to FREE are the section Xof memory in which new Xobjects are allocated. During the copying process, descriptor words Xfrom FROMSPACE are copied to the beginning of this free part of TOSPACE. X X\end{enumerate} X XGarbage collection begins by copying into TOSPACE all words in the Xroot set. SCAN is set to point to the first word of this root set in TOSPACE; XFREE is set to point to the first available word beyond the root Xset in TOSPACE. The SCAN pointer is moved one word at a time Xtowards the free pointer. If the descriptor word currently Xpointed at by SCAN is one with immediate data (a small integer or Xmiscellaneous value), SCAN is simply incremented. However, if the Xword pointed to by SCAN is a pointer, the stored object Xpointed to in FROMSPACE is copied to TOSPACE beginning at the FREE Xpointer, and the new TOSPACE pointer replaces the old XFROMSPACE one in the descriptor word pointed to by SCAN. XThe garbage collector can tell how long the stored object Xis from the header word. FREE is incremented to point to the Xnext free word beyond the most recently copied object. X XWhen SCAN ``catches up'' to FREE (so that they point to the same word Xin TOSPACE), the copying process is done and garbage collection Xis finished. The storage allocator may now again start allocating Xstorage from TOSPACE. X XThe above description of the copying algorithm glosses over Xa subtle detail --- to maintain the appropriate connectivity Xof objects during the copying phase, we must guarantee that Xevery object from FROMSPACE is copied only once to TOSPACE, Xand that objects which pointed to the same FROMSPACE object Xwill all point to its unique copy in TOSPACE when garbage Xcollection is complete. This behavior is accomplished by Xleaving a {\em forwarding address} in a FROMSPACE object Xthat has already been copied to TOSPACE. This forwarding Xaddress replaces the header word of a stored object in XFROMSPACE once it has been moved to the indicated address in XTOSPACE. If the garbage collector later attempts to copy an Xalready-copied object from FROMSPACE, it will see the Xforwarding pointer,\footnote{A forwarding pointer is Xdistinguished from a length header by its tag.} and can Xsimply use this forwarding pointer without performing any Xfurther copying. X XThe stop-and-copy approach has several important beneficial features: X X\begin{enumerate} X X\item Unlike other algorithms (e.g. mark-and-sweep), Xstop-and-copy takes time proportional to the Xnumber of accessible stored objects - not the size of Xmemory. It thus makes sense even for systems with huge Xmemories. X X\item Stop-and-copy also compacts the memory during every garbage Xcollection, which maintains locality of reference for virtual memory Xsystems. X X\item Incremental versions of the stop-and-copy algorithm Xhave been developed. Thus, it is not necessary to stop all Xprocessing while garbage collection takes place; garbage Xcollection can be performed incrementally along with storage Xallocation. X X\end{enumerate} X XHowever, stop-and-copy has the disadvantage of requiring Xlarge memories than some other garbage collection algorithms, Xsince only half of the memory is ``active'' at Xany given time. X X% \subsection*{Bootstrapping} X X X\end{body} X X END_OF_FILE if test 17190 -ne `wc -c <'plscheme/doc/plscheme-2.tex'`; then echo shar: \"'plscheme/doc/plscheme-2.tex'\" unpacked with wrong size! fi # end of 'plscheme/doc/plscheme-2.tex' fi if test -f 'plscheme/pl-ex.scm' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'plscheme/pl-ex.scm'\" else echo shar: Extracting \"'plscheme/pl-ex.scm'\" \(468 characters\) sed "s/^X//" >'plscheme/pl-ex.scm' <<'END_OF_FILE' X;;; examples for the compiler X X(define (c exp) (pp (ctest exp))) X X(define ex1 '(lambda (a) (if a #t (goo 23)))) X X(define ex2 '(lambda (a) (begin (if a #t (goo 23)) X 19))) X X(define ex3 '(lambda (a) (boo (if a #t (goo 23))))) X X(define ex4 '(lambda (a) (if (if a #t (goo 23)) 1 2))) X X(define ex5 '(lambda (a) (if a (if a #t (goo 23)) 2))) X X(define ex6 '(lambda (a) (begin (if a (if a #t (goo 23)) 2) X 19))) X X END_OF_FILE if test 468 -ne `wc -c <'plscheme/pl-ex.scm'`; then echo shar: \"'plscheme/pl-ex.scm'\" unpacked with wrong size! fi # end of 'plscheme/pl-ex.scm' fi if test -f 'plscheme/pl.scm' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'plscheme/pl.scm'\" else echo shar: Extracting \"'plscheme/pl.scm'\" \(82 characters\) sed "s/^X//" >'plscheme/pl.scm' <<'END_OF_FILE' X(load "plscheme.scm") X(load "compiler.scm") X(load "vm.scm") X(load "vm-debug.scm") END_OF_FILE if test 82 -ne `wc -c <'plscheme/pl.scm'`; then echo shar: \"'plscheme/pl.scm'\" unpacked with wrong size! fi # end of 'plscheme/pl.scm' fi if test -f 'plscheme/plscheme.scm' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'plscheme/plscheme.scm'\" else echo shar: Extracting \"'plscheme/plscheme.scm'\" \(2898 characters\) sed "s/^X//" >'plscheme/plscheme.scm' <<'END_OF_FILE' X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; X;;; This is the file PLSCHEME.SCM ;;; X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; X X;;; Should wrpa this up in a way that it's easier X;;; to extend; i.e. should make it easier to add X;;; new opcodes - Lyn X X; Code common to VM and compiler X X; The instruction set X X(define special-opcodes X '(check-nargs X make-environment X load-constant X load-variable X set-variable X make-procedure X push X call X make-continuation ;for non-tail-calls X return X leave-environment X jump-if-false X jump)) X X(define primitive-opcodes ;open-codeable procedures X '((eq? 2) X (integer? 1) X (+ 2) X (- 2) X (* 2) X (= 2) X (< 2) X (quotient 2) X (remainder 2) X (pair? 1) X (cons 2) X (car 1) X (cdr 1) X (set-car! 2) X (set-cdr! 2) X (ref? 1) X (ref 1) X (get 1) X (put! 2) X (vector? 1) X (make-vector 2) X (vector-length 1) X (vector-ref 2) X (vector-set! 3) X (read 0) X (write 1) X (display 1) X (newline 0))) X X(define opcodes-vector X (list->vector (append special-opcodes (map car primitive-opcodes)))) X X(define number-of-opcodes X (vector-length opcodes-vector)) X X(define (opcode-name opcode) X (vector-ref opcodes-vector opcode)) X X(define (opcode name) X (let loop ((opcode 0)) X (cond ((>= opcode number-of-opcodes) (error "no such opcode" name)) X ((eq? name (opcode-name opcode)) opcode) X (else (loop (+ opcode 1)))))) X X; The following kludge is necessary to enforce the #f/() distinction X; in the VM even if the distinction isn't enforced in the Scheme in X; which the VM runs. An analogous paranoia about #t and a standard X; unspecified value is humored. X X(define (mistakable? x) ;Don't pay any attention to this X (or (null? x) (symbol? x) (number? x) (pair? x) (string? x) (char? x) X (vector? x) (procedure? x))) X X(define upper-case? (char=? (string-ref (symbol->string 'a) 0) #\A)) X X(define false (if (mistakable? #f) X (string->symbol (if upper-case? "#F" "#f")) X #f)) X(define true (if (mistakable? #t) X (string->symbol (if upper-case? "#T" "#t")) X #t)) X(define unspecified (let ((u (set-car! (cons 1 2) 3))) X (if (mistakable? u) X (string->symbol (if upper-case? X "#" X "#")) X u))) END_OF_FILE if test 2898 -ne `wc -c <'plscheme/plscheme.scm'`; then echo shar: \"'plscheme/plscheme.scm'\" unpacked with wrong size! fi # end of 'plscheme/plscheme.scm' fi if test -f 'plscheme/vm-debug.scm' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'plscheme/vm-debug.scm'\" else echo shar: Extracting \"'plscheme/vm-debug.scm'\" \(1894 characters\) sed "s/^X//" >'plscheme/vm-debug.scm' <<'END_OF_FILE' X(define *stack-trace?* #f) X X(define (vm-trace) (set! *stack-trace?* #t) (set! *trace?* #t)) X(define (vm-untrace) (set! *stack-trace?* #f) (set! *trace?* #f)) X X(define-opcode 'call X (lambda () X (display-stack) X (let ((nargs (next-instruction-integer))) X; (assert (= (+ (fetch *sp*) nargs) X; (address-of-length-cell (fetch *cont*))) X; 'call) X (start-call (fetch *val*) nargs)))) X X(define display-stack X (lambda () X (newline) X (newline) X (display "Stack") X (newline) X (display "-----") X (newline) X (let ((end (area-end *stack-area*))) X (do ((sp (fetch *sp*) (+ sp 1))) X ((= sp end) (display 'BOTTOM-OF-STACK)) X (newline) X (display-descriptor (vector-ref *memory* sp)))))) X X(define display-descriptor X (lambda (desc) X (display-tag desc) X (display ": ") X (display-data desc))) X X(define display-tag X (lambda (desc) X (display (table-lookup (descriptor-tag desc) X tag-table X (lambda () (error "unrecognized-tag")))))) X X(define display-data X (lambda (desc) X (if (miscellaneous? desc) X (display-miscellaneous (descriptor-data desc)) X (display (descriptor-data desc))))) X X(define display-miscellaneous X (lambda (data) X (display (table-lookup data X misc-table X (lambda () (error "Unknown MISC value")))))) X X X(define miscellaneous? X (lambda (desc) X (eq? (table-lookup (descriptor-tag desc) X tag-table X (lambda () (error "Unknown tag"))) X 'MISC))) X X(define table-lookup X (lambda (key table error-thunk) X (let ((probe (assoc key table))) X (if probe X (cdr probe) X (error-thunk))))) X X(define misc-table X '((0 . FALSE) X (1 . TRUE) X (2 . EMPTY-LIST) X (3 . UNSPECIFIED) X (4 . UNDEFINED))) X X(define tag-table X '((0 . INT) X (1 . MISC) X (2 . RESERVED) X (3 . PAIR) X (4 . VECTOR) X (5 . SYMBOL) X (6 . PROCEDURE) X (7 . REF))) X END_OF_FILE if test 1894 -ne `wc -c <'plscheme/vm-debug.scm'`; then echo shar: \"'plscheme/vm-debug.scm'\" unpacked with wrong size! fi # end of 'plscheme/vm-debug.scm' fi echo shar: End of archive 1 \(of 2\). cp /dev/null ark1isdone MISSING="" for I in 1 2 ; do if test ! -f ark${I}isdone ; then MISSING="${MISSING} ${I}" fi done if test "${MISSING}" = "" ; then echo You have unpacked both archives. rm -f ark[1-9]isdone else echo You still need to unpack the following archives: echo " " ${MISSING} fi ## End of shell archive. exit 0