;; Standard Library Procedures and Macros ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; MISC ESSENTIAL PROCEDURES
+
+(define list
+ (lambda args args))
+
+(define map
+ (lambda (proc l)
+ (if (null? l)
+ '()
+ (cons (proc (car l)) (map proc (cdr l))))))
+
+(define join-lists
+ (lambda (l1 l2)
+ (if (null? l1)
+ l2
+ (cons (car l1) (join-lists (cdr l1) l2)))))
+
+; Append an arbitrary number of lists together
+(define append
+ (lambda lists
+ (if (null? lists)
+ ()
+ (if (null? (cdr lists))
+ (car lists)
+ (join-lists (car lists) (apply append (cdr lists)))))))
+
+
;; DERIVED FORMS
-;; define (procedural syntax)
+;; define
(define-macro (define args . body)
(if (pair? args)
- `(define ,(car args) (lambda ,(cdr args) ,@body))
+ (list 'define (car args) (join-lists (list 'lambda (cdr args)) body))
'no-match))
+;; not
+
+(define-macro (not x)
+ (list 'if x #f #t))
+
+;; let
+
+(define-macro (let args . body)
+ (join-lists
+ (list (join-lists (list 'lambda (map (lambda (x) (car x)) args)) body))
+ (map (lambda (x) (car (cdr x))) args)))
+
+;; quasiquote/unquote (one nesting level only)
+
+((lambda ()
+ (define (qqhelper l)
+ (if (null? l)
+ l
+ (let ((head (car l))
+ (tail (cdr l)))
+
+ (if (pair? head)
+ (if (eq? (car head) 'unquote)
+ (list 'cons (car (cdr head)) (qqhelper tail))
+ (if (eq? (car head) 'unquote-splicing)
+ (list 'join-lists (car (cdr head)) (qqhelper tail))
+ (list 'cons (list 'quasiquote head) (qqhelper tail))))
+ (if (symbol? head)
+ (list 'cons (list 'quote head) (qqhelper tail))
+ (list 'cons head (qqhelper tail)))))))
+
+ (define-macro (quasiquote arg)
+ (if (not (pair? arg))
+ (list 'quote arg)
+ (qqhelper arg)))))
+
;; begin
(define-macro (begin . sequence)
(define-macro (cdddr l) `(cdr (cdr (cdr ,l))))
(define-macro (cadddr l) `(car (cdr (cdr (cdr ,l)))))
-
-;; Methods used in remaining macro definitions:
-
-(define (map proc l)
- (if (null? l)
- '()
- (cons (proc (car l)) (map proc (cdr l)))))
-
-;; let
-
-(define-macro (let args . body)
- `((lambda ,(map (lambda (x) (car x)) args)
- ,@body) ,@(map (lambda (x) (cadr x)) args)))
-
;; let*
(define-macro (let* args . body)
(define-macro (and . expressions)
(if (null? expressions)
#t
- (expand-and-expressions expressions)))
- ))
+ (expand-and-expressions expressions)))))
;; or
((lambda ()
(define (expand-or-expressions expressions)
- (if (null? expressions)
- #f
- (let ((first (car expressions))
- (rest (cdr expressions))
- (val (gensym)))
- `(let ((,val ,first))
- (if ,val
- ,val
- ,(expand-or-expressions rest))))))
+ (let ((first (car expressions))
+ (rest (cdr expressions)))
+ (if (null? rest)
+ first
+ `(if ,first
+ #t
+ ,(expand-or-expressions rest)))))
(define-macro (or . expressions)
- (expand-or-expressions expressions))
- ))
-
-;; not
-
-(define-macro (not x)
- `(if ,x #f #t))
+ (if (null? expressions)
+ #f
+ (expand-or-expressions expressions)))))
;; FUNCTIONAL PROGRAMMING
;; LISTS
-; List creation
-(define (list . args) args)
-
; Return number of items in list
(define (length l)
(define (iter a count)
(iter (cdr a) (fix:+ count 1))))
(iter l 0))
-; Join two lists together
-(define (join l1 l2)
- (if (null? l1)
- l2
- (cons (car l1) (join (cdr l1) l2))))
-
-; Append an arbitrary number of lists together
-(define (append . lists)
- (if (null? lists)
- ()
- (if (null? (cdr lists))
- (car lists)
- (join (car lists) (apply append (cdr lists))))))
-
; Reverse the contents of a list
(define (reverse l)
(if (null? l)
(fix:+ n (sum-recurse (fix:- n 1)))))
-
;; MISC
(define (license)
: quote-body ( quote-obj -- quote-body-obj )
cdr car ;
-: quasiquote? ( obj -- obj bool )
- quasiquote-symbol tagged-list? ;
-
-: unquote? ( obj -- obj bool )
- unquote-symbol tagged-list? ;
-
-: unquote-splicing? ( obj -- obj bool )
- unquote-splicing-symbol tagged-list? ;
-
-: eval-unquote ( env obj -- res )
- cdr ( env args )
-
- nil? if
- except-message: ." no arguments to unquote." recoverable-exception throw
- then
-
- 2dup cdr
- nil? false = if
- except-message: ." too many arguments to unquote." recoverable-exception throw
- then
-
- 2drop car 2swap eval
-;
-
-( Create a new list from elements of l1 consed on to l2 )
-: join-lists ( l2 l1 -- l3 )
- nil? if 2drop exit then
-
- 2dup car
- -2rot cdr
- recurse cons
-;
-
-defer eval-quasiquote-item
-: eval-quasiquote-pair ( env obj -- res )
- 2over 2over ( env obj env obj )
-
- cdr eval-quasiquote-item
-
- -2rot car ( cdritem env objcar )
-
- unquote-splicing? if
- eval-unquote ( cdritems caritem )
-
- 2swap nil? if
- 2drop
- else
- 2swap join-lists
- then
- else
- eval-quasiquote-item ( cdritems caritem )
- 2swap cons
- then
-
-;
-
-:noname ( env obj )
- nil? if
- 2swap 2drop exit
- then
-
- unquote? if
- eval-unquote exit
- then
-
- pair-type istype? if
- eval-quasiquote-pair exit
- then
-
- 2swap 2drop
-; is eval-quasiquote-item
-
-: eval-quasiquote ( obj env -- res )
- 2swap cdr ( env args )
-
- nil? if
- except-message: ." no arguments to quasiquote." recoverable-exception throw
- then
-
- 2dup cdr ( env args args-cdr )
- nil? false = if
- except-message: ." too many arguments to quasiquote." recoverable-exception throw
- then
-
- 2drop car ( env arg )
-
- eval-quasiquote-item
-;
-
: variable? ( obj -- obj bool )
symbol-type istype? ;
exit
then
- quasiquote? if
- 2swap eval-quasiquote
- exit
- then
-
variable? if
2swap lookup-var
exit
R> drop ['] expand goto-deferred
;
-: expand-quasiquote-item ( exp -- result )
- nil? if exit then
-
- unquote? if
- unquote-symbol 2swap cdr car expand nil cons cons
- exit
- then
-
- unquote-splicing? if
- unquote-splicing-symbol 2swap cdr car expand nil cons cons
- exit
- then
-
- pair-type istype? if
- 2dup car recurse
- 2swap cdr recurse
- cons
- then
-;
-
-: expand-quasiquote ( exp -- result )
- quasiquote-symbol 2swap cdr
-
- expand-quasiquote-item
-
- cons ;
-
: expand-definition ( exp -- result )
define-symbol 2swap
quote? if exit then
- quasiquote? if expand-quasiquote exit then
-
definition? if expand-definition exit then
assignment? if expand-assignment exit then
The Lambda Lab / projects / scheme.forth.jl.git / commitdiff