Initial fork
This commit is contained in:
commit
70716dfeb3
|
|
@ -0,0 +1,23 @@
|
|||
# Makefile for miniscm
|
||||
#
|
||||
# This defaults to using ANSI C on 4.3 BSD-flavoured UNIX (which is
|
||||
# compatible with many modern Unices, including Linux). You may select a
|
||||
# different flavour of UNIX, or a pre-ANSI version of C, by telling make
|
||||
# to override the CC and/or CFLAGS variables.
|
||||
# Please see source and/or README for system definition #define's.
|
||||
#
|
||||
# Examples:
|
||||
# CFLAGS = -g -DSYSV -traditional -traditional-cpp -Wid-clash-8
|
||||
# CFLAGS = -O -DSYSV
|
||||
|
||||
CC ?= gcc
|
||||
CFLAGS ?= -O -ansi -pedantic -DBSD -DCMDLINE
|
||||
|
||||
all : miniscm
|
||||
|
||||
miniscm : miniscm.c Makefile
|
||||
$(CC) $(CFLAGS) -o miniscm miniscm.c
|
||||
|
||||
clean :
|
||||
rm -f core *.o miniscm *~
|
||||
|
||||
|
|
@ -0,0 +1,252 @@
|
|||
This is Cat's Eye Technologies' fork of the original Mini-Scheme
|
||||
implementation, miniscm, by Atsushi Moriwaki. The original README can
|
||||
be found below, following the first line of equals signs in this file.
|
||||
|
||||
My understanding is that Akira KIDA is no longer actively maintaining
|
||||
this project, and that the Mini-Scheme language and miniscm reference
|
||||
implementation effectively have no maintainer. It is not my objective
|
||||
to become the new maintainer of the language or implementation; rather,
|
||||
it is simply to provide a modernized and generally backwards-compatible
|
||||
source base for miniscm.
|
||||
|
||||
This code was forked from version 0.85k4. The current version of this
|
||||
fork is 0.85ce1. (I elected to use "ce" for "Cat's Eye" because "p" for
|
||||
"Pressey" is too easily confused with "patchlevel".)
|
||||
|
||||
Some improvements that have been made:
|
||||
|
||||
- modernized Makefile (defaults to 4.3 BSD, which works for Linux)
|
||||
- removed compiler warnings (under 4.3 BSD)
|
||||
- made compilable under AmigaOS 1.3 with DICE C
|
||||
- added -q command line option to suppress all non-explicit output
|
||||
(this includes the prompt; if you want output, use (display))
|
||||
- added -e command line option to cause all errors to be treated
|
||||
as fatal errors (exit interpreter immediately with error code 1)
|
||||
|
||||
Some further improvements I might consider:
|
||||
|
||||
- add -i command line option to specify the location of init.scm
|
||||
- add -l command line option to disable abbreviated quote output
|
||||
- allow source file(s) to be specified on command line
|
||||
|
||||
If you are interested in a more developed and actively maintained
|
||||
Scheme implementation which started as a fork of miniscm, check out
|
||||
the BSD-licensed TinyScheme: http://tinyscheme.sourceforge.net/
|
||||
|
||||
There is also another fork of miniscm on Sourceforge with the name
|
||||
"minischeme", although at 2 megabytes, I'm not sure it deserves the
|
||||
appelation "mini" any more: http://sourceforge.net/projects/minischeme/
|
||||
|
||||
-Chris
|
||||
|
||||
=====================================================================
|
||||
|
||||
---------- Mini-Scheme Interpreter Version 0.85 ----------
|
||||
|
||||
coded by Atsushi Moriwaki (11/5/1989)
|
||||
|
||||
E-MAIL : moriwaki@kurims.kurims.kyoto-u.ac.jp
|
||||
MIX : riemann
|
||||
NIFTY : PBB01074
|
||||
(Note that these addresses are now obsolete, see below)
|
||||
|
||||
=====================================================================
|
||||
|
||||
Revised by Akira KIDA
|
||||
|
||||
Version 0.85k4 (17 May 1994)
|
||||
Version 0.85k3 (30 Nov 1989)
|
||||
Version 0.85k2 (28 Nov 1989)
|
||||
Version 0.85k1 (14 Nov 1989)
|
||||
|
||||
Mini-Scheme is now maintained by Akira KIDA.
|
||||
|
||||
E-Mail : SDI00379@niftyserve.or.jp
|
||||
|
||||
Most part of this document is written by Akira KIDA.
|
||||
Send comments/requests/bug reports to Akira KIDA at the above
|
||||
email address.
|
||||
|
||||
=====================================================================
|
||||
|
||||
This Mini-Scheme Interpreter is based on "SCHEME Interpreter in
|
||||
Common Lisp" in Appendix of T.Matsuda & K.Saigo, Programming of LISP,
|
||||
archive No5 (1987) p6 - p42 (published in Japan).
|
||||
|
||||
|
||||
Copyright Notice:
|
||||
THIS SOFTWARE IS PLACED IN THE PUBLIC DOMAIN BY THE AUTHOR.
|
||||
|
||||
This software is completely free to copy, modify and/or re-distribute.
|
||||
But I (Atsushi Moriwaki) would appreciate it if you left my name on the
|
||||
code as the author.
|
||||
|
||||
DISCLAIMER:
|
||||
THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR
|
||||
IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
|
||||
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
PURPOSE.
|
||||
|
||||
|
||||
Supported features (or, NOT supported features :-)
|
||||
1) Lists, symbols, strings.
|
||||
However, strings have very limited capability.
|
||||
For instance, there is *NO* string-ref, string-set!, ... etc.
|
||||
2) Numbers are limited to FIXNUM only.
|
||||
There is *NO* complex, real, rational and even bignum.
|
||||
3) Macro feature is supported, though not the one defined in R4RS.
|
||||
|
||||
Known problems:
|
||||
1) Poor error recovery from illegal use of syntax and procedure.
|
||||
2) Certain procedures do not check its argument type.
|
||||
|
||||
Installation:
|
||||
1) Select system declaration and configuration options by editing
|
||||
source file.
|
||||
|
||||
You may choose one of the following systems by #define'ing
|
||||
the preprocessor symbol.
|
||||
|
||||
Supported systems are:
|
||||
Macintosh:
|
||||
LSC -- LightSpeed C (3.0) for Macintosh
|
||||
LSC4 -- LightSpeed C (4.0) for Macintosh
|
||||
They are different in #include header only.
|
||||
I (kida) think THINK C 5.0, 6.0, 7.0 may be OK
|
||||
with LSC4 configuration, though not tested.
|
||||
MPW2 -- Macintosh Programmer's Workshop v2.0x
|
||||
I don't tested v3.x or later.
|
||||
DOS:
|
||||
MSC4 -- Microsoft C v4.0 (use /AL)
|
||||
MSC v5.1, v6.0, v7.0 are all OK.
|
||||
TURBO2 -- Bolarnd's Turbo C v2.0 (use -ml)
|
||||
Turbo C++ 1.0 is OK.
|
||||
UNIX:
|
||||
BSD -- UNIX of BSD flavor, ex. SuOS 4.x
|
||||
SYSV -- UNIX of System-V flavor, ex. Sun/Solaris 2.x
|
||||
|
||||
VAX/VMS:
|
||||
VAXC -- VAX-C v3.x (this symbol may be defined by the
|
||||
compiler automatically).
|
||||
|
||||
2) Configure some preprocessor symbols by editing source files.
|
||||
|
||||
Configurable #define's are:
|
||||
|
||||
#define VERBOSE
|
||||
-- if defined, GC messages is verbose on default.
|
||||
|
||||
#define AVOID_HACK_LOOP
|
||||
-- if defined, do _NOT_ use loop construction in the
|
||||
form
|
||||
do { ... } while (0)
|
||||
This form is used in macro expansion, since this is
|
||||
the best "safety" blocking construct when used in
|
||||
macro definition.
|
||||
However, some compiler (including SunPRO CC 2.0.1)
|
||||
is silly enough to warning this construct, like
|
||||
"warning: end-of-loop code not reached", etc.
|
||||
If you dislike such warning, please define this symbol.
|
||||
NOTE: You may get some "statement not reached" warning
|
||||
even if you have define this symbol. Please be patient,
|
||||
or, use more smart compiler.
|
||||
In short if you use GCC, undefine this and forget it
|
||||
at all.
|
||||
|
||||
#define USE_SETJMP
|
||||
-- if defined, use setjmp to global jump on error.
|
||||
if not defined, avoid to use it. Compiled with
|
||||
this symbol defined, the interpreter issue fatal
|
||||
error and return to the operating system immediately
|
||||
when we run out of free cells. By default, i.e.,
|
||||
compiled with this symbol is not defined, the
|
||||
interpreter will just return to the top level in
|
||||
such a case.
|
||||
May not be used except for compiling as Mac DA.
|
||||
|
||||
#define USE_MACRO
|
||||
-- if defined, macro features are enabled.
|
||||
|
||||
#define USE_QQUOTE
|
||||
-- if defined, you can use quasi-quote "`" in macro.
|
||||
You can use macro even if this symbol is undefined.
|
||||
|
||||
3) Compile!
|
||||
|
||||
I think there is virtually no problem about how to compile.
|
||||
Since there is exactly one C source file. :-)
|
||||
If you are on UNIX boxes with some BSD flavors, instead of
|
||||
using make command, it's enough to type:
|
||||
|
||||
cc -DBSD -O -o miniscm miniscm.c
|
||||
|
||||
You may have additional warnings like 'function should
|
||||
return value'. This is due to omitting 'void' keyword
|
||||
from the source in order to get pre-ANSI compatibility.
|
||||
|
||||
|
||||
Usage : miniscm
|
||||
|
||||
Sorry, no command line argnumet is allowed.
|
||||
|
||||
|
||||
Special procedures of this system:
|
||||
|
||||
gc : (gc) -- force garbage collection
|
||||
|
||||
gc-verbose : (gc-verbose bool) -- GC verbose on/off
|
||||
Argument #f turnes off the GC message.
|
||||
Enything else turn on the GC message.
|
||||
|
||||
quit : (quit) -- quit to the operating system
|
||||
|
||||
put : (put sym prop expr)
|
||||
-- set the value of a property of a symbol.
|
||||
get : (get sym prop)
|
||||
-- get the value of a property of a symbol.
|
||||
|
||||
new-segment : (new-segment n)
|
||||
-- allocate n new cell segments.
|
||||
|
||||
print-width : (print-width list)
|
||||
-- returns 'printed' width of list.
|
||||
|
||||
closure? : (closure? obj)
|
||||
-- test if obj is a closure or not.
|
||||
|
||||
macro? : (macro? obj)
|
||||
-- test if obj is a macro or not.
|
||||
note that a macro is also a closure.
|
||||
|
||||
get-closure-code
|
||||
: (get-closure-code closure-obj)
|
||||
-- extract S-expr from closure-obj.
|
||||
|
||||
Scheme files:
|
||||
init.scm -- Automatically loaded at invocation.
|
||||
Default setting assumes that this file is in the current
|
||||
working directory.
|
||||
Change #define InitFile if you don't like it.
|
||||
|
||||
tools.scm -- This is a sample file. Contains very tiny pretty-print
|
||||
procedure.
|
||||
After invoking miniscm, type:
|
||||
(load "tools.scm")
|
||||
and try
|
||||
(pp getd)
|
||||
(pp do)
|
||||
|
||||
Documents?:
|
||||
|
||||
Sorry, there is no other documents.
|
||||
Do not ask one for me, please see the source instead. :-)
|
||||
|
||||
But if you _absolutely_ need help, please email to me at:
|
||||
<SDI00379@niftyserve.or.jp>
|
||||
|
||||
Enjoy!
|
||||
|
||||
-- Akira KIDA
|
||||
Sysop for FPL in NIFTY-Serve in JAPAN.
|
||||
(FPL stands for 'Forum for Program-Language')
|
||||
|
||||
|
|
@ -0,0 +1,156 @@
|
|||
; This is a init file for Mini-Scheme.
|
||||
|
||||
;; fake pre R^3 boolean values
|
||||
(define nil #f)
|
||||
(define t #t)
|
||||
|
||||
(define (caar x) (car (car x)))
|
||||
(define (cadr x) (car (cdr x)))
|
||||
(define (cdar x) (cdr (car x)))
|
||||
(define (cddr x) (cdr (cdr x)))
|
||||
(define (caaar x) (car (car (car x))))
|
||||
(define (caadr x) (car (car (cdr x))))
|
||||
(define (cadar x) (car (cdr (car x))))
|
||||
(define (caddr x) (car (cdr (cdr x))))
|
||||
(define (cdaar x) (cdr (car (car x))))
|
||||
(define (cdadr x) (cdr (car (cdr x))))
|
||||
(define (cddar x) (cdr (cdr (car x))))
|
||||
(define (cdddr x) (cdr (cdr (cdr x))))
|
||||
|
||||
(define call/cc call-with-current-continuation)
|
||||
|
||||
(define (list . x) x)
|
||||
|
||||
(define (map proc list)
|
||||
(if (pair? list)
|
||||
(cons (proc (car list)) (map proc (cdr list)))))
|
||||
|
||||
(define (for-each proc list)
|
||||
(if (pair? list)
|
||||
(begin (proc (car list)) (for-each proc (cdr list)))
|
||||
#t ))
|
||||
|
||||
(define (list-tail x k)
|
||||
(if (zero? k)
|
||||
x
|
||||
(list-tail (cdr x) (- k 1))))
|
||||
|
||||
(define (list-ref x k)
|
||||
(car (list-tail x k)))
|
||||
|
||||
(define (last-pair x)
|
||||
(if (pair? (cdr x))
|
||||
(last-pair (cdr x))
|
||||
x))
|
||||
|
||||
(define (head stream) (car stream))
|
||||
|
||||
(define (tail stream) (force (cdr stream)))
|
||||
|
||||
;; The following quasiquote macro is due to Eric S. Tiedemann.
|
||||
;; Copyright 1988 by Eric S. Tiedemann; all rights reserved.
|
||||
;;
|
||||
;; --- If you don't use macro or quasiquote, cut below. ---
|
||||
|
||||
(macro
|
||||
quasiquote
|
||||
(lambda (l)
|
||||
(define (mcons f l r)
|
||||
(if (and (pair? r)
|
||||
(eq? (car r) 'quote)
|
||||
(eq? (car (cdr r)) (cdr f))
|
||||
(pair? l)
|
||||
(eq? (car l) 'quote)
|
||||
(eq? (car (cdr l)) (car f)))
|
||||
(list 'quote f)
|
||||
(list 'cons l r)))
|
||||
(define (mappend f l r)
|
||||
(if (or (null? (cdr f))
|
||||
(and (pair? r)
|
||||
(eq? (car r) 'quote)
|
||||
(eq? (car (cdr r)) '())))
|
||||
l
|
||||
(list 'append l r)))
|
||||
(define (foo level form)
|
||||
(cond ((not (pair? form)) (list 'quote form))
|
||||
((eq? 'quasiquote (car form))
|
||||
(mcons form ''quasiquote (foo (+ level 1) (cdr form))))
|
||||
(#t (if (zero? level)
|
||||
(cond ((eq? (car form) 'unquote) (car (cdr form)))
|
||||
((eq? (car form) 'unquote-splicing)
|
||||
(error "Unquote-splicing wasn't in a list:"
|
||||
form))
|
||||
((and (pair? (car form))
|
||||
(eq? (car (car form)) 'unquote-splicing))
|
||||
(mappend form (car (cdr (car form)))
|
||||
(foo level (cdr form))))
|
||||
(#t (mcons form (foo level (car form))
|
||||
(foo level (cdr form)))))
|
||||
(cond ((eq? (car form) 'unquote)
|
||||
(mcons form ''unquote (foo (- level 1)
|
||||
(cdr form))))
|
||||
((eq? (car form) 'unquote-splicing)
|
||||
(mcons form ''unquote-splicing
|
||||
(foo (- level 1) (cdr form))))
|
||||
(#t (mcons form (foo level (car form))
|
||||
(foo level (cdr form)))))))))
|
||||
(foo 0 (car (cdr l)))))
|
||||
|
||||
;;;;; following part is written by a.k
|
||||
|
||||
;;;; atom?
|
||||
(define (atom? x)
|
||||
(not (pair? x)))
|
||||
|
||||
;;;; memq
|
||||
(define (memq obj lst)
|
||||
(cond
|
||||
((null? lst) #f)
|
||||
((eq? obj (car lst)) lst)
|
||||
(else (memq obj (cdr lst)))))
|
||||
|
||||
;;;; equal?
|
||||
(define (equal? x y)
|
||||
(if (pair? x)
|
||||
(and (pair? y)
|
||||
(equal? (car x) (car y))
|
||||
(equal? (cdr x) (cdr y)))
|
||||
(and (not (pair? y))
|
||||
(eqv? x y))))
|
||||
|
||||
|
||||
;;;; (do ((var init inc) ...) (endtest result ...) body ...)
|
||||
;;
|
||||
(macro do
|
||||
(lambda (do-macro)
|
||||
(apply (lambda (do vars endtest . body)
|
||||
(let ((do-loop (gensym)))
|
||||
`(letrec ((,do-loop
|
||||
(lambda ,(map (lambda (x)
|
||||
(if (pair? x) (car x) x))
|
||||
`,vars)
|
||||
(if ,(car endtest)
|
||||
(begin ,@(cdr endtest))
|
||||
(begin
|
||||
,@body
|
||||
(,do-loop
|
||||
,@(map (lambda (x)
|
||||
(cond
|
||||
((not (pair? x)) x)
|
||||
((< (length x) 3) (car x))
|
||||
(else (car (cdr (cdr x))))))
|
||||
`,vars)))))))
|
||||
(,do-loop
|
||||
,@(map (lambda (x)
|
||||
(if (and (pair? x) (cdr x))
|
||||
(car (cdr x))
|
||||
nil))
|
||||
`,vars)))))
|
||||
do-macro)))
|
||||
|
||||
;;;;; following part is written by c.p
|
||||
|
||||
(define (list? x)
|
||||
(or (eq? x '())
|
||||
(and (pair? x)
|
||||
(list? (cdr x)))))
|
||||
|
|
@ -0,0 +1,27 @@
|
|||
;;;; Sample of co-routine by call/cc
|
||||
(define (apply-to-next-leaf proc tree endmark)
|
||||
(letrec
|
||||
((return #f)
|
||||
(cont (lambda (l)
|
||||
(recurse l)
|
||||
(set! cont (lambda (d) (return endmark)))
|
||||
(cont #f)))
|
||||
(recurse (lambda (l)
|
||||
(if (pair? l)
|
||||
(for-each recurse l)
|
||||
(call/cc (lambda (c) (set! cont c) (return (proc l))))))))
|
||||
(lambda ()
|
||||
(call/cc (lambda (c) (set! return c) (cont tree))))))
|
||||
|
||||
(define (foo lis)
|
||||
(let ((bar (apply-to-next-leaf (lambda (x) (* x x)) lis '())))
|
||||
(let loop ((n (bar)))
|
||||
(if (not (null? n))
|
||||
(begin
|
||||
(display n)
|
||||
(newline)
|
||||
(loop (bar)))))))
|
||||
|
||||
;; foo prints each elements (leaves) squared
|
||||
(foo '(1 2 (3 (4 5) (6 (7)) 8) 9 10))
|
||||
|
||||
|
|
@ -0,0 +1,223 @@
|
|||
;;;; A Very Tiny Pretty Printer (VtPP) for Mini-Scheme
|
||||
;;;
|
||||
;;; Date written 28-Nov-1989 by Akira Kida
|
||||
;;; Date revised 24-Jan-1990 by Atsushi Moriwaki
|
||||
;;; Date revised 17-May-1994 by Akira Kida
|
||||
;;;
|
||||
|
||||
;; Columns of display device.
|
||||
(define *pp-display-width* 80)
|
||||
|
||||
;; Margin of display-width
|
||||
;; 8 means 80% of *pp-display-width*, i.e., if *pp-display-width* is
|
||||
;; set to 80, the result is 64. The prety-print procedure will watch
|
||||
;; for the current output column, and if the output seem to exceed
|
||||
;; this limit, it tries to insert newlines somewhere in the current
|
||||
;; sub-list. However, sometimes this may fail, and output may get even
|
||||
;; longer than *pp-display-width*. This is a feature, not a bug. :-)
|
||||
(define *pp-display-margin* 8)
|
||||
|
||||
;; Number of elements will possibly be displayed in one line.
|
||||
;; pretty-print will never display more then this number of elements
|
||||
;; on a single physical line. There is no feature around this. :-)
|
||||
(define *pp-display-elements* 12)
|
||||
|
||||
|
||||
;;; print n spaces
|
||||
(define (spaces n)
|
||||
(if (positive? n)
|
||||
(begin
|
||||
(display " ")
|
||||
(spaces (- n 1)))))
|
||||
|
||||
|
||||
;;; get definition of a procedure or a macro
|
||||
(define (getd symbol)
|
||||
(if (not (symbol? symbol))
|
||||
(error "getd: expects symbol value"))
|
||||
(let ((code (eval symbol)))
|
||||
(cond
|
||||
;; since a closure is also a macro, we should check macro first.
|
||||
((macro? code)
|
||||
(let ((def (get-closure-code code)))
|
||||
(cons 'macro (list symbol def))))
|
||||
((closure? code)
|
||||
(let ((def (get-closure-code code)))
|
||||
(cons
|
||||
'define
|
||||
(cons
|
||||
(cons symbol (car (cdr def)))
|
||||
(cdr (cdr def))))))
|
||||
(else
|
||||
;; if symbol is not a macro nor closure,
|
||||
;; we shall generate error function call code.
|
||||
(list 'error "Not a S-Expression procedure:" (list 'quote symbol))))))
|
||||
|
||||
|
||||
;;; pretty printer main procedure
|
||||
;;;
|
||||
(define (pretty-print a-list)
|
||||
; List of procedures which need exceptional handling.
|
||||
; Structure or each element in the list is
|
||||
;
|
||||
; (name . special-indentation)
|
||||
;
|
||||
; where name is a symbol and
|
||||
; special-indentation is an integer.
|
||||
;
|
||||
; #1 Standard format, non special case.
|
||||
; (proc
|
||||
; arg1
|
||||
; arg2
|
||||
; arg3)
|
||||
;
|
||||
; #2 Format for special-indentation == 0
|
||||
; (proc arg1
|
||||
; arg2
|
||||
; arg3)
|
||||
;
|
||||
; #3 Format for special-indentation == 1
|
||||
; (proc arg1
|
||||
; arg2
|
||||
; arg3)
|
||||
;
|
||||
; #4 Format for let style = 2
|
||||
; (let ((x .....)
|
||||
; (y .....))
|
||||
; <....>
|
||||
; <....>)
|
||||
;
|
||||
(define exception
|
||||
'((lambda . 0) (if . 0) (and . 1)
|
||||
(or . 1) (let . 2) (case . 0)
|
||||
(define . 0) (macro . 0)
|
||||
(map . 0) (apply . 0)
|
||||
(eq? . 1) (eqv? . 1) (set! . 0)
|
||||
(let* . 2) (letrec . 2)
|
||||
(* . 1) (/ . 1) (+ . 1) (- . 1)
|
||||
(= . 1) (< . 1) (> . 1) (<= . 1) (>= . 1)
|
||||
(do . 2)
|
||||
(call-with-input-file . 0) (call-with-output-file . 0)))
|
||||
; special quote abbrev.
|
||||
(define special
|
||||
'((quote 1 . "'") (quasiquote 1 . "`")
|
||||
(unquote 2 . ",") (unquote-splicing 2 . ",@")))
|
||||
; calculate appropriate margins
|
||||
(define pp-margin (/ (* *pp-display-width* *pp-display-margin*) 10))
|
||||
; check whether the number of elements exceeds n or not.
|
||||
(define (less-than-n-elements? a-list n)
|
||||
; count elements in a-list at most (n+1)
|
||||
(define (up-to-nth a-list n c)
|
||||
(cond
|
||||
((null? a-list) c)
|
||||
((pair? a-list)
|
||||
(set! c (up-to-nth (car a-list) n c))
|
||||
(if (< n c)
|
||||
c
|
||||
(up-to-nth (cdr a-list) n c)))
|
||||
(else (+ c 1))))
|
||||
(< (up-to-nth a-list n 0) n))
|
||||
; check if the length is fit within n columns or not.
|
||||
(define (fit-in-n-width? a-list n)
|
||||
(< (print-width a-list) n))
|
||||
; indent and pretty-print
|
||||
(define (do-pp a-list col)
|
||||
(spaces col)
|
||||
(pp-list a-list col 2))
|
||||
;; main logic.
|
||||
(define (pp-list a-list col step)
|
||||
(cond
|
||||
((atom? a-list) (write a-list)) ; atom
|
||||
((and (assq (car a-list) special)
|
||||
(pair? (cdr a-list))
|
||||
(null? (cddr a-list))) ; check for proper quote etc.
|
||||
(let ((s (assq (car a-list) special)))
|
||||
(display (cddr s)) ; display using abbrev.
|
||||
(pp-list
|
||||
(cadr a-list)
|
||||
(+ col (- (print-width (cddr s)) 2))
|
||||
(cadr s))))
|
||||
((and (less-than-n-elements? a-list *pp-display-elements*)
|
||||
(fit-in-n-width? a-list (- pp-margin col)))
|
||||
(display "(")
|
||||
(do-pp (car a-list) 0)
|
||||
(pp-args #f (cdr a-list) 1))
|
||||
(else ; long list.
|
||||
(let* ((sym (car a-list))
|
||||
(ex-col (assq sym exception)))
|
||||
(if (pair? ex-col) ; check for exception.,
|
||||
(case (cdr ex-col)
|
||||
((0 1)
|
||||
(display "(")
|
||||
(write sym)
|
||||
(display " ")
|
||||
(pp-list (cadr a-list) (+ col 2 (print-width sym)) 2)
|
||||
(pp-args
|
||||
#t
|
||||
(cdr (cdr a-list))
|
||||
(+ col 2 (if (zero? (cdr ex-col)) 0 (print-width sym)))))
|
||||
((2)
|
||||
(display "(")
|
||||
(write sym)
|
||||
(display " ")
|
||||
(if (symbol? (cadr a-list))
|
||||
(begin ; named let
|
||||
(write (cadr a-list))
|
||||
(display " ")
|
||||
(pp-list
|
||||
(caddr a-list)
|
||||
(+ col 3 (print-width sym) (print-width (cadr a-list)))
|
||||
1)
|
||||
(pp-args #t (cdddr a-list) (+ col 2)))
|
||||
(begin ; usual let
|
||||
(pp-list (cadr a-list) (+ col 2 (print-width sym)) 1)
|
||||
(pp-args #t (cddr a-list) (+ col 2)))))
|
||||
(else
|
||||
(error "Illegal exception")))
|
||||
(begin ; normal case.
|
||||
(display "(")
|
||||
(pp-list (car a-list) (+ col 1) 2)
|
||||
(pp-args #t (cdr a-list) (+ col step))))))))
|
||||
;; display arguments
|
||||
(define (pp-args nl a-list col)
|
||||
(cond
|
||||
((null? a-list) (display ")"))
|
||||
((pair? a-list)
|
||||
(if nl (newline))
|
||||
(do-pp (car a-list) col)
|
||||
(pp-args nl (cdr a-list) col))
|
||||
(else
|
||||
(display " . ")
|
||||
(write a-list)
|
||||
(display ")"))))
|
||||
;;
|
||||
;; main of pretty-print begins here.
|
||||
;;
|
||||
(do-pp a-list 0)
|
||||
(newline))
|
||||
|
||||
|
||||
|
||||
;;; pretty print procedure(s)/macro(s).
|
||||
;;; (pretty 'a-symbol) ; pretty print a procedure or macro
|
||||
;;; (pretty '(sym1 sym2 ...)) ; pretty print procedures and/or macros
|
||||
(define (pretty symbols)
|
||||
(if (pair? symbols)
|
||||
(for-each
|
||||
(lambda (x) (pretty-print (getd x)) (newline))
|
||||
symbols)
|
||||
(pretty-print (getd symbols))))
|
||||
|
||||
|
||||
|
||||
;;; pretty print user-interface
|
||||
;;;
|
||||
;;; usage:
|
||||
;;; (pp sym1 sym2 ...) ; obtain procedure/macro definitions in sequence
|
||||
;;;
|
||||
;;; Note: pp never evaluate its argument, so you do not have to specify
|
||||
;;; (pp 'proc-name). Use (pp proc-name) instead.
|
||||
;;;
|
||||
(macro pp (lambda (pp-macro)
|
||||
`(pretty ',(cdr pp-macro))))
|
||||
|
||||
Loading…
Reference in New Issue