view modules/parser.tp @ 218:b799192e404b

Implemented match:where:yield and fixed a bug in zeroPlus
author Michael Pavone <pavone@retrodev.com>
date Sat, 21 Dec 2013 12:08:06 -0800
parents e00a8bc6361b
children a1a80af71b05
line wrap: on
line source

#{
	_applyMatch <- :fun tomatch {
		fun: tomatch
	}
	_matchString <- :str tomatch {
		if: (tomatch isString?) {
			if: (tomatch length) < (str length) {
				#{
					matched? <- { false }
				}
			} else: {
				if: (tomatch length) > (str length) {
					tomatch <- tomatch from: 0 withLength: (str length)
				}
				if: str = tomatch {
					#{
						matched? <- { true }
						matchlen <- { str length }
						basicYield? <- { true }
						yield <- { str }
					}
				} else: {
					#{
						matched? <- { false }
					}
				}
			}
		} else: {
			#{
				matched? <- { false }
			}
		}
	}
	ifmatch:else <- :matchres :elseblock {
		if: (matchres matched?) {
			matchres
		} else: {
			elseblock:
		}
	}
	_makeMatchCall <- :matchexpr {
		if: (matchexpr nodeType) = "lambda" {
			#{
				valid? <- { true }
				matchcall <- quote: (_applyMatch: matchexpr tomatch)
			}
		} else: {
			if: (matchexpr nodeType) = "symbol" {
				#{
					valid? <- { true }
					matchcall <- quote: (matchexpr: tomatch)
				}
			} else: {
				if: (matchexpr nodeType) = "strlit" {
					#{
						valid? <- { true }
						matchcall <- quote: (_matchString: matchexpr tomatch)
					}
				} else: {
					if: (matchexpr nodeType) = "op" {
						if: (matchexpr opName) = "." {
							left <- (_makeMatchCall: (matchexpr left)) matchcall
							right <- (_makeMatchCall: (matchexpr right)) matchcall
							#{
								valid? <- { true }
								matchcall <- quote: (_applyMatch: :tomatch {
									lm <- left
									if: (lm matched?) {
										tomatch <- tomatch from: (lm matchlen)
										rm <- right
										if: (rm matched?) {
											total <- (rm matchlen) + (lm matchlen)
											#{
												matched? <- { true }
												matchlen <- { total }
												basicYield? <- { true }
												yield <- { tomatch from: 0 withLen: total }
											}
										} else: {
											rm
										}
									} else: {
										lm
									}
								} tomatch)
							}
						} else: {
							#{
								valid? <- { false }
								message <- "Unsupported operator " . (matchexpr opName)
							}
						}
					} else: {
						#{
							valid? <- { false }
							message <- "Unsupported AST node type " . (matchexpr nodeType)
						}
					}
				}
			}
		}
	}
	expandClass <- :chars {
		if: (chars length) > 0 {
			pos <- 0
			inverted <- false
			if: (chars byte: 0) = ("^" byte: 0) {
				pos <- 1
				inverted <- true
			}
			state_begin <- 0
			state_normal <- 1
			state_rangeend <- 2
			state <- state_begin
			out <- ""
			while: { pos < (chars byte_length)} do: {
				if: state = state_begin {
					out <- out . (chars from: pos withLength: 1)
					state <- state_normal
				} else: {
					if: state = state_normal {
						if: (chars byte: pos) = ("-" byte: 0) {
							state <- state_rangeend
						} else: {
							out <- out . (chars from: pos withLength: 1)
						}
					} else: {
						rangestart <- out byte: ((out byte_length) - 1)
						rangeend <- chars byte: pos
						if: rangeend < rangestart {
							tmp <- rangeend
							rangeend <- rangestart
							rangestart <- tmp
						}
						out <- out from: 0 withLength: ((out length) - 1)
						while: { rangestart <= rangeend } do: {
							out <- out . (rangestart asStringChar)
							rangestart <- rangestart + 1
						}
						state <- state_begin
					}
				}
				pos <- pos + 1
			}
			if: inverted {
				old <- out
				out <- ""
				//skip control characters for now
				cur <- 32
				while: { cur < 256 } do: {
					notfound <- true
					idx <- 0
					len <- (old length)
					while: { notfound && idx < len } do: {
						if: cur = (old byte: idx) {
							notfound <- false
						} else: {
							idx <- idx + 1
						}
					}
					if: notfound {
						out <- out . (cur asStringChar)
					}
					cur <- cur + 1
				}
			}
			out
		} else: {
			""
		}
	}
	charClass <- macro: :rawchars {
		eval: rawchars :chars {
			orig <- chars
			chars <- expandClass: chars
			//TODO: Use a more sophisticated approach for large classes
			quote: :tomatch {
				if: (tomatch isString?) {
					check <- 0

					nomatch <- true
					while: { nomatch && check < (chars byte_length) } do: {
						if: (tomatch byte: 0) = (chars byte: check) {
							nomatch <- false
						}
						check <- check + 1
					}
					if: nomatch {
						#{
							matched? <- { false }
						}
					} else: {
						#{
							matched? <- { true }
							matchlen <- { 1 }
							basicYield? <- { true }
							yield <- { tomatch from: 0 withLength: 1 }
						}
					}
				} else: {
					#{
						matched? <- { false }
					}
				}
			}
		} else: {
			print: "#error Argument to charClass macro must be a compile-time constant\n"
		}
	}

	zeroPlus <- macro: :matchexpr {
		funexpr <- false
		valid <- false
		mc <- _makeMatchCall: matchexpr
		if: (mc valid?) {
			mcall <- mc matchcall
			quote: :tomatch {
				cur <- 0
				n <- tomatch byte_length
				orig <- tomatch
				match <- true
				allBasic? <- true
				yieldvals <- []
				while: { match && cur < n } do: {
					res <- mcall
					match <- res matched?
					if: match {
						//TODO: Use some kind of lightweight substring wrapper here
						tomatch <- tomatch from: (res matchlen)
						if: allBasic? {
							ifnot: (res basicYield?) {
								allBasic? <- false
								if: cur > 0 {
									yieldvals <- (orig from: 0 withLength: cur) | yieldvals
								}
								yieldvals <- (res yield) | yieldvals
							}
						} else: {
							yieldvals <- (res yield) | yieldvals
						}
						allBasic? <- allBasic? && (res basicYield?)
						cur <- cur + (res matchlen)
					}
				}
				if: cur > 0 {
					if: allBasic? {
						#{
							matched? <- { true }
							matchlen <- { cur }
							basicYield? <- { true }
							yield <- { orig from: 0 withLength: cur }
						}
					} else: {
						yieldvals <- yieldvals reverse
						#{
							matched? <- { true }
							matchlen <- { cur }
							basicYield? <- { false }
							yield <- { yieldvals }
						}
					}
				} else: {
					#{
						matched? <- { false }
					}
				}
			}
		} else: {
			print: "#error Invalid zeroPlus macro call: " . (mc message) . "\n"
		}
	}

	matchOne <- macro: :options {
		options <- (options value) map: :option {
			_makeMatchCall: option
		}
		body <- options foldr: (quote: #{
			matched? <- { false }
		}) with: :acc el {
			if: (el valid?) {
				mcall <- el matchcall
				quote: (ifmatch: mcall else: { acc })
			} else: {
				print: "#error Invalid matchOne macro call: " . (el message) . "\n"
				acc
			}
		}
		quote: :tomatch {
			body
		}
	}

	match:yield <- macro: :matchexpr :ylambda {
		mc <- _makeMatchCall: matchexpr
		if: (mc valid?) {
			mcall <- mc matchcall
			quote: :tomatch {
				res <- mcall
				if: (res matched?) {
					#{
						matched? <- { true }
						matchlen <- { res matchlen }
						basicYield? <- { false }
						yield <- ylambda
					}
				} else: {
					res
				}
			}
		} else: {
			print: "#error Invalid macth:yield macro call: " . (mc message) . "\n"
		}
	}

	match:where:yield <- macro: :matchexpr :whereclause :ylambda {
		syms <- []
		withwhere <- (whereclause expressions) fold: (quote: :tomatch {}) with: :acc el {

			if: (el nodeType) = "assignment" {
				valassign <- quote: (val <- false)
				valsym <- (valassign) symbol
				valsym <- valsym name!: (valsym name) . ((el symbol) name)
				valassign <- valassign symbol!: valsym
				acc addExpression: valassign

				matchassign <- quote: (hasmatch <- false)
				matchsym <- (matchassign) symbol
				matchsym <- matchsym name!: (matchsym name) . ((el symbol) name)
				matchassign <- matchassign symbol!: matchsym
				acc addExpression: matchassign

				mc <- _makeMatchCall: (el expression)

				if: (mc valid?) {
					mcall <- mc matchcall
					matchfun <- quote: :tomatch {
						if: matchsym {
							if: valsym = tomatch {
								#{
									matched? <- { true }
									matchlen <- { valsym length }
									basicYield? <- { true } //TODO: Check if this is correct
									yield <- { valsym }
								}
							} else: {
								#{
									matched? <- { false }
								}
							}
						} else: {
							mr <- mcall
							if: (mr matched?) {
								matchsym <- true
								valsym <- (mr yield)
							}
							mr
						}
					}
					acc <- acc addExpression: (el expression!: matchfun)
					syms <- list node: #{
						orig <- el symbol
						matchval <- valsym
					} withTail: syms
					acc
				} else: {
					print: "#error " . ((el symbol) name) . " does not have a valid match expression: " . (mc message) . "\n"
				}

			} else: {
				print: "#error Nodes of type " . (el nodeType) . " are not allowed in match where clauses\n"
				acc
			}
		}
		mcMain <- _makeMatchCall: matchexpr
		if: (mcMain valid?) {
			mcall <- mcMain matchcall
			withwhere addExpression: (quote: (matchres <- mcall))
			successLambda <- quote: {
				//Extra assignments will be added here
				mlen <- matchres matchlen
				#{
					matched? <- { true }
					matchlen <- { mlen }
					basicYield? <- { false }
					yield <- ylambda
				}
			}
			sucexp <- syms fold: (successLambda expressions) with: :acc el {
				lsym <- el orig
				rsym <- el matchval
				(quote: (lsym <- rsym)) | acc
			}
			successLambda <- successLambda expressions!: sucexp
			withwhere addExpression: (quote: (if: (matchres matched?) successLambda else: {
				matchres
			}))
			withwhere
		} else: {
			print: "#error Error in main match expression of match:where:yield: " . (mcMain message) . "\n"
		}
	}


	_alpha <- charClass: "a-zA-Z"
	alpha <- zeroPlus: _alpha
	alphaNum <- zeroPlus: (charClass: "a-zA-Z0-9")
	hws <- zeroPlus: (matchOne: [
		(charClass: " \t")
		"/*" . (zeroPlus: (matchOne: [(charClass: "^*") "*" . (charClass: "^/")])) . "*/"
	])

	digit <- matchOne: [
		(match: "0" yield: {0})
		(match: "1" yield: {1})
		(match: "2" yield: {2})
		(match: "3" yield: {3})
		(match: "4" yield: {4})
		(match: "5" yield: {5})
		(match: "6" yield: {6})
		(match: "7" yield: {7})
		(match: "8" yield: {8})
		(match: "9" yield: {9})
	]

	posint <- match: Digits where: {
		Digits <- zeroPlus: digit
	} yield: {
		num <- Digits fold: 0 with: :acc el {
			print: "Element " . el . "\n"
			acc * 10 + el
		}
		#{
			litval <- num
		}
	}

	main <- {
		cmatch <- alpha: "czx0123"
		zeromatch <- alpha: "01234"
		if: (cmatch matched?) {
			print: "czx0123 matched with length " . (cmatch matchlen) . "\n"
		} else: {
			print: "czx0123 didn't match\n"
		}
		if: (zeromatch matched?) {
			print: "0123 matched with length " . (zeromatch matchlen) . "\n"
		} else: {
			print: "0123 didn't match\n"
		}
		zeromatchanum <- alphaNum: "01234"
		if: (zeromatchanum matched?) {
			print: "01234 matched with length " . (zeromatchanum matchlen) . "\n"
		} else: {
			print: "01234 didn't match\n"
		}
		stuff <- " \t/* blah blah blah * blah */ foo"
		hwsmatch <- hws: stuff
		if: (hwsmatch matched?) {
			print: "'" . (stuff from: (hwsmatch matchlen)) . "' found after hws\n"
		} else: {
			print: stuff . " did not match hws rule\n"
		}
		tmatch <- digit: "3"
		if: (tmatch matched?) {
			print: "3 matched with yield " . (tmatch yield) . ", yield + 1 = " . ((tmatch yield) + 1) . "\n"
		} else: {
			print: "3 did not match\n"
		}

		posintm <- posint: "345"
		if: (posintm matched?) {
			print: "345 matched with intlit value " . ((posintm yield) litval) . "\n"
		} else: {
			print: "345 did not match\n"
		}
	}
}