Verified Commit 55460ad1 authored by 10's avatar 10
Browse files

Attributes look nicer

parent d256d387
; import doc
import syntax/attributes
import syntax/object
define dict [
@[
; documentation [
; title "Mutable hash-table object constructor"
; usage "dict name"
; example "
; dict test
; 5 6 test set
; 5 test get"
; section types
; ]
object-constructor [
init [ hash-table-empty ]
method has [ %get swap hash-table-exists dig drop ]
method get [ %get swap hash-table-get dig drop ]
method get! [ get swap drop ]
method set [ %get bury hash-table-set %set ]
method keys [ %get hash-table-keys swap drop ]
method ->hash-table [ %get ]
]
]
define-object-constructor dict [
init [ hash-table-empty ]
method has [ %get swap hash-table-exists dig drop ]
method get [ %get swap hash-table-get dig drop ]
method get! [ get swap drop ]
method set [ %get bury hash-table-set %set ]
method keys [ %get hash-table-keys swap drop ]
method ->hash-table [ %get ]
]
export dict
export-name dict
; vi: ft=scheme
......@@ -17,20 +17,17 @@
; ... any more...
; ]
import syntax/attributes
import syntax/attribute
import syntax/variable
import syntax/assign
import dict
import list
dict %docs
dict %tag-docs
lexical (%docs %tag-docs)
define documentation-set [
@[lexical %docs
lexical %tag-docs
lexical list-iterate
]
import list
const body
const name
name body %docs set
......@@ -51,15 +48,10 @@ define documentation-set [
]
]
define doc-for [
@[lexical %docs
lexical documentation-set
]
upquote upquote documentation-set
]
define doc-for [ upquote upquote documentation-set ]
lexical (%docs)
define doc-eval [
@[lexical %docs]
const name
upquote const defs
name %docs has if [
......@@ -78,44 +70,37 @@ define doc-eval [
] [ drop drop ]
]
define documentation [
@[lexical documentation-set]
define-attribute? if [] ["documentation must be used as an attribute" abort]
const body const name
name upquote documentation-set
name body
define-attribute documentation [
args (doc-body)
before [
const body const name
name doc-body documentation-set
name body
]
]
define has-documentation? [
@[lexical %docs]
%docs has
]
lexical (%docs)
define has-documentation? [ %docs has ]
define documented-names [
@[lexical %docs]
%docs keys
]
lexical (%docs)
define documented-names [ %docs keys ]
define doc-tags [
@[lexical %tag-docs]
%tag-docs ->hash-table
]
lexical (%tag-docs)
define doc-tags [ %tag-docs ->hash-table ]
define doc-tag? [
@[lexical %tag-docs]
%tag-docs has
]
lexical (%tag-docs)
define doc-tag? [ %tag-docs has ]
export doc-for
export doc-eval
export documentation
export documentation-set
export has-documentation?
export documented-names
export-name doc-for
export-name doc-eval
export-name documentation
export-name documentation-set
export-name has-documentation?
export-name documented-names
export doc-tags
export doc-tag?
export-name doc-tags
export-name doc-tag?
; vi: ft=scheme
......@@ -46,15 +46,6 @@ doc-for ansi [
tags [ui output]
]
doc-for %before-define [
title "Handler for adding definitions"
description "define calls this function before adding a definition.
Used by syntax/attributes. This is a hack."
internal
section syntax
tags [internal definition]
]
doc-for bury [
title "Stack rotation: a b c -> b c a"
description "Moves the top item on the stack to position 3"
......
......@@ -75,7 +75,7 @@ define check-docs [
define next [ names get list-empty? if [#f] [list-pop swap names set] ]
while [next equals? #f not] [check-doc] drop drop
]
export check-docs
export-name check-docs
; vi: ft=scheme
......
import syntax/attributes
; [l...] list-iterate [ body ... ]
define list-iterate [
import syntax/variable
......@@ -12,7 +10,11 @@ define list-iterate [
]
drop
]
export list-iterate
export-name list-iterate
; ; [l...] list-map [ body : l -> l' ] -> [l' ...]
; define list-map [
; ]
; list-quasiquote( ^[literal-list] *[list-expr] ~[single-value-expr] ... )
define list-quasiquote [
......@@ -25,7 +27,7 @@ define list-quasiquote [
upquote eval
%acc get
]
export list-quasiquote
export-name list-quasiquote
; vi: ft=scheme
......@@ -9,9 +9,9 @@ define-racket-builtin interpreter-stack
(lambda (c s) (values c (cons s s)))
define-racket-builtin interpreter-stack-set
(lambda (c s) (values c (stack-top s list?)))
export interpreter-dump-stack
export interpreter-stack
export interpreter-stack-set
export-name interpreter-dump-stack
export-name interpreter-stack
export-name interpreter-stack-set
define-racket-builtin add
(lambda (c s) (values c
......@@ -19,7 +19,7 @@ define-racket-builtin add
(stack-top (cdr s) number?))
(cddr s))))
export add
export-name add
define-racket-builtin port-has-char?
(lambda (c s) (values c (cons (char-ready? (stack-top s input-port?)) s)))
......@@ -37,11 +37,11 @@ define-racket-builtin port-write-value
(write (stack-top s) (stack-top (cdr s) output-port?))
(values c (cdr s)))
export port-has-char?
export port-peek-char
export port-read-char
export port-write-string
export port-write-value
export-name port-has-char?
export-name port-peek-char
export-name port-read-char
export-name port-write-string
export-name port-write-value
define-racket-builtin definition-exists
(lambda (c s)
......@@ -81,10 +81,10 @@ define-racket-builtin defined-names
(hash-keys a))))])
(values c (cons names s))))
export definition-exists
export definition-get
export definition-remove
export defined-names
export-name definition-exists
export-name definition-get
export-name definition-remove
export-name defined-names
define-racket-builtin current-context-remove-children
(lambda (c s)
......@@ -96,7 +96,7 @@ define-racket-builtin current-context-remove-children
#:parent (context-parent c))
s))
export current-context-remove-children
export-name current-context-remove-children
define-racket-builtin hash-table?
(lambda (c s) (values c (cons (hash? (stack-top s)) s)))
......@@ -126,13 +126,13 @@ define-racket-builtin hash-table-remove
[h (stack-top (cdr s) hash?)])
(values c (cons (hash-remove h k) (cddr s)))))
export hash-table?
export hash-table-empty
export hash-table-exists
export hash-table-get
export hash-table-set
export hash-table-keys
export hash-table-remove
export-name hash-table?
export-name hash-table-empty
export-name hash-table-exists
export-name hash-table-get
export-name hash-table-set
export-name hash-table-keys
export-name hash-table-remove
; Places - A place is a mutable storage location
; capable of storing exactly one item.
......@@ -153,10 +153,14 @@ define-racket-builtin place-set
(set-mplace-v! p v)
(values c (cdr s))))
export place?
export make-place
export place-get
export place-set
export-name place?
export-name make-place
export-name place-get
export-name place-set
; define-racket-builtin list-join
; (lambda (c s) (values c (cons (apply append (stack-top s list?)) (cdr s))))
; export-name list-join
; vi: ft=scheme
......
......@@ -9,7 +9,7 @@
; are like
; expr const a
import syntax/attributes
import syntax/attribute
; [add-args ...] [named-arg ...] %make-assign-consts
; => [quote named-arg updo adddef add-args ...]
......@@ -32,10 +32,11 @@ define %make-assign-consts [
; Put values from the stack into names
; e.g. 1 2 3 => [a b c]
; now a = 1, b = 2, c = 3
define => [@[lexical %make-assign-consts] [] upquote %make-assign-consts eval ]
lexical (%make-assign-consts)
define => [ [] upquote %make-assign-consts eval ]
lexical (%make-assign-consts)
define := [
@[lexical %make-assign-consts]
const args
updo evaluate
......@@ -43,8 +44,8 @@ define := [
eval
]
export :=
export =>
export-name :=
export-name =>
; vi: ft=scheme
......
; attribute ...
; define func [...]
; Attributes are definitions you can use to augment the next define form.
define define-attribute [
import list
import syntax/variable
upquote const name
upquote const def-body
[] variable %args
define args [
[[]]
upquote list-iterate [
const arg
[upquote list-push quote quote list-push list-append]
[] arg list-push quote const list-push
list-push
list-append
]
%args set
]
[] variable %before
define before [ upquote %before set ]
def-body eval
%args get
[list-append] %before get list-push list-append
[quote %before-define updo definition-get swap drop [] or bury drop drop
list-append
quote %before-define updo definition-add
]
list-append
name updo definition-add+attributes
]
export-name define-attribute
define definition-add+attributes [
quote %before-define updo definition-get swap drop false? if [drop] [eval]
quote %before-define updo definition-remove
updo definition-add
]
export-name definition-add+attributes
define define [
upquote upquote swap
updo definition-add+attributes
]
export-name define
define-attribute lexical [
args (names)
before [
import list
swap
names
list-iterate [
const name
quote definition-add list-push
name list-push
quote quote list-push
name definition-resolve
false? if ["lexical: not defined: " dig ->string string-append abort] []
swap drop list-push
]
swap
]
]
export-name lexical
; vi: ft=scheme
"Use syntax/attribute instead!" abort
; define f [ @[attribute ...] body... ]
; Redefines define to look for @ as the first item in the body.
; Evaluates the list immediately following the @ upon definition.
; TODO: Specify multiple @[attribute ...] forms.
define define-attribute? [#f]
export define-attribute?
define %define-attribute? [#f]
export %define-attribute?
; Monkey-patch definition-add to check for attributes.
[
; <definition-add> 'definition-add <definition-add> eval
; give definition-add its original definition again in this context
clone quote definition-add swap eval
; TODO if the attr messes with the define body, it might ruin the @ parsing
; so first collect all of the @ forms from the head and only then eval them all
define %before-define [
[] quote %before-define definition-add
define define-attribute? [#t]
; interpreter-dump-stack
define %%define-attribute []
define %define-attribute? [#t]
swap
; actual attribute stuff here
; TODO if the attr messes with the define body, it might ruin the @ parsing
; so for now it only deals with one @[] block
list-empty? if [] [
list-head equals? @ if [
drop
......@@ -21,13 +33,39 @@ define %before-define [
eval
] [drop]
]
swap
; use the original definition-add in the parent context
; can't just uplevel it because that will just call this version again
quote definition-add definition-get swap drop quote eval uplevel
]
; grab a copy of <definition-add> and put it in this def
quote definition-add definition-resolve swap drop list-push
; now actually define it
quote definition-add definition-add
export definition-add
; TODO make this work
define define-attribute [
upquote name
upquote body
[quote %%define-attribute definition-resolve swap drop not not if []]
[abort]
" must be used as an attribute" name ->string string-append
list-push
[] swap list-push
list-append
interpreter-dump-stack
swap quote definition-add
]
export %before-define
export define-attribute
; ; lexical-alias newname oldname
; Clone the definition referred to by oldname and define it as newname.
define lexical-alias [
define-attribute? if [
%define-attribute? if [
updo upquote const newname
updo upquote const origname
; [quote def quote name definition-add body ...]
......@@ -46,7 +84,7 @@ export lexical-alias
; ; lexical name
; ; Lexically scope the given definition name
define lexical [
define-attribute? if [] ["lexical must be used as an attribute" abort]
%define-attribute? if [] ["lexical must be used as an attribute" abort]
upquote const name
; [quote def quote name definition-add body ...]
quote definition-add list-push
......@@ -60,7 +98,7 @@ export lexical
; [body...] val static name
; Like const, but shared between invocations.
define static [
define-attribute? if [] ["static must be used as an attribute" abort]
%define-attribute? if [] ["static must be used as an attribute" abort]
; basically prepend [quote v const name] to body
swap
upquote list-push
......
import syntax/attributes
import doc
documentation [
title "Choose a block of code to run based on the matching condition"
description "It's basically an if/elseif/else block."
usage "cond [ [-> bool] { if-true ... } ... ]"
example "cond [[#f] [0] [#t] [1]]"
example "6 cond [[equals? 2] [200] [equals? 6] [600] [#t] [-1]]"
; section eval
; tags []
]
define cond [
@[documentation [
title "Choose a block of code to run based on the matching condition"
description "It's basically an if/elseif/else block."
usage "cond [ [-> bool] { if-true ... } ... ]"
example "cond [[#f] [0] [#t] [1]]"
example "6 cond [[equals? 2] [200] [equals? 6] [600] [#t] [-1]]"
; section eval
; tags []
]]
import syntax/variable
......@@ -30,7 +29,7 @@ define cond [
eval
]
export cond
export-name cond
; vi: ft=scheme
......
......@@ -27,7 +27,7 @@ define function [
func-name updo definition-add
]
export function
export-name function
; vi: ft=scheme
......
; import doc ; oops, doc requires this!
import syntax/attributes
import syntax/variable
import list
define object-constructor [
@[lexical list-quasiquote]
lexical (list-quasiquote)
define define-object-constructor [
; documentation [
; title "Create a named value with accessor and mutator methods"
; description "Turns the enclosing define form into a constructor"
; usage "define ctor [@[object-constructor [define method [...] ...]]]"
; example "
; define variable [
; @[object-constructor [
; define-object-constructor variable [
; method get [%get]
; method set [%set]
; ]]
; ]
; 6 variable n
......@@ -25,13 +17,7 @@ define object-constructor [
import syntax/variable
import list
define-attribute?
if [] ["object-constructor must be used as an attribute" abort]
list-empty? if [drop] [
"object-constructor: define body must be empty" abort
]
const dname
upquote const dname
[] variable methods
[] variable init-expr
......@@ -76,9 +62,10 @@ define object-constructor [
name updo definition-add
]
]
dname swap
dname
updo definition-add+attributes
]
export object-constructor
export-name define-object-constructor
; vi: ft=scheme
......@@ -26,7 +26,7 @@ define variable [
P list-push
name updo definition-add
]
export variable
export-name variable
; vi: ft=scheme
......
import ui/ansi
export ansi
export-name ansi